From 3ac475560ec9df896a483645fc8ff46cbac3bc1f Mon Sep 17 00:00:00 2001 From: Hongjian Fang Date: Thu, 5 May 2016 12:52:53 +0200 Subject: [PATCH] new release 2016 share to public --- configure | 2 +- srcsmooth/CalSurfG.f90 | 2838 ---------------------------- srcsmooth/DSurfTomo | Bin 294584 -> 0 bytes srcsmooth/Makefile | 20 - srcsmooth/aprod.f90 | 60 - srcsmooth/delsph.f90 | 28 - srcsmooth/gaussian.f90 | 31 - srcsmooth/lsmrDataModule.f90 | 24 - srcsmooth/lsmrModule.f90 | 754 -------- srcsmooth/lsmrblas.f90 | 360 ---- srcsmooth/lsmrblasInterface.f90 | 41 - srcsmooth/main.f90 | 616 ------- srcsmooth/surfdisp96.f | 1062 ----------- srcsparsity/CalSurfG.f90 | 2841 ----------------------------- srcsparsity/Makefile | 25 - srcsparsity/aprod.f90 | 60 - srcsparsity/delsph.f90 | 28 - srcsparsity/forwardstep.f90 | 26 - srcsparsity/forwardtrans.f90 | 47 - srcsparsity/gaussian.f90 | 31 - srcsparsity/haar.f90 | 49 - srcsparsity/inversestep.f90 | 25 - srcsparsity/inversetrans.f90 | 47 - srcsparsity/invtrans3d.f90 | 32 - srcsparsity/lsmrDataModule.f90 | 24 - srcsparsity/lsmrModule.f90 | 754 -------- srcsparsity/lsmrblas.f90 | 360 ---- srcsparsity/lsmrblasInterface.f90 | 41 - srcsparsity/main.f90 | 756 -------- srcsparsity/merge1.f90 | 21 - srcsparsity/split.f90 | 24 - srcsparsity/surfdisp96.f | 1062 ----------- srcsparsity/waveletD8.f90 | 113 -- srcsparsity/wavelettrans3domp.f90 | 90 - 34 files changed, 1 insertion(+), 12291 deletions(-) delete mode 100644 srcsmooth/CalSurfG.f90 delete mode 100755 srcsmooth/DSurfTomo delete mode 100644 srcsmooth/Makefile delete mode 100644 srcsmooth/aprod.f90 delete mode 100644 srcsmooth/delsph.f90 delete mode 100644 srcsmooth/gaussian.f90 delete mode 100644 srcsmooth/lsmrDataModule.f90 delete mode 100644 srcsmooth/lsmrModule.f90 delete mode 100644 srcsmooth/lsmrblas.f90 delete mode 100644 srcsmooth/lsmrblasInterface.f90 delete mode 100644 srcsmooth/main.f90 delete mode 100644 srcsmooth/surfdisp96.f delete mode 100644 srcsparsity/CalSurfG.f90 delete mode 100644 srcsparsity/Makefile delete mode 100644 srcsparsity/aprod.f90 delete mode 100644 srcsparsity/delsph.f90 delete mode 100644 srcsparsity/forwardstep.f90 delete mode 100644 srcsparsity/forwardtrans.f90 delete mode 100644 srcsparsity/gaussian.f90 delete mode 100644 srcsparsity/haar.f90 delete mode 100644 srcsparsity/inversestep.f90 delete mode 100644 srcsparsity/inversetrans.f90 delete mode 100644 srcsparsity/invtrans3d.f90 delete mode 100644 srcsparsity/lsmrDataModule.f90 delete mode 100644 srcsparsity/lsmrModule.f90 delete mode 100644 srcsparsity/lsmrblas.f90 delete mode 100644 srcsparsity/lsmrblasInterface.f90 delete mode 100644 srcsparsity/main.f90 delete mode 100644 srcsparsity/merge1.f90 delete mode 100644 srcsparsity/split.f90 delete mode 100644 srcsparsity/surfdisp96.f delete mode 100644 srcsparsity/waveletD8.f90 delete mode 100644 srcsparsity/wavelettrans3domp.f90 diff --git a/configure b/configure index 260cf6b..cc38a3b 100755 --- a/configure +++ b/configure @@ -12,5 +12,5 @@ os.system('make clean') os.system('make') os.system('cp DSurfTomo ../bin') print '--------------------------------------' -print 'surf_tomo install over' +print 'Finishing DSurfTomo compiling' print '--------------------------------------' diff --git a/srcsmooth/CalSurfG.f90 b/srcsmooth/CalSurfG.f90 deleted file mode 100644 index 312cfa3..0000000 --- a/srcsmooth/CalSurfG.f90 +++ /dev/null @@ -1,2838 +0,0 @@ - subroutine depthkernel(nx,ny,nz,vel,pvRc,sen_vsRc,sen_vpRc,sen_rhoRc, & - iwave,igr,kmaxRc,tRc,depz,minthk) - use omp_lib - implicit none - - integer nx,ny,nz - real vel(nx,ny,nz) - real*8 sen_vpRc(ny*nx,kmaxRc,nz),sen_vsRc(ny*nx,kmaxRc,nz),sen_rhoRc(ny*nx,kmaxRc,nz) - - integer iwave,igr - real minthk - real depz(nz) - integer kmaxRc - real*8 tRc(kmaxRc) - real*8 pvRc(nx*ny,kmaxRc) - - - - real vpz(nz),vsz(nz),rhoz(nz) - real*8 dlncg_dlnvs(kmaxRc,nz),dlncg_dlnvp(kmaxRc,nz),dlncg_dlnrho(kmaxRc,nz) - integer mmax,iflsph,mode,rmax - integer ii,jj,k,i,nn,kk - integer,parameter::NL=200 - integer,parameter::NP=60 - real*8 cg1(NP),cg2(NP),cga,cgRc(NP) - real rdep(NL),rvp(NL),rvs(NL),rrho(NL),rthk(NL) - real depm(NL),vpm(NL),vsm(NL),rhom(NL),thkm(NL) - real dlnVs,dlnVp,dlnrho - - - mmax=nz - iflsph=1 - mode=1 - dlnVs=0.01 - dlnVp=0.01 - dlnrho=0.01 - - !print*,'depth kernel begin...' -!$omp parallel & -!$omp default(private) & -!$omp shared(depz,nx,ny,nz,minthk,dlnvs,dlnvp,dlnrho,kmaxRc,mmax,vel) & -!$omp shared(sen_vpRc,sen_vsRc,sen_rhoRc,tRc,pvRc,iflsph,iwave,mode,igr) -!$omp do - do jj=1,ny - do ii=1,nx - vsz(1:nz)=vel(ii,jj,1:nz) - ! some other emperical relationship maybe better, - do k=1,nz - vpz(k)=0.9409 + 2.0947*vsz(k) - 0.8206*vsz(k)**2+ & - 0.2683*vsz(k)**3 - 0.0251*vsz(k)**4 - rhoz(k)=1.6612*vpz(k) - 0.4721*vpz(k)**2 + & - 0.0671*vpz(k)**3 - 0.0043*vpz(k)**4 + & - 0.000106*vpz(k)**5 - enddo - - call refineGrid2LayerMdl(minthk,mmax,depz,vpz,vsz,rhoz,rmax,rdep,& - rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,igr,kmaxRc,& - tRc,cgRc) - pvRc((jj-1)*nx+ii,1:kmaxRc)=cgRc(1:kmaxRc) - !print*,cgRc(1:kmaxRc) - do kk=1,mmax-1 - depm(kk)=depz(kk) - vsm(kk) = vsz(kk) - vpm(kk) = vpz(kk) - thkm(kk) = depz(kk+1)-depz(kk) - rhom(kk) = rhoz(kk) - enddo - !!half space - depm(mmax) = depz(mmax) - vsm(mmax) = vsz(mmax) - vpm(mmax) = vpz(mmax) - rhom(mmax) = rhoz(mmax) - thkm(mmax) = 0.0 - !! calculate sensitivity kernel - do i = 1, mmax - vsm(i) = vsz(i) - 0.5*dlnVs*vsz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg1) - - vsm(i) = vsz(i) + 0.5*dlnVs*vsz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg2) - vsm(i) = vsz(i) - - do nn = 1,kmaxRc - cga = 0.5*(cg1(nn)+cg2(nn)) - dlncg_dlnvs(nn,i) = (cg2(nn)-cg1(nn))/cga/dlnVs - enddo - - - vpm(i) = vpz(i) - 0.5*dlnVp*vpz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg1) - - vpm(i) = vpz(i) + 0.5*dlnVp*vpz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg2) - vpm(i) = vpz(i) - - do nn = 1,kmaxRc - cga = 0.5*(cg1(nn)+cg2(nn)) - dlncg_dlnvp(nn,i) = (cg2(nn)-cg1(nn))/cga/dlnVp - enddo - rhom(i) = rhoz(i) - 0.5*dlnrho*rhoz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg1) - - rhom(i) = rhoz(i) + 0.5*dlnrho*rhoz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg2) - rhom(i) = rhoz(i) - - do nn = 1,kmaxRc - cga = 0.5*(cg1(nn)+cg2(nn)) - dlncg_dlnrho(nn,i) = (cg2(nn)-cg1(nn))/cga/dlnrho - enddo - enddo - sen_vsRc((jj-1)*nx+ii,1:kmaxRc,1:mmax)=dlncg_dlnvs(1:kmaxRc,1:mmax) - sen_vpRc((jj-1)*nx+ii,1:kmaxRc,1:mmax)=dlncg_dlnvp(1:kmaxRc,1:mmax) - sen_rhoRc((jj-1)*nx+ii,1:kmaxRc,1:mmax)=dlncg_dlnrho(1:kmaxRc,1:mmax) - ! print*,dlncg_dlnvp(1:kmaxRc,5) - enddo - enddo -!$omp end do -!$omp end parallel - end subroutine depthkernel - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: MODULE -! CODE: FORTRAN 90 -! This module declares variable for global use, that is, for -! USE in any subroutine or function or other module. -! Variables whose values are SAVEd can have their most -! recent values reused in any routine. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MODULE globalp -IMPLICIT NONE -INTEGER, PARAMETER :: i10=SELECTED_REAL_KIND(6) -INTEGER :: checkstat -INTEGER, SAVE :: nvx,nvz,nnx,nnz,fom,gdx,gdz -INTEGER, SAVE :: vnl,vnr,vnt,vnb,nrnx,nrnz,sgdl,rbint -INTEGER, SAVE :: nnxr,nnzr,asgr -INTEGER, DIMENSION (:,:), ALLOCATABLE :: nsts,nstsr,srs -REAL(KIND=i10), SAVE :: gox,goz,dnx,dnz,dvx,dvz,snb,earth -REAL(KIND=i10), SAVE :: goxd,gozd,dvxd,dvzd,dnxd,dnzd -REAL(KIND=i10), SAVE :: drnx,drnz,gorx,gorz -REAL(KIND=i10), SAVE :: dnxr,dnzr,goxr,gozr -REAL(KIND=i10), DIMENSION (:,:), ALLOCATABLE, SAVE :: velv,veln,velnb -REAL(KIND=i10), DIMENSION (:,:), ALLOCATABLE, SAVE :: ttn,ttnr -!REAL(KIND=i10), DIMENSION (:), ALLOCATABLE, SAVE :: rcx,rcz -REAL(KIND=i10), PARAMETER :: pi=3.1415926535898 -!!!-------------------------------------------------------------- -!! modified by Hongjian Fang @ USTC -! real,dimension(:),allocatable,save::rw -! integer,dimension(:),allocatable,save::iw,col -! real,dimension(:,:,:),allocatable::vpf,vsf -! real,dimension(:),allocatable,save::obst,cbst,wt,dtres -!! integer,dimension(:),allocatable,save::cbst_stat -! real,dimension(:,:,:),allocatable,save::sen_vs,sen_vp,sen_rho -!!! real,dimension(:,:,:),allocatable,save::sen_vsRc,sen_vpRc,sen_rhoRc -!!! real,dimension(:,:,:),allocatable,save::sen_vsRg,sen_vpRg,sen_rhoRg -!!! real,dimension(:,:,:),allocatable,save::sen_vsLc,sen_vpLc,sen_rhoLc -!!! real,dimension(:,:,:),allocatable,save::sen_vsLg,sen_vpLg,sen_rhoLg -!!! integer,save:: count1,count2 -! integer*8,save:: nar -! integer,save:: iter,maxiter -!!!-------------------------------------------------------------- -! -! nvx,nvz = B-spline vertex values -! dvx,dvz = B-spline vertex separation -! velv(i,j) = velocity values at control points -! nnx,nnz = Number of nodes of grid in x and z -! nnxr,nnzr = Number of nodes of refined grid in x and z -! gox,goz = Origin of grid (theta,phi) -! goxr, gozr = Origin of refined grid (theta,phi) -! dnx,dnz = Node separation of grid in x and z -! dnxr,dnzr = Node separation of refined grid in x and z -! veln(i,j) = velocity values on a refined grid of nodes -! velnb(i,j) = Backup of veln required for source grid refinement -! ttn(i,j) = traveltime field on the refined grid of nodes -! ttnr(i,j) = ttn for refined grid -! nsts(i,j) = node status (-1=far,0=alive,>0=close) -! nstsr(i,j) = nsts for refined grid -! checkstat = check status of memory allocation -! fom = use first-order(0) or mixed-order(1) scheme -! snb = Maximum size of narrow band as fraction of nnx*nnz -! nrc = number of receivers -! rcx(i),rcz(i) = (x,z) coordinates of receivers -! earth = radius of Earth (in km) -! goxd,gozd = gox,goz in degrees -! dvxd,dvzd = dvx,dvz in degrees -! dnzd,dnzd = dnx,dnz in degrees -! gdx,gdz = grid dicing in x and z -! vnl,vnr,vnb,vnt = Bounds of refined grid -! nrnx,nrnz = Number of nodes in x and z for refined grid -! gorx,gorz = Grid origin of refined grid -! sgdl = Source grid dicing level -! rbint = Ray-boundary intersection (0=no, 1=yes). -! asgr = Apply source grid refinement (0=no,1=yes) -! srs = Source-receiver status (0=no path, 1=path exists) -! -END MODULE globalp - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: MODULE -! CODE: FORTRAN 90 -! This module contains all the subroutines used to calculate -! the first-arrival traveltime field through the grid. -! Subroutines are: -! (1) travel -! (2) fouds1 -! (3) fouds2 -! (4) addtree -! (5) downtree -! (6) updtree -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MODULE traveltime -USE globalp -IMPLICIT NONE -INTEGER ntr -TYPE backpointer - INTEGER(KIND=2) :: px,pz -END TYPE backpointer -TYPE(backpointer), DIMENSION (:), ALLOCATABLE :: btg -! -! btg = backpointer to relate grid nodes to binary tree entries -! px = grid-point in x -! pz = grid-point in z -! ntr = number of entries in binary tree -! - -CONTAINS - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine is passed the location of a source, and from -! this point the first-arrival traveltime field through the -! velocity grid is determined. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE travel(scx,scz,urg) -IMPLICIT NONE -INTEGER :: isx,isz,sw,i,j,ix,iz,urg,swrg -REAL(KIND=i10) :: scx,scz,vsrc,dsx,dsz,ds -REAL(KIND=i10), DIMENSION (2,2) :: vss -! isx,isz = grid cell indices (i,j,k) which contains source -! scx,scz = (r,x,y) location of source -! sw = a switch (0=off,1=on) -! ix,iz = j,k position of "close" point with minimum traveltime -! maxbt = maximum size of narrow band binary tree -! rd2,rd3 = substitution variables -! vsrc = velocity at source -! vss = velocity at nodes surrounding source -! dsx, dsz = distance from source to cell boundary in x and z -! ds = distance from source to nearby node -! urg = use refined grid (0=no,1=yes,2=previously used) -! swrg = switch to end refined source grid computation -! -! The first step is to find out where the source resides -! in the grid of nodes. The cell in which it resides is -! identified by the "north-west" node of the cell. If the -! source lies on the edge or corner (a node) of the cell, then -! this scheme still applies. -! -isx=INT((scx-gox)/dnx)+1 -isz=INT((scz-goz)/dnz)+1 -sw=0 -IF(isx.lt.1.or.isx.gt.nnx)sw=1 -IF(isz.lt.1.or.isz.gt.nnz)sw=1 -IF(sw.eq.1)then - isx=90.0-isx*180.0/pi - isz=isz*180.0/pi - WRITE(6,*)"Source lies outside bounds of model (lat,long)= ",isx,isz - WRITE(6,*)"TERMINATING PROGRAM!!!" - STOP -ENDIF -IF(isx.eq.nnx)isx=isx-1 -IF(isz.eq.nnz)isz=isz-1 -! -! Set all values of nsts to -1 if beginning from a source -! point. -! -IF(urg.NE.2)nsts=-1 -! -! set initial size of binary tree to zero -! -ntr=0 -IF(urg.EQ.2)THEN -! -! In this case, source grid refinement has been applied, so -! the initial narrow band will come from resampling the -! refined grid. -! - DO i=1,nnx - DO j=1,nnz - IF(nsts(j,i).GT.0)THEN - CALL addtree(j,i) - ENDIF - ENDDO - ENDDO -ELSE -! -! In general, the source point need not lie on a grid point. -! Bi-linear interpolation is used to find velocity at the -! source point. -! - nsts=-1 - DO i=1,2 - DO j=1,2 - vss(i,j)=veln(isz-1+j,isx-1+i) - ENDDO - ENDDO - dsx=(scx-gox)-(isx-1)*dnx - dsz=(scz-goz)-(isz-1)*dnz - CALL bilinear(vss,dsx,dsz,vsrc) -! -! Now find the traveltime at the four surrounding grid points. This -! is calculated approximately by assuming the traveltime from the -! source point to each node is equal to the the distance between -! the two points divided by the average velocity of the points -! - DO i=1,2 - DO j=1,2 - ds=SQRT((dsx-(i-1)*dnx)**2+(dsz-(j-1)*dnz)**2) - ttn(isz-1+j,isx-1+i)=2.0*ds/(vss(i,j)+vsrc) - CALL addtree(isz-1+j,isx-1+i) - ENDDO - ENDDO -ENDIF -! -! Now calculate the first-arrival traveltimes at the -! remaining grid points. This is done via a loop which -! repeats the procedure of finding the first-arrival -! of all "close" points, adding it to the set of "alive" -! points and updating the points surrounding the new "alive" -! point. The process ceases when the binary tree is empty, -! in which case all grid points are "alive". -! -DO WHILE(ntr.gt.0) -! -! First, check whether source grid refinement is -! being applied; if so, then there is a special -! exit condition. -! -IF(urg.EQ.1)THEN - ix=btg(1)%px - iz=btg(1)%pz - swrg=0 - IF(ix.EQ.1)THEN - IF(vnl.NE.1)swrg=1 - ENDIF - IF(ix.EQ.nnx)THEN - IF(vnr.NE.nnx)swrg=1 - ENDIF - IF(iz.EQ.1)THEN - IF(vnt.NE.1)swrg=1 - ENDIF - IF(iz.EQ.nnz)THEN - IF(vnb.NE.nnz)swrg=1 - ENDIF - IF(swrg.EQ.1)THEN - nsts(iz,ix)=0 - EXIT - ENDIF -ENDIF -! -! Set the "close" point with minimum traveltime -! to "alive" -! - ix=btg(1)%px - iz=btg(1)%pz - nsts(iz,ix)=0 -! -! Update the binary tree by removing the root and -! sweeping down the tree. -! - CALL downtree -! -! Now update or find values of up to four grid points -! that surround the new "alive" point. -! -! Test points that vary in x -! - DO i=ix-1,ix+1,2 - IF(i.ge.1.and.i.le.nnx)THEN - IF(nsts(iz,i).eq.-1)THEN -! -! This option occurs when a far point is added to the list -! of "close" points -! - IF(fom.eq.0)THEN - CALL fouds1(iz,i) - ELSE - CALL fouds2(iz,i) - ENDIF - CALL addtree(iz,i) - ELSE IF(nsts(iz,i).gt.0)THEN -! -! This happens when a "close" point is updated -! - IF(fom.eq.0)THEN - CALL fouds1(iz,i) - ELSE - CALL fouds2(iz,i) - ENDIF - CALL updtree(iz,i) - ENDIF - ENDIF - ENDDO -! -! Test points that vary in z -! - DO i=iz-1,iz+1,2 - IF(i.ge.1.and.i.le.nnz)THEN - IF(nsts(i,ix).eq.-1)THEN -! -! This option occurs when a far point is added to the list -! of "close" points -! - IF(fom.eq.0)THEN - CALL fouds1(i,ix) - ELSE - CALL fouds2(i,ix) - ENDIF - CALL addtree(i,ix) - ELSE IF(nsts(i,ix).gt.0)THEN -! -! This happens when a "close" point is updated -! - IF(fom.eq.0)THEN - CALL fouds1(i,ix) - ELSE - CALL fouds2(i,ix) - ENDIF - CALL updtree(i,ix) - ENDIF - ENDIF - ENDDO -ENDDO -END SUBROUTINE travel - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine calculates a trial first-arrival traveltime -! at a given node from surrounding nodes using the -! First-Order Upwind Difference Scheme (FOUDS) of -! Sethian and Popovici (1999). -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE fouds1(iz,ix) -IMPLICIT NONE -INTEGER :: j,k,ix,iz,tsw1,swsol -REAL(KIND=i10) :: trav,travm,slown,tdsh,tref -REAL(KIND=i10) :: a,b,c,u,v,em,ri,risti -REAL(KIND=i10) :: rd1 -! -! ix = NS position of node coordinate for determination -! iz = EW vertical position of node coordinate for determination -! trav = traveltime calculated for trial node -! travm = minimum traveltime calculated for trial node -! slown = slowness at (iz,ix) -! tsw1 = traveltime switch (0=first time,1=previously) -! a,b,c,u,v,em = Convenience variables for solving quadratic -! tdsh = local traveltime from neighbouring node -! tref = reference traveltime at neighbouring node -! ri = Radial distance -! risti = ri*sin(theta) at point (iz,ix) -! rd1 = dummy variable -! swsol = switch for solution (0=no solution, 1=solution) -! -! Inspect each of the four quadrants for the minimum time -! solution. -! -tsw1=0 -slown=1.0/veln(iz,ix) -ri=earth -risti=ri*sin(gox+(ix-1)*dnx) -DO j=ix-1,ix+1,2 - DO k=iz-1,iz+1,2 - IF(j.GE.1.AND.j.LE.nnx)THEN - IF(k.GE.1.AND.k.LE.nnz)THEN -! -! There are seven solution options in -! each quadrant. -! - swsol=0 - IF(nsts(iz,j).EQ.0)THEN - swsol=1 - IF(nsts(k,ix).EQ.0)THEN - u=ri*dnx - v=risti*dnz - em=ttn(k,ix)-ttn(iz,j) - a=u**2+v**2 - b=-2.0*u**2*em - c=u**2*(em**2-v**2*slown**2) - tref=ttn(iz,j) - ELSE - a=1.0 - b=0.0 - c=-slown**2*ri**2*dnx**2 - tref=ttn(iz,j) - ENDIF - ELSE IF(nsts(k,ix).EQ.0)THEN - swsol=1 - a=1.0 - b=0.0 - c=-(slown*risti*dnz)**2 - tref=ttn(k,ix) - ENDIF -! -! Now find the solution of the quadratic equation -! - IF(swsol.EQ.1)THEN - rd1=b**2-4.0*a*c - IF(rd1.LT.0.0)rd1=0.0 - tdsh=(-b+sqrt(rd1))/(2.0*a) - trav=tref+tdsh - IF(tsw1.EQ.1)THEN - travm=MIN(trav,travm) - ELSE - travm=trav - tsw1=1 - ENDIF - ENDIF - ENDIF - ENDIF - ENDDO -ENDDO -ttn(iz,ix)=travm -END SUBROUTINE fouds1 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine calculates a trial first-arrival traveltime -! at a given node from surrounding nodes using the -! Mixed-Order (2nd) Upwind Difference Scheme (FOUDS) of -! Popovici and Sethian (2002). -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE fouds2(iz,ix) -IMPLICIT NONE -INTEGER :: j,k,j2,k2,ix,iz,tsw1 -INTEGER :: swj,swk,swsol -REAL(KIND=i10) :: trav,travm,slown,tdsh,tref,tdiv -REAL(KIND=i10) :: a,b,c,u,v,em,ri,risti,rd1 -! -! ix = NS position of node coordinate for determination -! iz = EW vertical position of node coordinate for determination -! trav = traveltime calculated for trial node -! travm = minimum traveltime calculated for trial node -! slown = slowness at (iz,ix) -! tsw1 = traveltime switch (0=first time,1=previously) -! a,b,c,u,v,em = Convenience variables for solving quadratic -! tdsh = local traveltime from neighbouring node -! tref = reference traveltime at neighbouring node -! ri = Radial distance -! risti = ri*sin(theta) at point (iz,ix) -! swj,swk = switches for second order operators -! tdiv = term to divide tref by depending on operator order -! swsol = switch for solution (0=no solution, 1=solution) -! -! Inspect each of the four quadrants for the minimum time -! solution. -! -tsw1=0 -slown=1.0/veln(iz,ix) -ri=earth -risti=ri*sin(gox+(ix-1)*dnx) -DO j=ix-1,ix+1,2 - IF(j.GE.1.AND.j.LE.nnx)THEN - swj=-1 - IF(j.eq.ix-1)THEN - j2=j-1 - IF(j2.GE.1)THEN - IF(nsts(iz,j2).EQ.0)swj=0 - ENDIF - ELSE - j2=j+1 - IF(j2.LE.nnx)THEN - IF(nsts(iz,j2).EQ.0)swj=0 - ENDIF - ENDIF - IF(nsts(iz,j).EQ.0.AND.swj.EQ.0)THEN - swj=-1 - IF(ttn(iz,j).GT.ttn(iz,j2))THEN - swj=0 - ENDIF - ELSE - swj=-1 - ENDIF - DO k=iz-1,iz+1,2 - IF(k.GE.1.AND.k.LE.nnz)THEN - swk=-1 - IF(k.eq.iz-1)THEN - k2=k-1 - IF(k2.GE.1)THEN - IF(nsts(k2,ix).EQ.0)swk=0 - ENDIF - ELSE - k2=k+1 - IF(k2.LE.nnz)THEN - IF(nsts(k2,ix).EQ.0)swk=0 - ENDIF - ENDIF - IF(nsts(k,ix).EQ.0.AND.swk.EQ.0)THEN - swk=-1 - IF(ttn(k,ix).GT.ttn(k2,ix))THEN - swk=0 - ENDIF - ELSE - swk=-1 - ENDIF -! -! There are 8 solution options in -! each quadrant. -! - swsol=0 - IF(swj.EQ.0)THEN - swsol=1 - IF(swk.EQ.0)THEN - u=2.0*ri*dnx - v=2.0*risti*dnz - em=4.0*ttn(iz,j)-ttn(iz,j2)-4.0*ttn(k,ix) - em=em+ttn(k2,ix) - a=v**2+u**2 - b=2.0*em*u**2 - c=u**2*(em**2-slown**2*v**2) - tref=4.0*ttn(iz,j)-ttn(iz,j2) - tdiv=3.0 - ELSE IF(nsts(k,ix).EQ.0)THEN - u=risti*dnz - v=2.0*ri*dnx - em=3.0*ttn(k,ix)-4.0*ttn(iz,j)+ttn(iz,j2) - a=v**2+9.0*u**2 - b=6.0*em*u**2 - c=u**2*(em**2-slown**2*v**2) - tref=ttn(k,ix) - tdiv=1.0 - ELSE - u=2.0*ri*dnx - a=1.0 - b=0.0 - c=-u**2*slown**2 - tref=4.0*ttn(iz,j)-ttn(iz,j2) - tdiv=3.0 - ENDIF - ELSE IF(nsts(iz,j).EQ.0)THEN - swsol=1 - IF(swk.EQ.0)THEN - u=ri*dnx - v=2.0*risti*dnz - em=3.0*ttn(iz,j)-4.0*ttn(k,ix)+ttn(k2,ix) - a=v**2+9.0*u**2 - b=6.0*em*u**2 - c=u**2*(em**2-v**2*slown**2) - tref=ttn(iz,j) - tdiv=1.0 - ELSE IF(nsts(k,ix).EQ.0)THEN - u=ri*dnx - v=risti*dnz - em=ttn(k,ix)-ttn(iz,j) - a=u**2+v**2 - b=-2.0*u**2*em - c=u**2*(em**2-v**2*slown**2) - tref=ttn(iz,j) - tdiv=1.0 - ELSE - a=1.0 - b=0.0 - c=-slown**2*ri**2*dnx**2 - tref=ttn(iz,j) - tdiv=1.0 - ENDIF - ELSE - IF(swk.EQ.0)THEN - swsol=1 - u=2.0*risti*dnz - a=1.0 - b=0.0 - c=-u**2*slown**2 - tref=4.0*ttn(k,ix)-ttn(k2,ix) - tdiv=3.0 - ELSE IF(nsts(k,ix).EQ.0)THEN - swsol=1 - a=1.0 - b=0.0 - c=-slown**2*risti**2*dnz**2 - tref=ttn(k,ix) - tdiv=1.0 - ENDIF - ENDIF -! -! Now find the solution of the quadratic equation -! - IF(swsol.EQ.1)THEN - rd1=b**2-4.0*a*c - IF(rd1.LT.0.0)rd1=0.0 - tdsh=(-b+sqrt(rd1))/(2.0*a) - trav=(tref+tdsh)/tdiv - IF(tsw1.EQ.1)THEN - travm=MIN(trav,travm) - ELSE - travm=trav - tsw1=1 - ENDIF - ENDIF - ENDIF - ENDDO - ENDIF -ENDDO -ttn(iz,ix)=travm -END SUBROUTINE fouds2 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine adds a value to the binary tree by -! placing a value at the bottom and pushing it up -! to its correct position. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE addtree(iz,ix) -IMPLICIT NONE -INTEGER :: ix,iz,tpp,tpc -TYPE(backpointer) :: exch -! -! ix,iz = grid position of new addition to tree -! tpp = tree position of parent -! tpc = tree position of child -! exch = dummy to exchange btg values -! -! First, increase the size of the tree by one. -! -ntr=ntr+1 -! -! Put new value at base of tree -! -nsts(iz,ix)=ntr -btg(ntr)%px=ix -btg(ntr)%pz=iz -! -! Now filter the new value up to its correct position -! -tpc=ntr -tpp=tpc/2 -DO WHILE(tpp.gt.0) - IF(ttn(iz,ix).lt.ttn(btg(tpp)%pz,btg(tpp)%px))THEN - nsts(iz,ix)=tpp - nsts(btg(tpp)%pz,btg(tpp)%px)=tpc - exch=btg(tpc) - btg(tpc)=btg(tpp) - btg(tpp)=exch - tpc=tpp - tpp=tpc/2 - ELSE - tpp=0 - ENDIF -ENDDO -END SUBROUTINE addtree - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine updates the binary tree after the root -! value has been used. The root is replaced by the value -! at the bottom of the tree, which is then filtered down -! to its correct position. This ensures that the tree remains -! balanced. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE downtree -IMPLICIT NONE -INTEGER :: tpp,tpc -REAL(KIND=i10) :: rd1,rd2 -TYPE(backpointer) :: exch -! -! tpp = tree position of parent -! tpc = tree position of child -! exch = dummy to exchange btg values -! rd1,rd2 = substitution variables -! -! Replace root of tree with its last value -! -IF(ntr.EQ.1)THEN - ntr=ntr-1 - RETURN -ENDIF -nsts(btg(ntr)%pz,btg(ntr)%px)=1 -btg(1)=btg(ntr) -! -! Reduce size of tree by one -! -ntr=ntr-1 -! -! Now filter new root down to its correct position -! -tpp=1 -tpc=2*tpp -DO WHILE(tpc.lt.ntr) -! -! Check which of the two children is smallest - use the smallest -! - rd1=ttn(btg(tpc)%pz,btg(tpc)%px) - rd2=ttn(btg(tpc+1)%pz,btg(tpc+1)%px) - IF(rd1.gt.rd2)THEN - tpc=tpc+1 - ENDIF -! -! Check whether the child is smaller than the parent; if so, then swap, -! if not, then we are done -! - rd1=ttn(btg(tpc)%pz,btg(tpc)%px) - rd2=ttn(btg(tpp)%pz,btg(tpp)%px) - IF(rd1.lt.rd2)THEN - nsts(btg(tpp)%pz,btg(tpp)%px)=tpc - nsts(btg(tpc)%pz,btg(tpc)%px)=tpp - exch=btg(tpc) - btg(tpc)=btg(tpp) - btg(tpp)=exch - tpp=tpc - tpc=2*tpp - ELSE - tpc=ntr+1 - ENDIF -ENDDO -! -! If ntr is an even number, then we still have one more test to do -! -IF(tpc.eq.ntr)THEN - rd1=ttn(btg(tpc)%pz,btg(tpc)%px) - rd2=ttn(btg(tpp)%pz,btg(tpp)%px) - IF(rd1.lt.rd2)THEN - nsts(btg(tpp)%pz,btg(tpp)%px)=tpc - nsts(btg(tpc)%pz,btg(tpc)%px)=tpp - exch=btg(tpc) - btg(tpc)=btg(tpp) - btg(tpp)=exch - ENDIF -ENDIF -END SUBROUTINE downtree - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine updates a value on the binary tree. The FMM -! should only produce updated values that are less than their -! prior values. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE updtree(iz,ix) -IMPLICIT NONE -INTEGER :: ix,iz,tpp,tpc -TYPE(backpointer) :: exch -! -! ix,iz = grid position of new addition to tree -! tpp = tree position of parent -! tpc = tree position of child -! exch = dummy to exchange btg values -! -! Filter the updated value to its correct position -! -tpc=nsts(iz,ix) -tpp=tpc/2 -DO WHILE(tpp.gt.0) - IF(ttn(iz,ix).lt.ttn(btg(tpp)%pz,btg(tpp)%px))THEN - nsts(iz,ix)=tpp - nsts(btg(tpp)%pz,btg(tpp)%px)=tpc - exch=btg(tpc) - btg(tpc)=btg(tpp) - btg(tpp)=exch - tpc=tpp - tpp=tpc/2 - ELSE - tpp=0 - ENDIF -ENDDO -END SUBROUTINE updtree - -END MODULE traveltime - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! MAIN PROGRAM -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: PROGRAM -! CODE: FORTRAN 90 -! This program is designed to implement the Fast Marching -! Method (FMM) for calculating first-arrival traveltimes -! through a 2-D continuous velocity medium in spherical shell -! coordinates (x=theta or latitude, z=phi or longitude). -! It is written in Fortran 90, although it is probably more -! accurately described as Fortran 77 with some of the Fortran 90 -! extensions. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!PROGRAM tomo_surf -subroutine CalSurfG(nx,ny,nz,nparpi,vels,iw,rw,col,dsurf, & - goxdf,gozdf,dvxdf,dvzdf,kmaxRc,kmaxRg,kmaxLc,kmaxLg, & - tRc,tRg,tLc,tLg,wavetype,igrt,periods,depz,minthk, & - scxf,sczf,rcxf,rczf,nrc1,nsrcsurf1,knum1,kmax,nsrcsurf,nrcf, & - nar,writepath) -USE globalp -USE traveltime -IMPLICIT NONE -!CHARACTER (LEN=30) ::grid,frechet -!CHARACTER (LEN=40) :: sources,receivers,otimes -!CHARACTER (LEN=30) :: travelt,rtravel,wrays,cdum -INTEGER :: i,j,k,l,nsrc,tnr,urg -INTEGER :: sgs,isx,isz,sw,idm1,idm2,nnxb,nnzb -INTEGER :: ogx,ogz,grdfx,grdfz,maxbt -REAL(KIND=i10) :: x,z,goxb,gozb,dnxb,dnzb -!REAL(KIND=i10), DIMENSION (:,:), ALLOCATABLE :: scxf,sczf -!REAL(KIND=i10), DIMENSION (:,:,:), ALLOCATABLE :: rcxf,rczf -! -! sources = File containing source locations -! receivers = File containing receiver locations -! grid = File containing grid of velocity vertices for -! resampling on a finer grid with cubic B-splines -! frechet = output file containing matrix of frechet derivatives -! travelt = File name for storage of traveltime field -! wttf = Write traveltimes to file? (0=no,>0=source id) -! fom = Use first-order(0) or mixed-order(1) scheme -! nsrc = number of sources -! scx,scz = source location in r,x,z -! scx,scz = source location in r,x,z -! x,z = temporary variables for source location -! fsrt = find source-receiver traveltimes? (0=no,1=yes) -! rtravel = output file for source-receiver traveltimes -! cdum = dummy character variable ! wrgf = write ray geometries to file? (<0=all,0=no,>0=source id.) -! wrays = file containing raypath geometries -! cfd = calculate Frechet derivatives? (0=no, 1=yes) -! tnr = total number of receivers -! sgs = Extent of refined source grid -! isx,isz = cell containing source -! nnxb,nnzb = Backup for nnz,nnx -! goxb,gozb = Backup for gox,goz -! dnxb,dnzb = Backup for dnx,dnz -! ogx,ogz = Location of refined grid origin -! gridfx,grdfz = Number of refined nodes per cell -! urg = use refined grid (0=no,1=yes,2=previously used) -! maxbt = maximum size of narrow band binary tree -! otimes = file containing source-receiver association information -!c----------------------------------------------------------------- -! variables defined by Hongjian Fang - integer nx,ny,nz - integer kmax,nsrcsurf,nrcf - real vels(nx,ny,nz) - real rw(*) - integer iw(*),col(*) - real dsurf(*) - real goxdf,gozdf,dvxdf,dvzdf - integer kmaxRc,kmaxRg,kmaxLc,kmaxLg - real*8 tRc(*),tRg(*),tLc(*),tLg(*) - integer wavetype(nsrcsurf,kmax) - integer periods(nsrcsurf,kmax),nrc1(nsrcsurf,kmax),nsrcsurf1(kmax) - integer knum1(kmax),igrt(nsrcsurf,kmax) - real scxf(nsrcsurf,kmax),sczf(nsrcsurf,kmax),rcxf(nrcf,nsrcsurf,kmax),rczf(nrcf,nsrcsurf,kmax) - integer nar - real minthk - integer nparpi - - - real vpz(nz),vsz(nz),rhoz(nz),depz(nz) - real*8 pvRc(nx*ny,kmaxRc),pvRg(nx*ny,kmaxRg),pvLc(nx*ny,kmaxLc),pvLg(nx*ny,kmaxLg) - real*8 sen_vsRc(nx*ny,kmaxRc,nz),sen_vpRc(nx*ny,kmaxRc,nz) - real*8 sen_rhoRc(nx*ny,kmaxRc,nz) - real*8 sen_vsRg(nx*ny,kmaxRg,nz),sen_vpRg(nx*ny,kmaxRg,nz) - real*8 sen_rhoRg(nx*ny,kmaxRg,nz) - real*8 sen_vsLc(nx*ny,kmaxLc,nz),sen_vpLc(nx*ny,kmaxLc,nz) - real*8 sen_rhoLc(nx*ny,kmaxLc,nz) - real*8 sen_vsLg(nx*ny,kmaxLg,nz),sen_vpLg(nx*ny,kmaxLg,nz) - real*8 sen_rhoLg(nx*ny,kmaxLg,nz) - real*8 sen_vs(nx*ny,kmax,nz),sen_vp(nx*ny,kmax,nz) - real*8 sen_rho(nx*ny,kmax,nz) - real coe_rho(nz-1),coe_a(nz-1) - real*8 velf(ny*nx) - integer kmax1,kmax2,kmax3,count1 - integer igr - integer iwave - integer knumi,srcnum - real,dimension(:,:),allocatable:: fdm - real row(nparpi) - real vpft(nz-1) - real cbst1 - integer ii,jj,kk,nn,istep - integer level,maxlevel,maxleveld,HorizonType,VerticalType,PorS - real,parameter::ftol=1e-4 - integer writepath -gdx=5 -gdz=5 -asgr=1 -sgdl=8 -sgs=8 -earth=6371.0 -fom=1 -snb=0.5 -goxd=goxdf -gozd=gozdf -dvxd=dvxdf -dvzd=dvzdf -nvx=nx-2 -nvz=ny-2 -ALLOCATE(velv(0:nvz+1,0:nvx+1), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE gridder: REAL velv' -ENDIF -! -! Convert from degrees to radians -! -dvx=dvxd*pi/180.0 -dvz=dvzd*pi/180.0 -gox=(90.0-goxd)*pi/180.0 -goz=gozd*pi/180.0 -! -! Compute corresponding values for propagation grid. -! -nnx=(nvx-1)*gdx+1 -nnz=(nvz-1)*gdz+1 -dnx=dvx/gdx -dnz=dvz/gdz -dnxd=dvxd/gdx -dnzd=dvzd/gdz -ALLOCATE(veln(nnz,nnx), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE gridder: REAL veln' -ENDIF - -! -! Call a subroutine which reads in the velocity grid -! -!CALL gridder(grid) -! -! Read in all source coordinates. -! -! -! Now work out, source by source, the first-arrival traveltime -! field plus source-receiver traveltimes -! and ray paths if required. First, allocate memory to the -! traveltime field array -! -ALLOCATE(ttn(nnz,nnx), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: PROGRAM fmmin2d: REAL ttn' -ENDIF - rbint=0 -! -! Allocate memory for node status and binary trees -! -ALLOCATE(nsts(nnz,nnx)) -maxbt=NINT(snb*nnx*nnz) -ALLOCATE(btg(maxbt)) - -allocate(fdm(0:nvz+1,0:nvx+1)) - - if(kmaxRc.gt.0) then - iwave=2 - igr=0 - call depthkernel(nx,ny,nz,vels,pvRc,sen_vsRc,sen_vpRc, & - sen_rhoRc,iwave,igr,kmaxRc,tRc,depz,minthk) - endif - - if(kmaxRg.gt.0) then - iwave=2 - igr=1 - call depthkernel(nx,ny,nz,vels,pvRg,sen_vsRg,sen_vpRg, & - sen_rhoRg,iwave,igr,kmaxRg,tRg,depz,minthk) - endif - - if(kmaxLc.gt.0) then - iwave=1 - igr=0 - call depthkernel(nx,ny,nz,vels,pvLc,sen_vsLc,sen_vpLc, & - sen_rhoLc,iwave,igr,kmaxLc,tLc,depz,minthk) - endif - - if(kmaxLg.gt.0) then - iwave=1 - igr=1 - call depthkernel(nx,ny,nz,vels,pvLg,sen_vsLg,sen_vpLg, & - sen_rhoLg,iwave,igr,kmaxLg,tLg,depz,minthk) - endif - -nar=0 -count1=0 - -sen_vs=0 -sen_vp=0 -sen_rho=0 -kmax1=kmaxRc -kmax2=kmaxRc+kmaxRg -kmax3=kmaxRc+kmaxRg+kmaxLc -do knumi=1,kmax -do srcnum=1,nsrcsurf1(knum1(knumi)) - if(wavetype(srcnum,knum1(knumi))==2.and.igrt(srcnum,knum1(knumi))==0) then - velf(1:nx*ny)=pvRc(1:nx*ny,periods(srcnum,knum1(knumi))) - sen_vs(:,1:kmax1,:)=sen_vsRc(:,1:kmaxRc,:)!(:,nt(istep),:) - sen_vp(:,1:kmax1,:)=sen_vpRc(:,1:kmaxRc,:)!(:,nt(istep),:) - sen_rho(:,1:kmax1,:)=sen_rhoRc(:,1:kmaxRc,:)!(:,nt(istep),:) - endif - if(wavetype(srcnum,knum1(knumi))==2.and.igrt(srcnum,knum1(knumi))==1) then - velf(1:nx*ny)=pvRg(1:nx*ny,periods(srcnum,knum1(knumi))) - sen_vs(:,kmax1+1:kmax2,:)=sen_vsRg(:,1:kmaxRg,:)!(:,nt,:) - sen_vp(:,kmax1+1:kmax2,:)=sen_vpRg(:,1:kmaxRg,:)!(:,nt,:) - sen_rho(:,kmax1+1:kmax2,:)=sen_rhoRg(:,1:kmaxRg,:)!(:,nt,:) - endif - if(wavetype(srcnum,knum1(knumi))==1.and.igrt(srcnum,knum1(knumi))==0) then - velf(1:nx*ny)=pvLc(1:nx*ny,periods(srcnum,knum1(knumi))) - sen_vs(:,kmax2+1:kmax3,:)=sen_vsLc(:,1:kmaxLc,:)!(:,nt,:) - sen_vp(:,kmax2+1:kmax3,:)=sen_vpLc(:,1:kmaxLc,:)!(:,nt,:) - sen_rho(:,kmax2+1:kmax3,:)=sen_rhoLc(:,1:kmaxLc,:)!(:,nt,:) - endif - if(wavetype(srcnum,knum1(knumi))==1.and.igrt(srcnum,knum1(knumi))==1) then - velf(1:nx*ny)=pvLg(1:nx*ny,periods(srcnum,knum1(knumi))) - sen_vs(:,kmax3+1:kmax,:)=sen_vsLg(:,1:kmaxLg,:)!(:,nt,:) - sen_vp(:,kmax3+1:kmax,:)=sen_vpLg(:,1:kmaxLg,:)!(:,nt,:) - sen_rho(:,kmax3+1:kmax,:)=sen_rhoLg(:,1:kmaxLg,:)!(:,nt,:) - endif - -call gridder(velf) - x=scxf(srcnum,knum1(knumi)) - z=sczf(srcnum,knum1(knumi)) -! -! Begin by computing refined source grid if required -! - urg=0 - IF(asgr.EQ.1)THEN -! -! Back up coarse velocity grid to a holding matrix -! - ALLOCATE(velnb(nnz,nnx)) - ! MODIFIEDY BY HONGJIAN FANG @ USTC 2014/04/17 - velnb(1:nnz,1:nnx)=veln(1:nnz,1:nnx) - nnxb=nnx - nnzb=nnz - dnxb=dnx - dnzb=dnz - goxb=gox - gozb=goz -! -! Identify nearest neighbouring node to source -! - isx=INT((x-gox)/dnx)+1 - isz=INT((z-goz)/dnz)+1 - sw=0 - IF(isx.lt.1.or.isx.gt.nnx)sw=1 - IF(isz.lt.1.or.isz.gt.nnz)sw=1 - IF(sw.eq.1)then - isx=90.0-isx*180.0/pi - isz=isz*180.0/pi - WRITE(6,*)"Source lies outside bounds of model (lat,long)= ",isx,isz - WRITE(6,*)"TERMINATING PROGRAM!!!" - STOP - ENDIF - IF(isx.eq.nnx)isx=isx-1 - IF(isz.eq.nnz)isz=isz-1 -! -! Now find rectangular box that extends outward from the nearest source node -! to "sgs" nodes away. -! - vnl=isx-sgs - IF(vnl.lt.1)vnl=1 - vnr=isx+sgs - IF(vnr.gt.nnx)vnr=nnx - vnt=isz-sgs - IF(vnt.lt.1)vnt=1 - vnb=isz+sgs - IF(vnb.gt.nnz)vnb=nnz - nrnx=(vnr-vnl)*sgdl+1 - nrnz=(vnb-vnt)*sgdl+1 - drnx=dvx/REAL(gdx*sgdl) - drnz=dvz/REAL(gdz*sgdl) - gorx=gox+dnx*(vnl-1) - gorz=goz+dnz*(vnt-1) - nnx=nrnx - nnz=nrnz - dnx=drnx - dnz=drnz - gox=gorx - goz=gorz -! -! Reallocate velocity and traveltime arrays if nnx>nnxb or -! nnz 0)THEN - WRITE(6,*)'Error with DEALLOCATE: PROGRAM fmmin2d: velnb' - ENDIF -ENDIF -enddo -enddo -deallocate(fdm) -deallocate(velv,veln,ttn,nsts,btg) -END subroutine -SUBROUTINE gridder(pv) -!subroutine gridder(pv) -!subroutine gridder() -USE globalp -IMPLICIT NONE -INTEGER :: i,j,l,m,i1,j1,conx,conz,stx,stz -REAL(KIND=i10) :: u,sumi,sumj -REAL(KIND=i10), DIMENSION(:,:), ALLOCATABLE :: ui,vi -!CHARACTER (LEN=30) :: grid -! -! u = independent parameter for b-spline -! ui,vi = bspline basis functions -! conx,conz = variables for edge of B-spline grid -! stx,stz = counters for veln grid points -! sumi,sumj = summation variables for computing b-spline -! -!C--------------------------------------------------------------- -double precision pv(*) -!integer count1 -!C--------------------------------------------------------------- -! Open the grid file and read in the velocity grid. -! -!OPEN(UNIT=10,FILE=grid,STATUS='old') -!READ(10,*)nvx,nvz -!READ(10,*)goxd,gozd -!READ(10,*)dvxd,dvzd -!count1=0 -DO i=0,nvz+1 - DO j=0,nvx+1 -! count1=count1+1 -! READ(10,*)velv(i,j) -! velv(i,j)=real(pv(count1)) - velv(i,j)=real(pv(i*(nvx+2)+j+1)) - ENDDO -ENDDO -!CLOSE(10) -! -! Convert from degrees to radians -! -! -! Now dice up the grid -! -ALLOCATE(ui(gdx+1,4), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: Subroutine gridder: REAL ui' -ENDIF -DO i=1,gdx+1 - u=gdx - u=(i-1)/u - ui(i,1)=(1.0-u)**3/6.0 - ui(i,2)=(4.0-6.0*u**2+3.0*u**3)/6.0 - ui(i,3)=(1.0+3.0*u+3.0*u**2-3.0*u**3)/6.0 - ui(i,4)=u**3/6.0 -ENDDO -ALLOCATE(vi(gdz+1,4), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: Subroutine gridder: REAL vi' -ENDIF -DO i=1,gdz+1 - u=gdz - u=(i-1)/u - vi(i,1)=(1.0-u)**3/6.0 - vi(i,2)=(4.0-6.0*u**2+3.0*u**3)/6.0 - vi(i,3)=(1.0+3.0*u+3.0*u**2-3.0*u**3)/6.0 - vi(i,4)=u**3/6.0 -ENDDO -DO i=1,nvz-1 - conz=gdz - IF(i==nvz-1)conz=gdz+1 - DO j=1,nvx-1 - conx=gdx - IF(j==nvx-1)conx=gdx+1 - DO l=1,conz - stz=gdz*(i-1)+l - DO m=1,conx - stx=gdx*(j-1)+m - sumi=0.0 - DO i1=1,4 - sumj=0.0 - DO j1=1,4 - sumj=sumj+ui(m,j1)*velv(i-2+i1,j-2+j1) - ENDDO - sumi=sumi+vi(l,i1)*sumj - ENDDO - veln(stz,stx)=sumi - ENDDO - ENDDO - ENDDO -ENDDO -DEALLOCATE(ui,vi, STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with DEALLOCATE: SUBROUTINE gridder: REAL ui,vi' -ENDIF -END SUBROUTINE gridder - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine is similar to bsplreg except that it has been -! modified to deal with source grid refinement -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE bsplrefine -USE globalp -INTEGER :: i,j,k,l,i1,j1,st1,st2,nrzr,nrxr -INTEGER :: origx,origz,conx,conz,idm1,idm2 -REAL(KIND=i10) :: u,v -REAL(KIND=i10), DIMENSION (4) :: sum -REAL(KIND=i10), DIMENSION(gdx*sgdl+1,gdz*sgdl+1,4) :: ui,vi -! -! nrxr,nrzr = grid refinement level for source grid in x,z -! origx,origz = local origin of refined source grid -! -! Begin by calculating the values of the basis functions -! -nrxr=gdx*sgdl -nrzr=gdz*sgdl -DO i=1,nrzr+1 - v=nrzr - v=(i-1)/v - DO j=1,nrxr+1 - u=nrxr - u=(j-1)/u - ui(j,i,1)=(1.0-u)**3/6.0 - ui(j,i,2)=(4.0-6.0*u**2+3.0*u**3)/6.0 - ui(j,i,3)=(1.0+3.0*u+3.0*u**2-3.0*u**3)/6.0 - ui(j,i,4)=u**3/6.0 - vi(j,i,1)=(1.0-v)**3/6.0 - vi(j,i,2)=(4.0-6.0*v**2+3.0*v**3)/6.0 - vi(j,i,3)=(1.0+3.0*v+3.0*v**2-3.0*v**3)/6.0 - vi(j,i,4)=v**3/6.0 - ENDDO -ENDDO -! -! Calculate the velocity values. -! -origx=(vnl-1)*sgdl+1 -origz=(vnt-1)*sgdl+1 -DO i=1,nvz-1 - conz=nrzr - IF(i==nvz-1)conz=nrzr+1 - DO j=1,nvx-1 - conx=nrxr - IF(j==nvx-1)conx=nrxr+1 - DO k=1,conz - st1=gdz*(i-1)+(k-1)/sgdl+1 - IF(st1.LT.vnt.OR.st1.GT.vnb)CYCLE - st1=nrzr*(i-1)+k - DO l=1,conx - st2=gdx*(j-1)+(l-1)/sgdl+1 - IF(st2.LT.vnl.OR.st2.GT.vnr)CYCLE - st2=nrxr*(j-1)+l - DO i1=1,4 - sum(i1)=0.0 - DO j1=1,4 - sum(i1)=sum(i1)+ui(l,k,j1)*velv(i-2+i1,j-2+j1) - ENDDO - sum(i1)=vi(l,k,i1)*sum(i1) - ENDDO - idm1=st1-origz+1 - idm2=st2-origx+1 - IF(idm1.LT.1.OR.idm1.GT.nnz)CYCLE - IF(idm2.LT.1.OR.idm2.GT.nnx)CYCLE - veln(idm1,idm2)=sum(1)+sum(2)+sum(3)+sum(4) - ENDDO - ENDDO - ENDDO -ENDDO -END SUBROUTINE bsplrefine -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine calculates all receiver traveltimes for -! a given source and writes the results to file. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!SUBROUTINE srtimes(scx,scz,rcx1,rcz1,cbst1) -SUBROUTINE srtimes(scx,scz,rcx1,rcz1,cbst1) -USE globalp -IMPLICIT NONE -INTEGER :: i,k,l,irx,irz,sw,isx,isz,csid -INTEGER, PARAMETER :: noray=0,yesray=1 -INTEGER, PARAMETER :: i5=SELECTED_REAL_KIND(6) -REAL(KIND=i5) :: trr -REAL(KIND=i5), PARAMETER :: norayt=0.0 -REAL(KIND=i10) :: drx,drz,produ,scx,scz -REAL(KIND=i10) :: rcx1,rcz1,cbst1 -REAL(KIND=i10) :: sred,dpl,rd1,vels,velr -REAL(KIND=i10), DIMENSION (2,2) :: vss -!!------------------------------------------------------ -! modified by Hongjian Fang @ USTC - integer no_p,nsrc - real dist -! real cbst(*) !note that the type difference(kind=i5 vs real) -! integer cbst_stat(*) -!!------------------------------------------------------ -! -! irx,irz = Coordinates of cell containing receiver -! trr = traveltime value at receiver -! produ = dummy multiplier -! drx,drz = receiver distance from (i,j,k) grid node -! scx,scz = source coordinates -! isx,isz = source cell location -! sred = Distance from source to receiver -! dpl = Minimum path length in source neighbourhood. -! vels,velr = velocity at source and receiver -! vss = velocity at four grid points about source or receiver. -! csid = current source ID -! noray = switch to indicate no ray present -! norayt = default value given to null ray -! yesray = switch to indicate that ray is present -! -! Determine source-receiver traveltimes one at a time. -! -!0605DO i=1,nrc -!0605 IF(srs(i,csid).EQ.0)THEN -!0605! WRITE(10,*)noray,norayt -!0605 CYCLE -!0605 ENDIF -! -! The first step is to locate the receiver in the grid. -! - irx=INT((rcx1-gox)/dnx)+1 - irz=INT((rcz1-goz)/dnz)+1 - sw=0 - IF(irx.lt.1.or.irx.gt.nnx)sw=1 - IF(irz.lt.1.or.irz.gt.nnz)sw=1 - IF(sw.eq.1)then - irx=90.0-irx*180.0/pi - irz=irz*180.0/pi - WRITE(6,*)"srtimes Receiver lies outside model (lat,long)= ",irx,irz - WRITE(6,*)"TERMINATING PROGRAM!!!!" - STOP - ENDIF - IF(irx.eq.nnx)irx=irx-1 - IF(irz.eq.nnz)irz=irz-1 -! -! Location of receiver successfully found within the grid. Now approximate -! traveltime at receiver using bilinear interpolation from four -! surrounding grid points. Note that bilinear interpolation is a poor -! approximation when traveltime gradient varies significantly across a cell, -! particularly near the source. Thus, we use an improved approximation in this -! case. First, locate current source cell. -! - isx=INT((scx-gox)/dnx)+1 - isz=INT((scz-goz)/dnz)+1 - dpl=dnx*earth - rd1=dnz*earth*SIN(gox) - IF(rd1.LT.dpl)dpl=rd1 - rd1=dnz*earth*SIN(gox+(nnx-1)*dnx) - IF(rd1.LT.dpl)dpl=rd1 - sred=((scx-rcx1)*earth)**2 - sred=sred+((scz-rcz1)*earth*SIN(rcx1))**2 - sred=SQRT(sred) - IF(sred.LT.dpl)sw=1 - IF(isx.EQ.irx)THEN - IF(isz.EQ.irz)sw=1 - ENDIF - IF(sw.EQ.1)THEN -! -! Compute velocity at source and receiver -! - DO k=1,2 - DO l=1,2 - vss(k,l)=veln(isz-1+l,isx-1+k) - ENDDO - ENDDO - drx=(scx-gox)-(isx-1)*dnx - drz=(scz-goz)-(isz-1)*dnz - CALL bilinear(vss,drx,drz,vels) - DO k=1,2 - DO l=1,2 - vss(k,l)=veln(irz-1+l,irx-1+k) - ENDDO - ENDDO - drx=(rcx1-gox)-(irx-1)*dnx - drz=(rcz1-goz)-(irz-1)*dnz - CALL bilinear(vss,drx,drz,velr) - trr=2.0*sred/(vels+velr) - ELSE - drx=(rcx1-gox)-(irx-1)*dnx - drz=(rcz1-goz)-(irz-1)*dnz - trr=0.0 - DO k=1,2 - DO l=1,2 - produ=(1.0-ABS(((l-1)*dnz-drz)/dnz))*(1.0-ABS(((k-1)*dnx-drx)/dnx)) - trr=trr+ttn(irz-1+l,irx-1+k)*produ - ENDDO - ENDDO - ENDIF -! WRITE(10,*)yesray,trr -!!----------------------------------------------------------------- -! modified bu Hongjian Fang @ USTC -! count2=count2+1 -! cbst((no_p-1)*nsrc*nrc+(csid-1)*nrc+i)=trr - cbst1=trr -! call delsph(scx,scz,rcx(i),rcz(i),dist) -! travel_path(count2)=dist -!cbst_stat((no_p-1)*nsrc*nrc+(csid-1)*nrc+i)=yesray -!0605ENDDO -END SUBROUTINE srtimes - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine calculates ray path geometries for each -! source-receiver combination. It will also compute -! Frechet derivatives using these ray paths if required. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!SUBROUTINE rpaths(wrgf,csid,cfd,scx,scz) -!SUBROUTINE rpaths() -SUBROUTINE rpaths(scx,scz,fdm,surfrcx,surfrcz,writepath) -USE globalp -IMPLICIT NONE -INTEGER, PARAMETER :: i5=SELECTED_REAL_KIND(5,10) -INTEGER, PARAMETER :: nopath=0 -INTEGER :: i,j,k,l,m,n,ipx,ipz,ipxr,ipzr,nrp,sw -!fang!INTEGER :: wrgf,cfd,csid,ipxo,ipzo,isx,isz -INTEGER :: ipxo,ipzo,isx,isz -INTEGER :: ivx,ivz,ivxo,ivzo,nhp,maxrp -INTEGER :: ivxt,ivzt,ipxt,ipzt,isum,igref -INTEGER, DIMENSION (4) :: chp -REAL(KIND=i5) :: rayx,rayz -REAL(KIND=i10) :: dpl,rd1,rd2,xi,zi,vel,velo -REAL(KIND=i10) :: v,w,rigz,rigx,dinc,scx,scz -REAL(KIND=i10) :: dtx,dtz,drx,drz,produ,sred -REAL(KIND=i10), DIMENSION (:), ALLOCATABLE :: rgx,rgz -!fang!REAL(KIND=i5), DIMENSION (:,:), ALLOCATABLE :: fdm -REAL(KIND=i10), DIMENSION (4) :: vrat,vi,wi,vio,wio -!fang!------------------------------------------------ -real fdm(0:nvz+1,0:nvx+1) -REAL(KIND=i10) surfrcx,surfrcz -integer writepath -!fang!------------------------------------------------ -! -! ipx,ipz = Coordinates of cell containing current point -! ipxr,ipzr = Same as ipx,apz except for refined grid -! ipxo,ipzo = Coordinates of previous point -! rgx,rgz = (x,z) coordinates of ray geometry -! ivx,ivz = Coordinates of B-spline vertex containing current point -! ivxo,ivzo = Coordinates of previous point -! maxrp = maximum number of ray points -! nrp = number of points to describe ray -! dpl = incremental path length of ray -! xi,zi = edge of model coordinates -! dtx,dtz = components of gradT -! wrgf = Write out raypaths? (<0=all,0=no,>0=souce id) -! cfd = calculate Frechet derivatives? (0=no,1=yes) -! csid = current source id -! fdm = Frechet derivative matrix -! nhp = Number of ray segment-B-spline cell hit points -! vrat = length ratio of ray sub-segment -! chp = pointer to incremental change in x or z cell -! drx,drz = distance from reference node of cell -! produ = variable for trilinear interpolation -! vel = velocity at current point -! velo = velocity at previous point -! v,w = local variables of x,z -! vi,wi = B-spline basis functions at current point -! vio,wio = vi,wi for previous point -! ivxt,ivzt = temporary ivr,ivx,ivz values -! rigx,rigz = end point of sub-segment of ray path -! ipxt,ipzt = temporary ipx,ipz values -! dinc = path length of ray sub-segment -! rayr,rayx,rayz = ray path coordinates in single precision -! isx,isz = current source cell location -! scx,scz = current source coordinates -! sred = source to ray endpoint distance -! igref = ray endpoint lies in refined grid? (0=no,1=yes) -! nopath = switch to indicate that no path is present -! -! Allocate memory to arrays for storing ray path geometry -! -maxrp=nnx*nnz -ALLOCATE(rgx(maxrp+1), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE rpaths: REAL rgx' -ENDIF -ALLOCATE(rgz(maxrp+1), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE rpaths: REAL rgz' -ENDIF -! -! Allocate memory to partial derivative array -! -!fang!IF(cfd.EQ.1)THEN -!fang! ALLOCATE(fdm(0:nvz+1,0:nvx+1), STAT=checkstat) -!fang! IF(checkstat > 0)THEN -!fang! WRITE(6,*)'Error with ALLOCATE: SUBROUTINE rpaths: REAL fdm' -!fang! ENDIF -!fang!ENDIF -! -! Locate current source cell -! -IF(asgr.EQ.1)THEN - isx=INT((scx-goxr)/dnxr)+1 - isz=INT((scz-gozr)/dnzr)+1 -ELSE - isx=INT((scx-gox)/dnx)+1 - isz=INT((scz-goz)/dnz)+1 -ENDIF -! -! Set ray incremental path length equal to half width -! of cell -! - dpl=dnx*earth - rd1=dnz*earth*SIN(gox) - IF(rd1.LT.dpl)dpl=rd1 - rd1=dnz*earth*SIN(gox+(nnx-1)*dnx) - IF(rd1.LT.dpl)dpl=rd1 - dpl=0.5*dpl -! -! Loop through all the receivers -! -!fang!DO i=1,nrc -! -! If path does not exist, then cycle the loop -! -fdm=0 -!fang! IF(cfd.EQ.1)THEN -!fang! fdm=0.0 -!fang! ENDIF -!fang! IF(srs(i,csid).EQ.0)THEN -!fang! IF(wrgf.EQ.csid.OR.wrgf.LT.0)THEN -!fang! WRITE(40)nopath -!fang! ENDIF -!fang! IF(cfd.EQ.1)THEN -!fang! WRITE(50)nopath -!fang! ENDIF -!fang! CYCLE -!fang! ENDIF -! -! The first step is to locate the receiver in the grid. -! - ipx=INT((surfrcx-gox)/dnx)+1 - ipz=INT((surfrcz-goz)/dnz)+1 - sw=0 - IF(ipx.lt.1.or.ipx.ge.nnx)sw=1 - IF(ipz.lt.1.or.ipz.ge.nnz)sw=1 - IF(sw.eq.1)then - ipx=90.0-ipx*180.0/pi - ipz=ipz*180.0/pi - WRITE(6,*)"rpath Receiver lies outside model (lat,long)= ",ipx,ipz - WRITE(6,*)"TERMINATING PROGRAM!!!" - STOP - ENDIF - IF(ipx.eq.nnx)ipx=ipx-1 - IF(ipz.eq.nnz)ipz=ipz-1 -! -! First point of the ray path is the receiver -! - rgx(1)=surfrcx - rgz(1)=surfrcz -! -! Test to see if receiver is in source neighbourhood -! - sred=((scx-rgx(1))*earth)**2 - sred=sred+((scz-rgz(1))*earth*SIN(rgx(1)))**2 - sred=SQRT(sred) - IF(sred.LT.2.0*dpl)THEN - rgx(2)=scx - rgz(2)=scz - nrp=2 - sw=1 - ENDIF -! -! If required, see if receiver lies within refined grid -! - IF(asgr.EQ.1)THEN - ipxr=INT((surfrcx-goxr)/dnxr)+1 - ipzr=INT((surfrcz-gozr)/dnzr)+1 - igref=1 - IF(ipxr.LT.1.OR.ipxr.GE.nnxr)igref=0 - IF(ipzr.LT.1.OR.ipzr.GE.nnzr)igref=0 - IF(igref.EQ.1)THEN - IF(nstsr(ipzr,ipxr).NE.0.OR.nstsr(ipzr+1,ipxr).NE.0)igref=0 - IF(nstsr(ipzr,ipxr+1).NE.0.OR.nstsr(ipzr+1,ipxr+1).NE.0)igref=0 - ENDIF - ELSE - igref=0 - ENDIF -! -! Due to the method for calculating traveltime gradient, if the -! the ray end point lies in the source cell, then we are also done. -! - IF(sw.EQ.0)THEN - IF(asgr.EQ.1)THEN - IF(igref.EQ.1)THEN - IF(ipxr.EQ.isx)THEN - IF(ipzr.EQ.isz)THEN - rgx(2)=scx - rgz(2)=scz - nrp=2 - sw=1 - ENDIF - ENDIF - ENDIF - ELSE - IF(ipx.EQ.isx)THEN - IF(ipz.EQ.isz)THEN - rgx(2)=scx - rgz(2)=scz - nrp=2 - sw=1 - ENDIF - ENDIF - ENDIF - ENDIF -! -! Now trace ray from receiver to "source" -! - DO j=1,maxrp - IF(sw.EQ.1)EXIT -! -! Calculate traveltime gradient vector for current cell using -! a first-order or second-order scheme. -! - IF(igref.EQ.1)THEN -! -! In this case, we are in the refined grid. -! -! First order scheme applied here. -! - dtx=ttnr(ipzr,ipxr+1)-ttnr(ipzr,ipxr) - dtx=dtx+ttnr(ipzr+1,ipxr+1)-ttnr(ipzr+1,ipxr) - dtx=dtx/(2.0*earth*dnxr) - dtz=ttnr(ipzr+1,ipxr)-ttnr(ipzr,ipxr) - dtz=dtz+ttnr(ipzr+1,ipxr+1)-ttnr(ipzr,ipxr+1) - dtz=dtz/(2.0*earth*SIN(rgx(j))*dnzr) - ELSE -! -! Here, we are in the coarse grid. -! -! First order scheme applied here. -! - dtx=ttn(ipz,ipx+1)-ttn(ipz,ipx) - dtx=dtx+ttn(ipz+1,ipx+1)-ttn(ipz+1,ipx) - dtx=dtx/(2.0*earth*dnx) - dtz=ttn(ipz+1,ipx)-ttn(ipz,ipx) - dtz=dtz+ttn(ipz+1,ipx+1)-ttn(ipz,ipx+1) - dtz=dtz/(2.0*earth*SIN(rgx(j))*dnz) - ENDIF -! -! Calculate the next ray path point -! - rd1=SQRT(dtx**2+dtz**2) - rgx(j+1)=rgx(j)-dpl*dtx/(earth*rd1) - rgz(j+1)=rgz(j)-dpl*dtz/(earth*SIN(rgx(j))*rd1) -! -! Determine which cell the new ray endpoint -! lies in. -! - ipxo=ipx - ipzo=ipz - IF(asgr.EQ.1)THEN -! -! Here, we test to see whether the ray endpoint lies -! within a cell of the refined grid -! - ipxr=INT((rgx(j+1)-goxr)/dnxr)+1 - ipzr=INT((rgz(j+1)-gozr)/dnzr)+1 - igref=1 - IF(ipxr.LT.1.OR.ipxr.GE.nnxr)igref=0 - IF(ipzr.LT.1.OR.ipzr.GE.nnzr)igref=0 - IF(igref.EQ.1)THEN - IF(nstsr(ipzr,ipxr).NE.0.OR.nstsr(ipzr+1,ipxr).NE.0)igref=0 - IF(nstsr(ipzr,ipxr+1).NE.0.OR.nstsr(ipzr+1,ipxr+1).NE.0)igref=0 - ENDIF - ipx=INT((rgx(j+1)-gox)/dnx)+1 - ipz=INT((rgz(j+1)-goz)/dnz)+1 - ELSE - ipx=INT((rgx(j+1)-gox)/dnx)+1 - ipz=INT((rgz(j+1)-goz)/dnz)+1 - igref=0 - ENDIF -! -! Test the proximity of the source to the ray end point. -! If it is less than dpl then we are done -! - sred=((scx-rgx(j+1))*earth)**2 - sred=sred+((scz-rgz(j+1))*earth*SIN(rgx(j+1)))**2 - sred=SQRT(sred) - sw=0 - IF(sred.LT.2.0*dpl)THEN - rgx(j+2)=scx - rgz(j+2)=scz - nrp=j+2 - sw=1 -!fang! IF(cfd.NE.1)EXIT - ENDIF -! -! Due to the method for calculating traveltime gradient, if the -! the ray end point lies in the source cell, then we are also done. -! - IF(sw.EQ.0)THEN - IF(asgr.EQ.1)THEN - IF(igref.EQ.1)THEN - IF(ipxr.EQ.isx)THEN - IF(ipzr.EQ.isz)THEN - rgx(j+2)=scx - rgz(j+2)=scz - nrp=j+2 - sw=1 - !fang! IF(cfd.NE.1)EXIT - ENDIF - ENDIF - ENDIF - ELSE - IF(ipx.EQ.isx)THEN - IF(ipz.EQ.isz)THEN - rgx(j+2)=scx - rgz(j+2)=scz - nrp=j+2 - sw=1 - !fang! IF(cfd.NE.1)EXIT - ENDIF - ENDIF - ENDIF - ENDIF -! -! Test whether ray path segment extends beyond -! box boundaries -! - IF(ipx.LT.1)THEN - rgx(j+1)=gox - ipx=1 - rbint=1 - ENDIF - IF(ipx.GE.nnx)THEN - rgx(j+1)=gox+(nnx-1)*dnx - ipx=nnx-1 - rbint=1 - ENDIF - IF(ipz.LT.1)THEN - rgz(j+1)=goz - ipz=1 - rbint=1 - ENDIF - IF(ipz.GE.nnz)THEN - rgz(j+1)=goz+(nnz-1)*dnz - ipz=nnz-1 - rbint=1 - ENDIF -! -! Calculate the Frechet derivatives if required. -! - !fang! IF(cfd.EQ.1)THEN -! -! First determine which B-spline cell the refined cells -! containing the ray path segment lies in. If they lie -! in more than one, then we need to divide the problem -! into separate parts (up to three). -! - ivx=INT((ipx-1)/gdx)+1 - ivz=INT((ipz-1)/gdz)+1 - ivxo=INT((ipxo-1)/gdx)+1 - ivzo=INT((ipzo-1)/gdz)+1 -! -! Calculate up to two hit points between straight -! ray segment and cell faces. -! - nhp=0 - IF(ivx.NE.ivxo)THEN - nhp=nhp+1 - IF(ivx.GT.ivxo)THEN - xi=gox+(ivx-1)*dvx - ELSE - xi=gox+ivx*dvx - ENDIF - vrat(nhp)=(xi-rgx(j))/(rgx(j+1)-rgx(j)) - chp(nhp)=1 - ENDIF - IF(ivz.NE.ivzo)THEN - nhp=nhp+1 - IF(ivz.GT.ivzo)THEN - zi=goz+(ivz-1)*dvz - ELSE - zi=goz+ivz*dvz - ENDIF - rd1=(zi-rgz(j))/(rgz(j+1)-rgz(j)) - IF(nhp.EQ.1)THEN - vrat(nhp)=rd1 - chp(nhp)=2 - ELSE - IF(rd1.GE.vrat(nhp-1))THEN - vrat(nhp)=rd1 - chp(nhp)=2 - ELSE - vrat(nhp)=vrat(nhp-1) - chp(nhp)=chp(nhp-1) - vrat(nhp-1)=rd1 - chp(nhp-1)=2 - ENDIF - ENDIF - ENDIF - nhp=nhp+1 - vrat(nhp)=1.0 - chp(nhp)=0 -! -! Calculate the velocity, v and w values of the -! first point -! - drx=(rgx(j)-gox)-(ipxo-1)*dnx - drz=(rgz(j)-goz)-(ipzo-1)*dnz - vel=0.0 - DO l=1,2 - DO m=1,2 - produ=(1.0-ABS(((m-1)*dnz-drz)/dnz)) - produ=produ*(1.0-ABS(((l-1)*dnx-drx)/dnx)) - IF(ipzo-1+m.LE.nnz.AND.ipxo-1+l.LE.nnx)THEN - vel=vel+veln(ipzo-1+m,ipxo-1+l)*produ - ENDIF - ENDDO - ENDDO - drx=(rgx(j)-gox)-(ivxo-1)*dvx - drz=(rgz(j)-goz)-(ivzo-1)*dvz - v=drx/dvx - w=drz/dvz -! -! Calculate the 12 basis values at the point -! - vi(1)=(1.0-v)**3/6.0 - vi(2)=(4.0-6.0*v**2+3.0*v**3)/6.0 - vi(3)=(1.0+3.0*v+3.0*v**2-3.0*v**3)/6.0 - vi(4)=v**3/6.0 - wi(1)=(1.0-w)**3/6.0 - wi(2)=(4.0-6.0*w**2+3.0*w**3)/6.0 - wi(3)=(1.0+3.0*w+3.0*w**2-3.0*w**3)/6.0 - wi(4)=w**3/6.0 - ivxt=ivxo - ivzt=ivzo -! -! Now loop through the one or more sub-segments of the -! ray path segment and calculate partial derivatives -! - DO k=1,nhp - velo=vel - vio=vi - wio=wi - IF(k.GT.1)THEN - IF(chp(k-1).EQ.1)THEN - ivxt=ivx - ELSE IF(chp(k-1).EQ.2)THEN - ivzt=ivz - ENDIF - ENDIF -! -! Calculate the velocity, v and w values of the -! new point -! - rigz=rgz(j)+vrat(k)*(rgz(j+1)-rgz(j)) - rigx=rgx(j)+vrat(k)*(rgx(j+1)-rgx(j)) - ipxt=INT((rigx-gox)/dnx)+1 - ipzt=INT((rigz-goz)/dnz)+1 - drx=(rigx-gox)-(ipxt-1)*dnx - drz=(rigz-goz)-(ipzt-1)*dnz - vel=0.0 - DO m=1,2 - DO n=1,2 - produ=(1.0-ABS(((n-1)*dnz-drz)/dnz)) - produ=produ*(1.0-ABS(((m-1)*dnx-drx)/dnx)) - IF(ipzt-1+n.LE.nnz.AND.ipxt-1+m.LE.nnx)THEN - vel=vel+veln(ipzt-1+n,ipxt-1+m)*produ - ENDIF - ENDDO - ENDDO - drx=(rigx-gox)-(ivxt-1)*dvx - drz=(rigz-goz)-(ivzt-1)*dvz - v=drx/dvx - w=drz/dvz -! -! Calculate the 8 basis values at the new point -! - vi(1)=(1.0-v)**3/6.0 - vi(2)=(4.0-6.0*v**2+3.0*v**3)/6.0 - vi(3)=(1.0+3.0*v+3.0*v**2-3.0*v**3)/6.0 - vi(4)=v**3/6.0 - wi(1)=(1.0-w)**3/6.0 - wi(2)=(4.0-6.0*w**2+3.0*w**3)/6.0 - wi(3)=(1.0+3.0*w+3.0*w**2-3.0*w**3)/6.0 - wi(4)=w**3/6.0 -! -! Calculate the incremental path length -! - IF(k.EQ.1)THEN - dinc=vrat(k)*dpl - ELSE - dinc=(vrat(k)-vrat(k-1))*dpl - ENDIF -! -! Now compute the 16 contributions to the partial -! derivatives. -! - DO l=1,4 - DO m=1,4 - rd1=vi(m)*wi(l)/vel**2 - rd2=vio(m)*wio(l)/velo**2 - rd1=-(rd1+rd2)*dinc/2.0 - !fang! rd1=vi(m)*wi(l) - !fang! rd2=vio(m)*wio(l) - !fang! rd1=(rd1+rd2)*dinc/2.0 - rd2=fdm(ivzt-2+l,ivxt-2+m) - fdm(ivzt-2+l,ivxt-2+m)=rd1+rd2 - ENDDO - ENDDO - ENDDO - !fang! ENDIF -!fang! IF(j.EQ.maxrp.AND.sw.EQ.0)THEN -!fang! WRITE(6,*)'Error with ray path detected!!!' -!fang! WRITE(6,*)'Source id: ',csid -!fang! WRITE(6,*)'Receiver id: ',i -!fang! ENDIF - ENDDO -! -! Write ray paths to output file -! -!fang! IF(wrgf.EQ.csid.OR.wrgf.LT.0)THEN - if(writepath == 1) then - WRITE(40,*)'#',nrp - DO j=1,nrp - rayx=(pi/2-rgx(j))*180.0/pi - rayz=rgz(j)*180.0/pi - WRITE(40,*)rayx,rayz - ENDDO - endif -!fang! ENDIF -! -! Write partial derivatives to output file -! -!fang! IF(cfd.EQ.1)THEN -!fang!! -!fang!! Determine the number of non-zero elements. -!fang!! -!fang! isum=0 -!fang! DO j=0,nvz+1 -!fang! DO k=0,nvx+1 -!fang! IF(ABS(fdm(j,k)).GE.ftol)isum=isum+1 -!fang! ENDDO -!fang! ENDDO -!fang! WRITE(50)isum -!fang! isum=0 -!fang! DO j=0,nvz+1 -!fang! DO k=0,nvx+1 -!fang! isum=isum+1 -!fang! IF(ABS(fdm(j,k)).GE.ftol)WRITE(50)isum,fdm(j,k) -!fang! ENDDO -!fang! ENDDO -!fang! ENDIF -!fang!ENDDO -!fang!IF(cfd.EQ.1)THEN -!fang! DEALLOCATE(fdm, STAT=checkstat) -!fang! IF(checkstat > 0)THEN -!fang! WRITE(6,*)'Error with DEALLOCATE: SUBROUTINE rpaths: fdm' -!fang! ENDIF -!fang!ENDIF -DEALLOCATE(rgx,rgz, STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with DEALLOCATE: SUBROUTINE rpaths: rgx,rgz' -ENDIF -END SUBROUTINE rpaths - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine is passed four node values which lie on -! the corners of a rectangle and the coordinates of a point -! lying within the rectangle. It calculates the value at -! the internal point by using bilinear interpolation. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE bilinear(nv,dsx,dsz,biv) -USE globalp -IMPLICIT NONE -INTEGER :: i,j -REAL(KIND=i10) :: dsx,dsz,biv -REAL(KIND=i10), DIMENSION(2,2) :: nv -REAL(KIND=i10) :: produ -! -! nv = four node vertex values -! dsx,dsz = distance between internal point and top left node -! dnx,dnz = width and height of node rectangle -! biv = value at internal point calculated by bilinear interpolation -! produ = product variable -! -biv=0.0 -DO i=1,2 - DO j=1,2 - produ=(1.0-ABS(((i-1)*dnx-dsx)/dnx))*(1.0-ABS(((j-1)*dnz-dsz)/dnz)) - biv=biv+nv(i,j)*produ - ENDDO -ENDDO -END SUBROUTINE bilinear - - - subroutine refineGrid2LayerMdl(minthk0,mmax,dep,vp,vs,rho,& - rmax,rdep,rvp,rvs,rrho,rthk) -!!--------------------------------------------------------------------c -!!refine grid based model to layerd based model -!!INPUT: minthk: is the minimum thickness of the refined layered model -!! mmax: number of depth grid points in the model -!! dep, vp, vs, rho: the depth-grid model parameters -!! rmax: number of layers in the fined layered model -!! rdep, rvp, rvs, rrho, rthk: the refined layered velocity model -!! - implicit none - integer NL - parameter (NL=200) - integer mmax,rmax - real minthk0 - real minthk - real dep(*),vp(*),vs(*),rho(*) - real rdep(NL),rvp(NL),rvs(NL),rrho(NL),rthk(NL) - integer nsublay(NL) - real thk,newthk,initdep - integer i,j,k,ngrid - - k = 0 - initdep = 0.0 - do i = 1, mmax-1 - thk = dep(i+1)-dep(i) - minthk = thk/minthk0 - nsublay(i) = int((thk+1.0e-4)/minthk) + 1 - ngrid = nsublay(i)+1 - newthk = thk/nsublay(i) - do j = 1, nsublay(i) - k = k + 1 - rthk(k) = newthk - rdep(k) = initdep + rthk(k) - initdep = rdep(k) - rvp(k) = vp(i)+(2*j-1)*(vp(i+1)-vp(i))/(2*nsublay(i)) - rvs(k) = vs(i)+(2*j-1)*(vs(i+1)-vs(i))/(2*nsublay(i)) - rrho(k) = rho(i)+(2*j-1)*(rho(i+1)-rho(i))/(2*nsublay(i)) - enddo - enddo -!! half space model - k = k + 1 - rthk(k) = 0.0 - rvp(k) = vp(mmax) - rvs(k) = vs(mmax) - rrho(k) = rho(mmax) - - rmax = k - -!! do i = 1, mmax -!! write(*,*) dep(i),vp(i),vs(i),rho(i) -!! enddo -!! print *, '---------------------------------' -!! do i = 1, rmax -!! write(*,*) rdep(i),rthk(i),rvp(i),rvs(i),rrho(i) -!! enddo - - return - end -subroutine synthetic(nx,ny,nz,nparpi,vels,obst, & - goxdf,gozdf,dvxdf,dvzdf,kmaxRc,kmaxRg,kmaxLc,kmaxLg, & - tRc,tRg,tLc,tLg,wavetype,igrt,periods,depz,minthk, & - scxf,sczf,rcxf,rczf,nrc1,nsrcsurf1,knum1,kmax,nsrcsurf,nrcf,noiselevel) - -USE globalp -USE traveltime -IMPLICIT NONE -!CHARACTER (LEN=30) ::grid,frechet -!CHARACTER (LEN=40) :: sources,receivers,otimes -!CHARACTER (LEN=30) :: travelt,rtravel,wrays,cdum -INTEGER :: i,j,k,l,nsrc,tnr,urg -INTEGER :: sgs,isx,isz,sw,idm1,idm2,nnxb,nnzb -INTEGER :: ogx,ogz,grdfx,grdfz,maxbt -REAL(KIND=i10) :: x,z,goxb,gozb,dnxb,dnzb -!REAL(KIND=i10), DIMENSION (:,:), ALLOCATABLE :: scxf,sczf -!REAL(KIND=i10), DIMENSION (:,:,:), ALLOCATABLE :: rcxf,rczf -! -! sources = File containing source locations -! receivers = File containing receiver locations -! grid = File containing grid of velocity vertices for -! resampling on a finer grid with cubic B-splines -! frechet = output file containing matrix of frechet derivatives -! travelt = File name for storage of traveltime field -! wttf = Write traveltimes to file? (0=no,>0=source id) -! fom = Use first-order(0) or mixed-order(1) scheme -! nsrc = number of sources -! scx,scz = source location in r,x,z -! scx,scz = source location in r,x,z -! x,z = temporary variables for source location -! fsrt = find source-receiver traveltimes? (0=no,1=yes) -! rtravel = output file for source-receiver traveltimes -! cdum = dummy character variable ! wrgf = write ray geometries to file? (<0=all,0=no,>0=source id.) -! wrays = file containing raypath geometries -! cfd = calculate Frechet derivatives? (0=no, 1=yes) -! tnr = total number of receivers -! sgs = Extent of refined source grid -! isx,isz = cell containing source -! nnxb,nnzb = Backup for nnz,nnx -! goxb,gozb = Backup for gox,goz -! dnxb,dnzb = Backup for dnx,dnz -! ogx,ogz = Location of refined grid origin -! gridfx,grdfz = Number of refined nodes per cell -! urg = use refined grid (0=no,1=yes,2=previously used) -! maxbt = maximum size of narrow band binary tree -! otimes = file containing source-receiver association information -!c----------------------------------------------------------------- -! variables defined by Hongjian Fang - integer nx,ny,nz - integer kmax,nsrcsurf,nrcf - real vels(nx,ny,nz) - real obst(*) - real goxdf,gozdf,dvxdf,dvzdf - integer kmaxRc,kmaxRg,kmaxLc,kmaxLg - real*8 tRc(*),tRg(*),tLc(*),tLg(*) - integer wavetype(nsrcsurf,kmax) - integer periods(nsrcsurf,kmax),nrc1(nsrcsurf,kmax),nsrcsurf1(kmax) - integer knum1(kmax),igrt(nsrcsurf,kmax) - real scxf(nsrcsurf,kmax),sczf(nsrcsurf,kmax),rcxf(nrcf,nsrcsurf,kmax),rczf(nrcf,nsrcsurf,kmax) - real minthk - integer nparpi - - - real vpz(nz),vsz(nz),rhoz(nz),depz(nz) - real*8 pvRc(nx*ny,kmaxRc),pvRg(nx*ny,kmaxRg),pvLc(nx*ny,kmaxLc),pvLg(nx*ny,kmaxLg) - real*8 velf(ny*nx) - integer kmax1,kmax2,kmax3,count1 - integer igr - integer iwave - integer knumi,srcnum - real cbst1 - real noiselevel - real gaussian - external gaussian - integer ii,jj,kk,nn,istep -gdx=5 -gdz=5 -asgr=1 -sgdl=8 -sgs=8 -earth=6371.0 -fom=1 -snb=0.5 -goxd=goxdf -gozd=gozdf -dvxd=dvxdf -dvzd=dvzdf -nvx=nx-2 -nvz=ny-2 -ALLOCATE(velv(0:nvz+1,0:nvx+1), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE gridder: REAL velv' -ENDIF -! -! Convert from degrees to radians -! -dvx=dvxd*pi/180.0 -dvz=dvzd*pi/180.0 -gox=(90.0-goxd)*pi/180.0 -goz=gozd*pi/180.0 -! -! Compute corresponding values for propagation grid. -! -nnx=(nvx-1)*gdx+1 -nnz=(nvz-1)*gdz+1 -dnx=dvx/gdx -dnz=dvz/gdz -dnxd=dvxd/gdx -dnzd=dvzd/gdz -ALLOCATE(veln(nnz,nnx), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE gridder: REAL veln' -ENDIF - -! -! Call a subroutine which reads in the velocity grid -! -!CALL gridder(grid) -! -! Read in all source coordinates. -! -! -! Now work out, source by source, the first-arrival traveltime -! field plus source-receiver traveltimes -! and ray paths if required. First, allocate memory to the -! traveltime field array -! -ALLOCATE(ttn(nnz,nnx), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: PROGRAM fmmin2d: REAL ttn' -ENDIF - rbint=0 -! -! Allocate memory for node status and binary trees -! -ALLOCATE(nsts(nnz,nnx)) -maxbt=NINT(snb*nnx*nnz) -ALLOCATE(btg(maxbt)) - -!allocate(fdm(0:nvz+1,0:nvx+1)) - - if(kmaxRc.gt.0) then - iwave=2 - igr=0 - call caldespersion(nx,ny,nz,vels,pvRc, & - iwave,igr,kmaxRc,tRc,depz,minthk) - endif - - if(kmaxRg.gt.0) then - iwave=2 - igr=1 - call caldespersion(nx,ny,nz,vels,pvRg, & - iwave,igr,kmaxRg,tRg,depz,minthk) - endif - - if(kmaxLc.gt.0) then - iwave=1 - igr=0 - call caldespersion(nx,ny,nz,vels,pvLc, & - iwave,igr,kmaxLc,tLc,depz,minthk) - endif - - if(kmaxLg.gt.0) then - iwave=1 - igr=1 - call caldespersion(nx,ny,nz,vels,pvLg, & - iwave,igr,kmaxLg,tLg,depz,minthk) - endif - -!nar=0 -count1=0 - -!sen_vs=0 -!sen_vp=0 -!sen_rho=0 -kmax1=kmaxRc -kmax2=kmaxRc+kmaxRg -kmax3=kmaxRc+kmaxRg+kmaxLc -do knumi=1,kmax -do srcnum=1,nsrcsurf1(knum1(knumi)) - if(wavetype(srcnum,knum1(knumi))==2.and.igrt(srcnum,knum1(knumi))==0) then - velf(1:nx*ny)=pvRc(1:nx*ny,periods(srcnum,knum1(knumi))) -! sen_vs(:,1:kmax1,:)=sen_vsRc(:,1:kmaxRc,:)!(:,nt(istep),:) -! sen_vp(:,1:kmax1,:)=sen_vpRc(:,1:kmaxRc,:)!(:,nt(istep),:) -! sen_rho(:,1:kmax1,:)=sen_rhoRc(:,1:kmaxRc,:)!(:,nt(istep),:) - endif - if(wavetype(srcnum,knum1(knumi))==2.and.igrt(srcnum,knum1(knumi))==1) then - velf(1:nx*ny)=pvRg(1:nx*ny,periods(srcnum,knum1(knumi))) -! sen_vs(:,kmax1+1:kmax2,:)=sen_vsRg(:,1:kmaxRg,:)!(:,nt,:) -! sen_vp(:,kmax1+1:kmax2,:)=sen_vpRg(:,1:kmaxRg,:)!(:,nt,:) -! sen_rho(:,kmax1+1:kmax2,:)=sen_rhoRg(:,1:kmaxRg,:)!(:,nt,:) - endif - if(wavetype(srcnum,knum1(knumi))==1.and.igrt(srcnum,knum1(knumi))==0) then - velf(1:nx*ny)=pvLc(1:nx*ny,periods(srcnum,knum1(knumi))) -! sen_vs(:,kmax2+1:kmax3,:)=sen_vsLc(:,1:kmaxLc,:)!(:,nt,:) -! sen_vp(:,kmax2+1:kmax3,:)=sen_vpLc(:,1:kmaxLc,:)!(:,nt,:) -! sen_rho(:,kmax2+1:kmax3,:)=sen_rhoLc(:,1:kmaxLc,:)!(:,nt,:) - endif - if(wavetype(srcnum,knum1(knumi))==1.and.igrt(srcnum,knum1(knumi))==1) then - velf(1:nx*ny)=pvLg(1:nx*ny,periods(srcnum,knum1(knumi))) -! sen_vs(:,kmax3+1:kmax,:)=sen_vsLg(:,1:kmaxLg,:)!(:,nt,:) -! sen_vp(:,kmax3+1:kmax,:)=sen_vpLg(:,1:kmaxLg,:)!(:,nt,:) -! sen_rho(:,kmax3+1:kmax,:)=sen_rhoLg(:,1:kmaxLg,:)!(:,nt,:) - endif - -call gridder(velf) - x=scxf(srcnum,knum1(knumi)) - z=sczf(srcnum,knum1(knumi)) -! -! Begin by computing refined source grid if required -! - urg=0 - IF(asgr.EQ.1)THEN -! -! Back up coarse velocity grid to a holding matrix -! - ALLOCATE(velnb(nnz,nnx)) -! MODIFIEDY BY HONGJIAN FANG @ USTC 2014/04/17 - velnb(1:nnz,1:nnx)=veln(1:nnz,1:nnx) - nnxb=nnx - nnzb=nnz - dnxb=dnx - dnzb=dnz - goxb=gox - gozb=goz -! -! Identify nearest neighbouring node to source -! - isx=INT((x-gox)/dnx)+1 - isz=INT((z-goz)/dnz)+1 - sw=0 - IF(isx.lt.1.or.isx.gt.nnx)sw=1 - IF(isz.lt.1.or.isz.gt.nnz)sw=1 - IF(sw.eq.1)then - isx=90.0-isx*180.0/pi - isz=isz*180.0/pi - WRITE(6,*)"Source lies outside bounds of model (lat,long)= ",isx,isz - WRITE(6,*)"TERMINATING PROGRAM!!!" - STOP - ENDIF - IF(isx.eq.nnx)isx=isx-1 - IF(isz.eq.nnz)isz=isz-1 -! -! Now find rectangular box that extends outward from the nearest source node -! to "sgs" nodes away. -! - vnl=isx-sgs - IF(vnl.lt.1)vnl=1 - vnr=isx+sgs - IF(vnr.gt.nnx)vnr=nnx - vnt=isz-sgs - IF(vnt.lt.1)vnt=1 - vnb=isz+sgs - IF(vnb.gt.nnz)vnb=nnz - nrnx=(vnr-vnl)*sgdl+1 - nrnz=(vnb-vnt)*sgdl+1 - drnx=dvx/REAL(gdx*sgdl) - drnz=dvz/REAL(gdz*sgdl) - gorx=gox+dnx*(vnl-1) - gorz=goz+dnz*(vnt-1) - nnx=nrnx - nnz=nrnz - dnx=drnx - dnz=drnz - gox=gorx - goz=gorz -! -! Reallocate velocity and traveltime arrays if nnx>nnxb or -! nnz 0)THEN - WRITE(6,*)'Error with DEALLOCATE: PROGRAM fmmin2d: velnb' - ENDIF -ENDIF -enddo -enddo -!deallocate(fdm) -deallocate(velv,veln,ttn,nsts,btg) -END subroutine -subroutine caldespersion(nx,ny,nz,vel,pvRc, & - iwave,igr,kmaxRc,tRc,depz,minthk) - use omp_lib - implicit none - - integer nx,ny,nz - real vel(nx,ny,nz) - - integer iwave,igr - real minthk - real depz(nz) - integer kmaxRc - real*8 tRc(kmaxRc) - real*8 pvRc(nx*ny,kmaxRc) - - - - real vpz(nz),vsz(nz),rhoz(nz) - integer mmax,iflsph,mode,rmax - integer ii,jj,k,i,nn,kk - integer,parameter::NL=200 - integer,parameter::NP=60 - real*8 cg1(NP),cg2(NP),cga,cgRc(NP) - real rdep(NL),rvp(NL),rvs(NL),rrho(NL),rthk(NL) - real depm(NL),vpm(NL),vsm(NL),rhom(NL),thkm(NL) - real dlnVs,dlnVp,dlnrho - - - mmax=nz - iflsph=1 - mode=1 - dlnVs=0.01 - dlnVp=0.01 - dlnrho=0.01 - -!$omp parallel & -!$omp default(private) & -!$omp shared(depz,nx,ny,nz,minthk,kmaxRc,mmax,vel) & -!$omp shared(tRc,pvRc,iflsph,iwave,mode,igr) -!$omp do - do jj=1,ny - do ii=1,nx - vsz(1:nz)=vel(ii,jj,1:nz) - ! some other emperical relationship maybe better, - do k=1,nz - vpz(k)=0.9409 + 2.0947*vsz(k) - 0.8206*vsz(k)**2+ & - 0.2683*vsz(k)**3 - 0.0251*vsz(k)**4 - rhoz(k)=1.6612*vpz(k) - 0.4721*vpz(k)**2 + & - 0.0671*vpz(k)**3 - 0.0043*vpz(k)**4 + & - 0.000106*vpz(k)**5 - enddo - - call refineGrid2LayerMdl(minthk,mmax,depz,vpz,vsz,rhoz,rmax,rdep,& - rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,igr,kmaxRc,& - tRc,cgRc) - pvRc((jj-1)*nx+ii,1:kmaxRc)=cgRc(1:kmaxRc) - enddo - enddo -!$omp end do -!$omp end parallel - end subroutine - - diff --git a/srcsmooth/DSurfTomo b/srcsmooth/DSurfTomo deleted file mode 100755 index 041f045e14dea081fd4943299bf458dabd3e2916..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 294584 zcmeFaf1FiSz5hQ4W^^=g&nV(lmQx;U=o&(yF^M@tXJC&V6ccq&6l~D2$Vi7AjTD_T z#)&zAg+^Vjmx{XFqQoxOOQba*^22L7kSUe-N?x-)B8oqPkq^q}`FgLl&+G##etLYr z|J`}O*=xPu>-}TB*IMuOUTd$t_oMrEy>Vn&S!!Te+1vqTWo1M7Us+jJ)>&3ds;unY z{15p*b?U^%@lBUBefB&-OaD@(**DFJPdfspPMy@$GO4tP(N8Qd1^PU?l~wRxSN%<$ z+ID4on@hWVDZfR7s0@e&KcGhZDPO|5ylk!^{Ey=|^}4nzu5Ft=>rnk_?;dFUKIF?Q z|MvW@Yn%PK>xv={uJ1U{?-*~iI3E*Kdi{L-3vXIwdR)|J-+JDA_3RZhQco}cn+ z$Ku~1^=-Yb?b@ra`MfW1Fu%HAIDSW8?FuOGEa~zkya7#}+WO^duIq1*gZVYQx7_U4 zeVn6LKCYXCl>SbgdgY9%S6zF>m#%d1gZY)6=J@TX^>pNu`jv8X{nz!oOyi`+1eX3~ zCadzWxc~XQ`kVOn_q%ImPQC7iFMaOIGpEjKyOw&tIlq`)8T^uZsm>quqI8)$b>$DPnvu02I+;!J|%)<`Wul;;i-xUd(WLtVMMeNihGoT0atNpCw zmmCXk&(G<1`djGN;Q5UxYT(9woIO-O$M1}{;5XOv+ng|3vfmxb59572mUd`;!;4&f zagD{l1Z&rqikPI|%r>9HL2SN%gW}OO(-YXm0W9F zQTweWKN=P-)62`|;V9Jx!f*aUdD%j)b+gOM79CYq_Ab&B`L93Y!*w$Mui*c1{=e1V zn(NBTro0LA7+|&h$Gw)FHv773Pn&u5=T4h`!_4XA_4i)>OOMY@YQE#Ei$C?ix8}VP z{`X10oSg<{W8~&wKgkLCFP!UVvRk>A{pHpxW}f!>tG;|~ z+qG9*W2&G|oFD%2;V5?X=P2*=ZQ$C^N8ARyEuSxcY1Z(Oo`>`pT|$39ilq8&fS?O* zxUTKWFAX1?5NmcS)nBa~)4jR=t*uk9D+;Ex{tmUnVflPz_7&5=bVb{Y;Uf|XeF$D^ zhaFd!m$h&m=JTWJH~RaBM1GM${`cp9E%3h<_+JbB|7(HF{F9nG{}e2^2{9Ljw>;m& zb^d^kzEqI=KFQAR_AfQgultRhUgxgHHM+Kcwegp_?mQwmsjM--bwX>;gwAcjg4^(9 zVe1p2(%&KdN>G)#bAMyu{8VaFV=8K@|HCUmbtat_oZqozZr?xq*WoQ2B=oWef|D|3 zWhM!UPE=;tQ^DPR9h*{}yKeYq)3EKC;O++-JGxW7Hy$`}z{W}N58;~iS^LnOmNvd&O?|{aRb*YYh1I87G6eKaY?H@2#*t%)tuB(C?T7sB~eS`Wtm~y zGQ)ZrQ{7GVe++Ujynf(7b8FH_o!jUzEJsv`|J$bkG-tILfqH(-?k z`K@jMP&HmOne-5Y@>|^?R^vsKN!J*Z-|7bO8ZW9$`b2~BTiqaL<3*K8*BX@H>V_eW zg@z-8+!!==eaN?J$G()xJB>3|p5LU#p#k|#YMeD7za<(^G$_9%8c#APza<*C7?j@< zji(rtU#IagLGGLTiyEgkhN*QF80WNYu(JGCHv*_Sf)LLkwDHP=2c$hxGpW{~S1w zU*8d>vhy=T`xv6xe5SfDxbXflT!P8 z2f}I5g%{uySE!qMN4XQ<;2q>{z@6Q}yfs{7KNLI3VBR`GP0FTBT47|_&WfuR;V-kT zPnf^l2&d-O9`lz^kj5j*VU{?{Su)4%=0wdrZDt;zlQU`3n6cd;*tNydKnBhJUJN6L zS#h^R@Up7KrE;@#rHsG4rN0gGXPdw4_qnH$UliBV{A~b4{`T`%U3C>+b?w-ErI#X|yvrRT1${^)4Nm3JH%U>xNd;i#SnU02M~fnn(&pyoMLCQXlnsmo#{n09)ml^q8L8k?MF zs-B%o&vm(6+JRx}AP~zo%BVS8W%G(Ol@8J+lL>1c<EOrvgAmP<;GuOO6tyOES*sL;#>9O*z~F5K2Qy8c2gE zU$taLlr9-sIRH?Srd-w_l!lTtkcpz~v*aXEx@3!$0{|sy%1to{rJ*DZWSS`VTXMQ6 z_lNbHEH}f70)v<|MQ0iW0*FZisR}wDdE>wVgI5`3NbjTA`6>%6{P&@ zb4#$`Vp0}@U86*l8o7;eu*Hd-dv=#}8|N!H^gncKBrEC9TEk~O*gPPShlql^lh03i)zv_bf7dCc-vXceX&@8~>Xu1Y8l*Dp*wAn(p0A+{%T*TJ z)5BeZyI;x=UNO)t>MAwFI1C9UF-;!K&`?#;SC-`$lA|B4n51Q131%xnjL~7Gi zbAFpO=gj~+yR9b#^Im56$h_~)W30nD`I-DCHKAhYrzn7gBPJBezm-~-sejZID1W6f zs8aNUGSm?}mnZ6rfq+y|hIm7f>+GN7`K84JG5^ixuEkg(@@7J0<5jbD->~&a%H$s! zwmxj#7j_;9ayw91@&<&l^VTE+Z7%H+7`g`XTzX{;w*=w`1i2r0>apdJJ5RkTF6I(N z^3^fi5|EEAZ@Ws8$I?dLA#0j7(JoP>y)TAaLbR1_A2C|j2d0}%`1KU#5wOw>S!wK` z!a4ZcEkV~~4CKaPTg_ridVjSA^Ah4Oz#8X^5ZVN&B;(_AQD+ca`Z znBNp^>@Ew2<bSMm*(U+J#oCt7~BT{Qs`!fQ#v`e0&k zY`6;dJ~0?d44w?p{kI@_!1n$b*dMu!upNF+A=( zRuZgW$Q!rg&SNpb3WmI~I_^9c6Rcp!8=vFOV=-}FUt|4C!L9#A!+n}bFf(j@YMoYU zxuX=4x325l)?6sRl~%IhQjQ~$SK@aN$;q4Pw^;>IRrXsQGN!8V7XTX!$geLX%B(pe z`IE5R3e_2qUtj1{%kx{U0#%`7HNv3$`ck-4Sn*q}0#%{9Xx7}T{rXaJWLcY6!$F0{ ziXit1=B02+$GW3gT=+^!Ur0~1qWpT&TFdjBtWdiF`Spe7Sf1Z%Q$iKO@N@~_al(pr z`FIDY3w#ol>x#pvIN>RL{M8kQUHuhxYf6)`$b@+cMS2ExiRy4rkZU6L4_miT*>8gK zm7PYCwPvv%Q!LMKva&4({qqAQ8U}gK+k4ACO%1Z2R=Zn*yEikMd&_{b7TLKt85^8(2eHAJ+Xt2{@_&sN zH(u0uVdMP_p0dVCwi>BqCqJBz+t4+?*jC%&{Ke_H|(Fn?cqnO&J_ zMHCv*r1UgV%(F~ex*??aW-FFUmmx|eC;F11N-nZYE?wi1Egm^BL}0B4PBS1;p~z== ziaL*M_xXvIUz}c|eCrX}*0WUy1^tq<3}}91n13+OEGFKXX0rL$lF zzArd;GyWq_G!wG_6rxO>3P&p3c>r$v!gYTgK(aZ=ydGuQHwyDB)4M@u^Lx)JoNALq zxc3QBwuGI#)C{@}L~+tIkyYiz=vbqCQN=0+-wr%_eWBRBh_2DgO3ojWo`9tMhUTF8 z2^Ii%P=BdmvU^-%aTpyvKxRHlk31k|JG|v(aoTqX^5+wNGz9;=33W7C1`BThsOqcH znQC^?Z%<9r$;(D|lVs(@Jv_255e$DY_)a&v!2C%FZaN}Z@cd}inP_3#O~-}v+vsFO zpW*yDXmh41&%z*Vtzw}~Nb}F#Xx4F`HELNyaF_Iu`@gx8__y;$ScUbA4f}P2GzkLd z4~b!ASUAEN~*Xh0n+zW#Pver1puKM_ba|q=~%E5u2Mgtc~z;0`%tnl`1_R4=AVPu>ZWpPtr@P7 zWAZLbp!cE};u3L9PNF6m4Hhic)Y(1z?68$#x|W=As|+!^dR-?2?z|rLgy@XIKxZ_G z+<5{jjiG;4-Y5$GULy1y%D^M6$XA8$m(-h71T zq4}rF_gQA>8fw4EX@Fh|Eo6*by4$S6C{@C>|05hs0AKO&9@(Gn?8;Dh7G+c|qJip4 z8dHvd;g>s>p+0}H4eYQ`u|eaBabAZ38M&R4;0O5kbSKO)0_axkp%ODl1DeI<3$T(m zk;eg~-mjaU^UElvWmi0kn&o@>$H0kh{-%27f#~a85s*c0mR6ks{fTH=RyLOj!s!9} zH^{e+;JS|=rm-5aY%|JZu~C%pI{zNUY<#OnJFxT~ikSIHjlI6n(|L7)w)DicD)p?VYbRrv=rIqORfMbu5@*7~YO8JZvx9(AGFsw*(Iv)% z4jIm0X;X!qoF<+5mA$i2P@ba_kbHCJfwp7R%3;T7R$@IPD74x&^`0PC23OIloiOTl zdYd=UVlWAFU$xiu0=03ru+mzTlCs%rW{?-j#m(F}|H#;GKbbeMY^{zgWaX_+uc6hV zwZLSc(A)CGXtjsL)_pPhK`Gr1#7DPUsnr%D6iGWhP_aM}IIEQU2cpiXAlB8;DHa^> zsYg)%BJg9S)YCCboJ%n8C0aJ@*mq>G@C~I3<)1Z^m){x| zM%}vhbU4$%n;;ES8>3HnRjZAQj}W-gMeMODy2i5}9mbF;KqhoP)5f;@U!(IZvqzb| z(O8x3+$F*nqtlJ>J{Q!`?}ifhR#K-+FKe9Acv<7+jZ=G%Rgr_C4`7hX7*4TsAQ+Ih ziJb)4^InE5{~$(@!}*GOD}~e-=05oZ}({A%tvx)Nb?{Y6MIvZG)F|#c0E#R0+ zqmKhumu#@cR9!w`kku9s6@fJ#sNlB<9O!9B6d^BlirZ=nhl{``Jy2nA5%?>BaYmg} zp;`1}l|+R$uFb6%DjeH`BO8^D<1@K?AC|Szt;`K75e(l*ScVlf?&Cn~rlW|{f&~*e zv({YyL{PYN&w&H-@)vM*_g0Cj?f%Gf>d}R>K8|yV*5?MsHwOIvq4|`!Nk(pw*I1!W zCEtBcq5OW*^!|Mr!cL3V`_LiGM+qOz1SV(Qu_FlAMeG7i-W=}T-mzm~w!W`97{95x z<3Ksp>`FIKs5uz7DP;S}#pb)kt1x!Ig8oIwX)auRKs?w8Nrm~xrNaojn>y?b_T1#Q z=1H|e=6(!lONIyzcF&sGnfazI-O`+YKn1HnWb->vDw}`GczT_-qtgS;9sj2sRUQb3 zZEDV=4UxYw9*-)7l~SvyMlL0pz(%_jdrMlR-xSq1$&J4iR`fdHZ}9B(+Y8k zJ)PlL1WJghl1pzk)OO3JHhC@97;v{lqf56H$L^e4B&+;bQM^r4rVzXG$-{bZy1lOy`c>O8dfr1!C8TEr-`24-z$Mpy;Q z#DHCzmgrNYX(fWXbrd`~E_k2A#T4AOauCIR zDm|PA;;M-F?vq5#rn}-jBcsrUnBFCTY>pu=LFnxgpdJQ={8A1*ae0@Z*kduoCE(x^ zpti>-v0}SEhJbp~Am_UTyY|61+c*Yi2H4@Kv^G!}YdN?&Fr?2o{BlbKbsI3yfakp> zx7$AX_BB=?+&1hP2A?moK+Ote^u*rt7-|@6IyI(>fE4f~#ZHN)MU5 z(QHy#N`UKkkjW1k+K+`?T7%Qpd__@JF{OrDDQbvAEl(@q+Wv^=eESYTe>YxU>Ghx* zSLIwN|LtFw5E&*y(j1ntT*FivyHpuxdVeR_RDPGAjF_jYvLkEGX0Tfp9ixjJyKvp+r z+^VH%nLF0Ih;^+(&5LcI<#uPck=DcwRBSsT4RvCSQX;sxqVfgb6s`meT{BPC?Lh1r z7nd`(rj~;?R60hv1cmEjh@-->IS8mzW0Xq(8382d99t@W00PDs8#8vTDmrJOPOaQ1MG0I4SDKP|8O^mVxH$~9@;g7Y}L@wLjG zCpgiIvm16$*2a`Bk(8H?QAQ(q4gytOjIspsU>D>bQ=KHx?v|}mK!tsZ0xK;)A|`c- zq`*-z%4j6eLEthvMp?oHRPY6f`eJ8I1%v2!e7k z$`U4MkT!D_s%cwLAy|;BrunpmsIX~3aNBB|ZdY5_G;-U>EdNasSA{884enK!bb3&!=*NrfE`B0^6E$y#pUZp&6J(v>I`Ld{OdEmP-kKlG4 zRz5WBSYH*^cUe$){kNpb66v4n3(s_sV~{&ny2)I(?Qbp&$*GKDMKk5|Zd{MuZ@Jy^ zD0hjZAzzJAjslGw1Vi@4D3_=vfG$i-g{%U)ekVDIF2Ak0Flceu(LKN&n8>B~J0czX zf`uL#a`TWSl7h=)l%qhfgFsaoqg;YBWOJ@GX?JoLCufXjxkk1da%>&NP3{s&G1Fs| zqd<&5$A^beQ}e!L{i?O7-ck)=OD;i6{B3DdVK6j5Qrn$H&D^26ZoXB zUq&Y?Al(s@xOqQ#F51?vMFyUiQSbspmc zb0v6zWtQKBR~d>|8ERf-k@pyOMQ@{_>?{vA8kDv?@M#`y*J0)GcAg|e0q03Jlk%RV zhh&hG6LcMtZ3nmB9P$m6_3mS-tRP$F+^Aj>Tg4@kwp<*ej7GL}5Nz2MqgFj5=p^xW0X-!u!A6YPKWakhMHUxdc8%ZrK)d_4nER!l3hHRsn=lT^7x-?n7Kx zI*fx5mw;7PLCAt_{EEd6nMgs%yko5&HPPpiLC9)9l6BaK1#hf|OQ5{C8LB--8HHv} z2Z5?B_8XR9<|MQoL)XAYO*oDN1AGKBO1$U~c7&Ii-B{xmT_P!LOpG!T33CvHHN+@O zAZ#37;}L2pY02ISTbVgJ8BPG0G*pXUNv?3l>_Sf#>OD zZ)?z<@&#=7ncx;jx{JUI5dGMwQuNU`wbl^#;P zIz26>niNwh!TM?Q4!?eCi4iIa;_etB$!^)Z|Bt?G2LIr;n0jMS7`qJNY-#Br)hp9e z9B19@NA0X=hp)7&*2O;2`cFlpjyPy??e?jOo_|81jVMs z5SM_1OMsdlqr}RTcMwoB4066p*t&QUk(ntuGp2GvVdx-G%`z13+b5R#1WtUqvj%(6 zR))=?8L{PkVyQ>z91u*k35dL|^vsyju|Q0_K_>I8)8sC1X88FY(v@zD8M}mrlR=<# zOz~Y4UFUH-n^vtkF;$D9pmGqX=Ef+O0FsL#E0TT+(kCxY z@31;i1A%EY{*!4iXf;QY3<_tLfb)GZXC;jD>BgB&GeNY8yo3p8q+70ZTWL7DglF&e z<*21gz;#1hZnU#;mqCKz%<@hZccTU6h+TjL-&;SjI~dM_RhjQ}AJx+~)Oxn^4&#b- zEA*OZl^O%8318^FFN_CSXoFaLXDt`ET?^qv>E$R~0Wl`9}fgWPJ5jN$c zLr)23jISwl<5vjQT6ZhByc}2%JU^GN0p0_?wul#tJc%l$fu2vR~{7;{&Zv>GIs3n%_Ec3t|j1GlooxAwEoUp5Dq-xxk4%thkJ3B;%{y){84% z#hu1SFl4tGAveHB=Q-3lxPrB^N!$(z8X7~T4ftft&?OjMYK&;{!|qUJnD6BzNB^P9 zHCqooRN0l@Awy8f7D=5JZK^`Ijt#X^WHb_)H|9bYefc4Opwds~ZdMP558;&PaZk%m z=#0h}P#7%-fB8|@31$$BYeHCt7@Kn(J-R*yzEB4ewP*3RlLrm_+N2XnuAp6e%t!OzIdsx*_8E2hbcV&;U5NI7HkYRtwZ;!0j= zEsKYdxq2_%p>wQD&AI9A2c5%t*r4~XJYxZm{ zJ8jl`(x1&z{@|>JT5m{iq@=CiR$6@DTWhC*6np92Th(3i@3kJ}lie)DXc z`tXYf4!D4A3{@l=>-`dkgZ!*Tt;%{=yjIM^uB^AMKhKO)*4s>;?yBQUnk#hfmNPlE znffSL@NwonO|WGEc~G189MCty{1chHD@ZpXo6&h^rbZR!;D_~=&Thf0!l1cFH!V6> z5M?&E{+^BdV8Jg*i@;9e*K;(74e4OvgC4rW*x13+nvl~r!QGn>debP~4d^kP`k;Hj zB^)T(g*msD3)_d4qHj*KVeRqOX$ylt|J!)P#Sg~x54w}g575V!VV?d$r<`@hRdHu@ ziMTUv-&7oN{lje_a^7~h;kb0VtQ*5eM=-_7fuXrhI5S^Wa#2guDV(02+cH7Z%ycdD zwoG0HK3H(A9wVY#)--nPN^!4jTb6@5WoRkqSl3**a6mRspasA^aUy}cVH@TrrR%bc z7_%Z?uqrH!=|miatJ4uBnp3peoOEqiIG4vAU;0d8OotvSnM)BJ@ab5OIKAIvLg%hv z!Fy09TR)Sg>k3Hf;C7WNu}r;=zniXf&q$usp!#GAZu@!>ShD5ww4D~#D_CNg=zuIq zEkXR|AfT4SD6w_RO-rb~NX%YN-v}1)zCD!M6682*DE3Wd%^k0$eu)XlQFMxnt?acD zY){0|nB&QvbO)Kdox)4g(;a%LrV3Mfz-(u4w09YBXYn!x=p+^J=2w& zDzC`CK}_WmUQAmIb%hb*AP}_2D3_?djNMtqa1v9An1T1`j?vPz4=bnYF3ZyN+?dKG zyqH`Jb%hb*AP~%pQ7%z^S!LT~i5PT`ZVA&*upjxUT9+(MKWsVL#wD=oW`}1kvIOgW z2LZJqM!7_F)1V3UuLZfI0js05B=%tEQn4m2kQtI{kYHoC-JV&6c0t|Jw659I#tDV= zzm43}$cF0~&2&U{VSiQ zSAW~G4a&yVA;G?rL41p39D1oE3uqAs!Ny^Xa*688x$FCtRCE2_pzBd|$rdL4yKKSO z8K5=ZCHtH0f#Rjc8lDOTir1s|>1k~afb&%2 z^7(Fwpr^TW52-Z^6`$W!JlH)4&MKm1gI_LukwPTnwSrr3Fjr|sK@8TvcIcYyBJpo> zg}@dn(Dt6k4BkIw;+;Usy+f~Z@nbDaqVIh2{33cfUv7`-^!}y~8HI|${WZDi(3kJ4X339ClgnDUVtt;g*CSP893`6b-8=uRSftW=4^OOF z-}wZkVN|JNCrL`-^wp$CZZZBZ30&#GgXvzsB+_$|pAhDS3!Pf(lkViZ@%-W?#&b27 z=szj)7Tq@EiWO9BImIUA`}#XJdaPs&n-;H-h;H?=ya{f0CLl_yRL3ry^>YBxWpA#~ zHYe%5)HV8~DMU!tFUyo3?#kROZH6Y;^fySkGgXtgygF%M*@fBsgL=nEJDr9-7LJQC zO_O616F*TQOj!vUI_rha!S^-P#>*$ z4@h>!SqngrwI}B@@e7}#Gf~|5j8M@RAM{0$jkHm~__f*@V6*}Fg&V&V8DkKLf$$5Y z!651AyHwZ!83O>O2x*Fh2C0j_8W+hL05C;JQ)Hq+;ND_sAd`SpeDgPAN-fC&Yq6J( zw6I}+<8%W|F~B4NrWt@=d<|eKGA(-T0ZN+AY`QJA9+LMF%Oe@1Lo6*Gg z?YyqZAT80c=)H5HWhO-x%6!|N5ckiAPr6X=k(tn1Egv&0JAX>LUArxF>GQm6D%<+0 zY-?@U`jKG4jX2H5`2#r+#@51upVKYppRG5rv~CLv*QUab?t!+Znot<^?KSeY#PsF1 zo!7g8+*ON0R<{c}A#1LGIq0gV$b{DHZGDQM7aT(_%j?~`o-_RZplhQg)(2fbP@;9n zuWS+bHG^^-?Gh5_76#=N7uXG9brRB<&OS582+J(mZyDD!T(gtLT6702da5;8vTKZi zjC;aVh6-)s|Hf2!CO##|{hB%uLzeTdz>hP%HP@rsB9xfWI_Otcg-@wM^^XQ!?;+7# zPZjonwo3Py)>L|>60MVN>$A$_gs=a7(A7%fyuzS)iOSR@D|4c>z1`KN)-(q~=OayB z(gvxqx{wA^XOKEqmtMVmOYg6tS2Pr#tK!Lzm(4?%bGXMjhgakrUYlrM@)*+oIiIus zB>0~l{O35UBH>x#YBfF!OLgn{m^M5uuDWD+di|Temu?6># zp>8uTeAXCNg44gEsu#}sijcoFWU>ty_ThvT{! zzf%+*#T|?;N18$8hf=rY8D`}9^<~}Qqf63Z`Gvv_KHxyya2#Va!114?DMJT`3om|J z7j%4@4jc_dV_<`yHJ?g}1}nj@*D+)HOmMMNF|@3H2XBf=vIgV#@_0USj+U3ZMW;2o z7Anq1BW)fNnAR%f;7?e+mO~&eUjRgM3`xBYoTOMNo+mkkqWQS?trSYbSapRm=#y?!mmyRT6zYr7_J96suXg$+Wj5 zL~1Q3DoorCN{nJ_BY>o=tv|J_UO*z51O%2JO+GpY5iDZ`W8Td@xmaZ?MwCd*c?Q-i zy+rO5{LlUBG2C)DzPy}-W<{jBi&tbKNiCrg{mQy0Fs~a0%A$wQQ8fqu3h&)tP3`@O zy9q4}zQGG?fdblTTv&%FX&kFcInEWw{0nRAC<4pqd*pS!#z{KAMAB`gl7jyyNkb2k zG{Q?Ncar|fgwbE8Z<(S6Q<@2pNMn@j7ok-XJS@WSA)mq?nIkmPMN7f{mbQ;e?5 zP6JvOgjtw>B;=hmmC@Cn`B{#6Z3*-I;h7%@r4(yV98G*Dk*;m8WuVv7Wus$_HT~t_ zBK86uZP7$8dM*v6MR;IaJ!+MTJWLT;VX+k*eEnyW_WtJK6}`xd*i4@+QFMbuERu-X zzR1I+MTDOr{Dt79Lba6}{Ob8h73Lpah2M>rt#~rCgg*_@WzV2Se=|Jq(~0pR&)IS- zV;aIG_xIp+z1_+k-&P`DugcQX%^F5;(Ge~%y2a^HSQ$RNN>Btl;O-6bcyyH)G2Dr$ zE)h{UyolZ7R7D=5Ni<~iJ}-9__3D=!CFSmePF1_t=#T#{Q5ae3AxF62@N(OYj@p-0 zO?Q5aRr`(?ae)(YMu~`phZk|Y(QzX^S+%hqSd|2R)Jy7Zk}-~d*rK(#GK&r`>8D1w z+7740T{U_bpe(f5F}=Qo>FtMSdXZAtC2#X$mVsxi}{y&(oIW=!KSPRT-;dp+rgeMbQaUfv*EQIRj z3E!KHar);IlQss9-a5}p!VF1Z+SK?jTI~Wa{&*+;dE%n}D(SsaZ#@o8$P=HIDNbK| zZ=y_8mLQAp=i#$-SrC6`8c^%F&9R?36(cwF$ zgPW!g^)FVh17oRB4dti^_3Qh0BAdYT>;=c<)$L*=Kd_f1c!GQi0&|AWg}wFEZ_;j; zG&(cV-jL<)>Cf*`{`-N+1l}TD0)xU5U3pDzeWA%X& zR{xk_<>}@+7OJVy4f3iS?dbpPf+DZV(!jm+g=Xrk4@vJZ5`Ok;vsb^KB(+3^>Yc6W?^;~v%`e)8YC-1({>ATYD zRbb-z2v_R)qY|FqPw)hJ8w6_A!+J4mm9L5;-APeR+THqYyDj?>`-B|7{d zp~G9XKXi$D{q-K|b)x6F=Tla%-@2&D+vvU)?(P4Q)hqtKLDCiQd?4znz#`Ao?a{G{ zUVrw$6-nU39=IwA{11StY^RW|JU~pGrM2hBK7k7;jCl~%{Hts9!pTfu^sEYYcFXX! zFbZ-n;Zf20gRV+pD_#;FzG^>7RP9i6;R)Cy9AmFCbAoTWh+Sa4-AB9|?Nn#BFm1rj z6AwDC)XZjTbH}F23H8smot&-z8z(q!qrYl)_AdPy*zR!-E7jJcD&7eMMQ?BsmRInn zZ>yk97So|y`%&X8pOC+s_G|+tp65EAr zhRQL7R8B*vm+PAjp&zPXrwySx8$uXJnmy&>9StGz@EY2?1^lG^78>4LZ#Hv+Z@R$u z8SzdGp?ABTTlaft|GB!O)PBq1S!%zFfS_f))6#4A?{8~A>(OcG68-0vmGqxcz+|&y z9M8WHPm%RJ?@jPTU=sxIsQ;L>dq*d25s#mPZ1E=J=iFOM>;Dt@l-B=qKve${UH>DY z>!GbDiZ^3j53RqApBkg%o;!W|pz))7d(m+4vc;Y=;LrF`ImXYzQ;0K>x5b4| z-ZmQ!FK>nTu&wm`q4JhU-mk$+-fdo<$|)MJ0jWR9e#XN_cv$Zb>0F8LBXGmyxStIy z`!$bBl||>7z>3-uMc;v84xH{3eJjHp?-l(omGg#?qUy~0lau+!(`2MKnWsM`r8>K< zZ73h)nz{3VId60kmYj^_db8?|8`cVHe>88^D zm4RJp|JpN3=BW6C3zfWLzj<55Y{YMXF0l?ce+A>~F<@%rpF5tNB|N(mJQ4Vpe?jg$ ziH}X%MR4plL+oD;GQ*qrm)Qr^{~Y*~)_;K0^$#v0^Yves&=ru@UvmMGEUu$Ae7v;& zR3~~2nAM*vRaA6G*7IDS;Hmom_#M`NEOgODaQu7ff63QN+y5N+98`a&>mOWb<#l}r z<9*G?RL8d-?~j0&E$&n~hLOg*hR%sPh5TkiXP^}6w4tN%ALNd)k`-q=%`|kx!)v%X zVNE~>wUBwhp-9GNPH=I47VpH+In4Zg;A^G!D~D&P{q7wpJ5+qvg=Sv6EpMxx_2?XQ ziSg6;Bl^!`V6xdYj%QN|&xaB`5%{C!$bHA-XDA%|Z4r;3gKY68|Uv z{Rmfo7moS*|7SwiLtDpsbPl>?{i#m07?{=H@oXyL`EY`#>i@%cSbvi?6pnvS{o8Li zsQ&OdsQ#z9`n%A|*I%#1IE-U&H@emK_-H&oN8be~16<*lW=fbodU&QM8y$01IcoD? z%zV(in|>cPdHyNK{}~q#d8K;}&;Nnps_bfe9aGFd+6_=juQX)E!V;!i4`m7@_M|pW zr$9&B_t~4jVDuh^2Bb0wJTJ@wHep^OX1$F z+6&dYLFDLmzl-a(;I8$-y*#_}v~uoK6v5pa?VYEc-FCJr44V3)BV;@9(gXS+xAa4f zx2(cR7$KG<#Gyy)W=UHH@RzbEdOait?z=r+m$~A#;LHysHTkG=u_o+$QsfYIu2;RC zIwQm)clrkt>a_Cov#GUCYONB3q7~d7LO>(C*}C8ZhkUl8b4xSNT&Tc+(C(MYp_k?Q*mGpOW_}%8cePKOEQ21y>aBsI>mpdYxUq5nJb6n!mOT{_BR>f7HC*Wa}&eiR8EhXoF)et9G5?&THE?03>rf(5hKXVn?P8C9fBFo*A?38YdtP!E_jKwk14e+2bGE3#$c-<^s3#z0-akLIlu78YJX}vNzIb<*B zS7)MFX%5bPoH4J_?b9Oa1sCx0*8b*dQm)@VR{G%PT3$CWc4;-Hz+>uc zejrQz-IC!oQNE8n3To(^>ksaB+Ulxtj`(J3&J$L%AhhpDV@g-+#`_?aI6l+EX@yPE zhhpiO^o$^P3Udo*<;8mBE{^mCcXyc~bQNoTz6{rrNl%k|PkK6@1IQPLrG@ltuU@nC;$bFj5 z=#{6wvFe%p%dz$v^Xr0UCPTLBAkpz+>savDgPisVOJ;v`tmDjHHqGZPoyqg2bnNja zrgkQlmghzKs#4JOdi3artolLj=djRfq#Nsv+(maM3Rp>6f18-#b56B|&Z!!?n66mBJeP~Q;%U9saI_3eo*96+TA z2pws!;e;o_203Hk5IOiDyz^sYOy2Rxbw_6b~_r(}h19m(=WC>8+4pMPN z%+3LLZdfXt4jWt%PU~6X@{0PH@8%fe60nniV8Q+`QU~4(yNVVFy57a%&8E(0CbaGk zawn12+vZjn=A+~kBGhvZ%K$&j$|^)ZdgP7w7w~p`;KV)(p?KtNQ<&Nprd}4dK?2mo z=s4)kplcqa;@oYFz9&Yol_v|jUYjAdZ9LV>i87w%qcS&C;q1 z(q7{K6Fg)my3t{ZdpmzbQu%FRVYR)IjT71h9?Vj-tbvzRTiO}b%}ZdF*gxckd~DY%G4hkbdun<0~TlyN2V$54b_K5Tn}haSf&`Jy6XSkI`s` z2Tn=?FYv%j68JF>oRtK=&jV*9ft3Iyu%{MZgf{`#@dn=%dYRQ^#~Z02r)Q;cQoE^N zW5Ju)AymA8Z=^Ao+FSQ++zSon_$TEx zJG-r=pLDSJV*)VQ;UE>iFnR{E1Nb+!J#SdX?lZ1foPcn5%*rJ$e~2UHyrG}6QC!v~ zfH>VDdNn3;2_ULXu;BWu)N>iMINf03ZR8Yf(MOjU;0~cNQad>t!@BYz$S}o#dQFf9 zK^UGZxT3_Mg+bTXMa27RR{;vT7J3%bR1ks@x{AfXuJl}`Q(L7#H%aKr7X}M&6a^}* z0Te9k^7J!Q7Wze8_0U_Wd{Gq;>L=pV1EMiMW?r!H8qa7ukYM3l&uEqiDZjadfglqF zfkPkH{3tZ}f@iQBK(KI*XHchN13BfTD_yHbSJUJnOr=gJCOd%Uac2uZCo+7C`ju=s z8U$}S$WOn8&$9FcIm1)k2)NUku~|8Cm&(?PiJSEEJcQGG3Xj3sT?GsvL43@vA%o_- z8Dg1%_t|EGuChgjXP_#3-@_xqeBZgh{HI9@P0&!;yPu89jy@hMdWD1-X*WU)wE3WG z%($Q7mYAg5lNc&4YBGNeCK-Q*#4!`8ec78vN4=->`VK~F91?iH^Iob>Qj@#>NEXA6 zzno~{MS~2$+N+tHD#UHJ>gwPmfF5d?eI+9=UK{sCSG>=LqC^NC)bYoV{9@Kjb5OzvfDR(?KfUll+^b#n1 z#QA~!;LNLJEx|a{iF1QE6k&jafGRiCsV;%)D^RL1?hP2jwNsx?8X{2(8hJ;ri!n%{T(ME|c-Z=o0_SYHrmZe)z0a(pqan?kcK$<5B=y+f0LY$1hKJ&P zIS04G3p7#^3@qSDfWlHvAcD=`&pXj{p64^;z#c#V*Vj_Xm zSG37u8!zg00$N4g_CzHht$8-G|D@J(UzBQ_svRor&}`Z{HMUIL0N!>QbT#M%d$W)k zm)@>y|3G6dxOR6)jO7|cNEHX zVn$2u&M(MMB?r@g))ckWq!i>r^JH$IORLe+!ev>m&&$BDkS$9kWVUXR*w^@KUcuC) z*n;oK9dz!Az26&AYb=LtwjkFI+A}4VFJ$1iM8c}1Lg#zO9#SWC4iDAkQ*(>U89m6IVLY81r?H)f z>3%a_uM9d!zf?c39j4!JtE69-ujl50PDO19g)n3=TcwlwEjgIy&xRIz#|+c&ICy#s z8nrj0>S%j7a@d)JxqMz+Fti0Lg^HCYSyar}*QUTI_zG#80)>iy%loo!<*hw|Bd869 zZ5Bp6NzKB7MqfXk#s7OqY3?qZJ_q8c08E=1YTh`y_a1K%vZ5QnD<~gt8W6}X!b9J1%IWR~YUuU~LX@1?pENxIdp$vvMGp*-P8Gj+f3oJENXVkF=;k_Z zs-Mx_4jo-f9)a@<*K>Zs?=Tf+4A@z7(0)rZD~RU$=iB(kDH9cuL391XJX?Jkssm7{ zkj+0W*uu{XM$;*pkmV4ekc1Ju$Sf9JirnIjx_^A)q#!c zZe8^WgMpKnMrqo40CYamCLC^8v?I?Z9Y%2=Mo?>#F-{_6{$MVuR_3h8-L%`HA${f!p-ka3r z>;z8)exlQj8^3p_L0#!YyxE{$QO&d2TZ%)M9TIiU=wAU#;6koU1U(EfR?uI2pUotd zj1X!%hl~D5ZWo@U#i&(ef&~|UNFh|wurN`~iG_I~l3saa6W~89rkyAK>7|;FET#v> z9<;$UA;vJ)^#;=v62tne?wjLmr7vQmBDL8yKJ5BLQYa7kf15h7JPGN7)K{MQl6>s5 z@c}+Rf+`9>(dVDhmHcR*mkE?_@%gmRhsslBRjKTzAsW1@5w|aRTVEJGiiw0)?aFRC zR%lgjBzvlRqhENWs_AJ}OGn!heH%2!QX8-em*IolUoJpgp`x20sK1L|X{K?${?Gwy zUG1j{fy4tURspaqBI94RWFHGecZTZLmS$?I;+_FLaUBTCXz1z7` z{LBp7^y1AsI*~5&%~W45Wtuh{$`CJ^ss`^T(bp$Ft26YhR~Ft%12)%h4Z5a~U~%Z) zzd_q+L8upv*tYYiR#RqyjWy?DqH{b>~H)2VlNBS z(lyH$X8Aty%ygCAl#_9scB|7nP+4zek?P;w``SGN|G{-K(#19H3M_yY6;Iye_pu!S zCGMkJnSRr)2#_aZh(q!IX$JxISd4NBAk(1gy$i`#EwYWZBI4AzaxOv95ivvw-YYxC zbOA9cMko=TIoLMqczv7G*(Z4KO6KSLO;d+p6`nRiIJh@mVM$A<=+7|agP8I!LGBlo zG})Oe-Mix#7S5+9ZGsii#M#;U*Mo(Z0CpW#6tn~*d2!#_*7+yzz63b@I?oUws7tJ6JzHs1tO=$ zE3)&Jw=1QYLVqd~Q}kvTqyj8*I72Q;q~ElTlpmd7_NI(qQS3>^H~ZwEGjA+_nsIs(qQAnz~^?|4*BM5O~Xl1~Aqx#vLn zK;4iIIu{Su81xO_dnS$yQNKAR>7_n&cu_xr-CE9Lh&P67`x>Iw0+Xo4TveaAr}wtv zCI#4T)pIT&IRKM=soR(7UBL^@(d?8G&4wRdvnpv;3m2!^`=nW|*KFTFmH=*NZH?r} z4lPRbZxCsp?w_1nU&1BJs;g2jdaa_XXpy4rNFs@eLDtl~-V&b(Xf7W$t*OR@Urf`z{#VS&(X1Wy~? z$%!$Fc@)lm+XY7r%Il1UA#@_bL5Q0&G0GAO!o-Ic<<OST=CA%%)pZM>o4Ph6o%XhSO0;!Fs@;&?PiMtvvF;d2qx*JVJs?Rpb_aa zj}8KAQjBs5zF5a@GLsCgC+9#X)QUuZBnMfn=-Sjy^ZPm%8V}flgd)p*k^X9T4*;z1 zo9WNmKpai4WfZo0eu*&#ij{=HTVka|#+%UaLY6>Z2caPaQ7|ikUp>mmlr#YZ7i!p$J45!D5e}Kfhc*bKI?6tUInPLY$wZ};r1({>5 zj&PlB3L{5_?F$$V0%}H#atW_gG>^D7;f$JQ%cla*c=z*$A5qKLw`I69( z6(_l{&DSOWwq8IwM@K`qmVGYo1)gm~`g@EQEAgcC_jy529T=ef8f^=(Uo+_=#r>M% zUcv7xv0%J5EgYY@)(wV5C=;DO$H)gH508ABWjzu+JgUKOKU0!SNF92{rqP&ns}j)*S< zw56+>Mjps-Vn4GkzdJ(>(v<0la6(msk7GLk#g|cEHf}WM2N!Qff9+tSDKAiR5(Xdp zRi>K!Vz=a>II3 zk8&3p7Q0n=GyZT`j{}TSslGV38?i``W)$Aeg`BDY1%PQ3=G~)p81=If?qoI=ZcdHl z5CijwzDOdfZ0jaX2y&fTge_i=_m$e*JK~Y zf6(U^w42Sz%*Mi`<5FOHz;F+B4Hu|n2Zvc~=TF24?PJhpO7(t`GMt~V&#knRri_%- z{k*Hm>db`dl;OPET*`B&5olB4rqqPi1NNbY70r4z>%O4tdJ@g8k7o<%J0PGUJXMfQ zJ>8uDoo?$c0R*Hy^)mYgjrrq(u9GNlE>B%sr8!_Y*-aIzU7zHmsl zQt*dJ;APL$qGCepGZP3G7rfXc5zFIRkaM-D;@!ZQUA0gjVT)&6;nYMezKjmLWiDTf zrouJ6ZQ9plLhCL}B%6(|3KlF^v7(`_AvdA^X=*V95o9Ey`%Mjn4!aYEYV6o}WKo1M zA2Ol!4eMI}tYSq&O(*9JRpUC345dDNh@ntnn^nRYs-xSTY*lM;C$Y2JHG564;8sd0 zh;ofR-s+&nJ~8OJ<732^Za{I~RijdEkq@Do2uepfwTBpV9Zyc1o+EgraWg}*8Mm@2 zv&si)8~yiH7^CJ)3KylCM*fMTly&)+xXJziU#t&0Z)Vko8B(|d37OFPtTp1dK5RB+ zmy|??Xtuq%Fey!N%hxsJxXeASWD1&<=@e> zK8o;GeMr?`?5p2SjvCLC2A$oi5~o@g?GF~54kF8h>gwA!;_d4zPm&u<@Mc2=W*y#( zn+x}8zMw?IVR_9GLFb%(9Mkf%40E;S5)2+eoN}MB0Vr2XZil1OL>zQJz=w{Sc#SY4 zMZQa6e^mx&qxo;=sjP4+zQCJ*IT}F=xef7Ge$>0;r_B0p0@SqW<^uU>%?ThBaTaf8 z$VHa}pja)JV8J|$;TILUw-a`5$sfbbcUe;RI>J`A+Ag9Ah^={+_CM^6EvQn@0e9;z ze?0|nF+X#U?N(><<^Q48LZ&e8Kx6&pAlC~vZjqZF(n42VlZp%>(6LvXzKc8Y(J%H4 zP+0gI7X|tF>JF7ePk*y}6P{h!1{W9VesUFtps?K+qcBNDi!DH-o8ah;!c8p#iD1FA zpH!VV0;~vQM58qQ<-`IPum08cD zot9e+mUBH{-w!2jnir1)2PVjJ5Kvt)$|ZoPCefO|4Y1|gILB8jQ*|)owy1>n;+TO0 z!`ngNv?NBkM9g~%ypu0f%aWIXjt9%5qe(Xw#@oHx%5v`A))Cs)W7Z%sBAJSfc6E*G6jxom!)?Vfy=-AQ&&?yRC;T|#Mkfo`@HZ=Sr> zU6Bn(m|v;bc%{E9;s8`|v%@gB;bYe7jv)@kQp!Onygf#_1P}%Ky&3KE6e|Af^<;gU z-nPClDvLJ1G9bB;KbW{P+73*sl3#Gu!0x6Xfy`9y?#5e59Baa%x6?5NDMLO%K$uX_m zsY5{PL-~?d+2|3j8``Kvbq`S7T>1Y>Gb;|%k!>L@|x^cS$?I95{S)ev=cNB zHB1vcU9A>Xszq2B)XBxn(5<{*ZOB-=$v5X;4^ymAH)m7SbI>C)AMgVg4b}%7-`WXyHpbcMYIN zIL}xUir%1a*(}FEC{>u1it}}P>~WQJL3P!&*v?&eU+X$n{b0clyp_a|%_y9OBT_}w z4OBmQNeOQ*j5?Bc?`8{)Lwd!Oxwx@1?9i80>FkxUdvJ;Bag{;tlWu4-QQ zKUP-p1p&xdKDu>+@WC+Fd5oN(&Rxd_$CV#DHaH=3EMFyC&zG~Hy?(2@ktoAdUr0PA zfk95Keh#;l%=g}*WUW={;dn$_!UY_B*CJd0(9IW~QyBBHP$5d{X(PKI=j67GdSWU| z7}d=mYAy^pBAeRbB^dWU^C?86mQcBGXyWBa4>6UUd&v%5Zaspjs**$e&FGwZJWTyQ zJFqQXgEwsta!;c=QQb{Ep6s97DP&F?k}X_V-dvb7nx9E$(fB=|DU_cO+__$RUpy#& zr!Di=w_VET+6H}<54fziVcGF?5UzV}K)Cmh9ZwIWlFh;Rt%|O47vpTzjO8@8+YcNR zH>68ck1G#4cd@m)6Ekujh6C>)D{IXGAe5vRAYYL5G9R ze?5DOH_cs^!IAScvw+N1l16oi zMed^2fpACKMWcnB`Zt%&?y?H0x3$)(oi{Kc2l)>ZQGj14JT ze-UuaKJ)C#9LzOZeHYcgWy1~>?_I~ozpx!gDWXs89KaUJ--6B?KT6jnXw4AmRtBAu z$WF*VOF!5SHES%Quriz_YZw87&L98L;-KFvj4L+7`(@P9W{{A@*E4NXl5zTKV1&bIiBZ5TnVjuP@0X{e?3aAUU5>1 zgwY8J>LJr`1sZ`I#AL5bzNAnw{4(b-{9(R!pwkhp;6v_0f4-JJISnWdQBZRt6VY=+ zug1Y@JO1DfP6%S>C0>zCkLoOWH}JnvWUU;JGuWBasN6pTlfiBf!$QSG7e^vWp07Sx z9mY{R@V9<3a08rGPp!tHYWUIQa&3$^b5V1_2Mhizo?v#9>vwRg$Yl#e6H#Dh8h}P8N7$Om z!%s^;=C00GjHI4*DymR1e|YH5sm*iq%|E1+ zg{$B-oiAHpq0owM#MeFPOSmmJ zu`B?m6}e=o)9PgL2(4t9dghW3I>(E;P;ms)LVsUsO!TFA98;R4f`JB-(eM6ZBk++I zlXRaxlx}W69p>eGQP9QTGrF@;gR1(>$T+Skgppa$owqSXR2)E78GS0c#w^rknL z;?$4twnY=6O9=Yyr3jiPn3G{Mw#rDxN4R2yR7qvRL&cz7Y=jT0GLJlCbX#6X8lm}Z z>FPvxr=z>QgzlUK9UkXYhGW9^3}sa1up`jqK|udBUFxcmB%R?o#5p)fT%FUoODB!^3c&h-|O`r9qs%d)y6$P3*uR? z_eAk|)Z=QLi~&Y;pPiM8{>^Z6IC{it=|fVCbo5W2Vzi^U|Km<$Wusd>uGZl?JxfR_jdm2_D)4^yePh5~Vz!&CZ%P7=lNM z$wq&9+F4L*SSNluV zxl(`fyp)ap#5@gysJ~Q=E49^^Qa1W`SL%5y^+ib>p;B!b^-m><6ZHu*eeA69vc}6B zr}o|oiLK_C;46FYU{@Tcb%U)=Y_smHO#|>Nt9MYUaQs~r_L;fD>DvLagZC}+(GuYf z=KBC#en^1EzP}v@rSKKd@Lq_kja9{0T@>d%-Up={9>A~Z)?Vc1c7-n40x@2txeCQP zgQ-vK0cdLP0UCiuA9b8hEa7}|Ddz_6CB{*MZAQTo9)Dld_sCOJuq5ge#G=0Y(Ktqx zMt%2FWUZVBeiDf&xnYuN;tlD!IPw6^#Z;ZBD zPnc94fC!yLs;HX$@2zTXB39xtRLx;BZp3ZRoi*ZIaQyX<)M}_t z8i{BMyA>8jhH#Wa7cp4N7(j^U7^1fJNGe33OCrWeM4^s>xg(Ms0Haw@{^U1JU4f{D zoSjjs5OOY$n0W?Zk7H2S6G<+`oe9T4>Wd@?V(Qy|r@R-1oFybYs+u2E(c&U+Rn1qR zMb%t^izYo?NT`}i?CEsLQ_UW2T18RKl_S;6{6lrjRN3nJ6VgRJm++gLq43chvXh=r zJ8`RV3Aq~IKO~e2)vunpsQS-4^>3{HMwI2h_Hda;`Hjin-MW__P)uIy%qt2G(GrWY z;1G_1c~&G99HKR1oPv<0IN^^C`qW!R zdp?G(r1#(}&<_msMbM)?pZD~x75&xi@RA>8Gj6|q*XdV@{;=q|+MPBr@Z!8g_)XxO zxqzz$MW$TL$E{bEDjNX6R5u;VVixX_bWJ5}c#~P!>9!th0|)$V96?}}?_M_0wSTn| zNt)A_34ca9)G3xtj{|6Aw!Q)%pymeFZjLpJ%a0l*clcY%S$DgS%e_v#Gm>7-8|9Rv zkRC2sk{_Zcy8dH8*8FRaI+^kMWpF&^@8g#|{AiTUBi~-9(=pmTre{GM?03};g} z@hFY2cp9G`mBzHUOyhXjJyrTf?7ny=X*33%2fEH(gN3f_s3L_!%k4^2?H?f*#cwAL zt5xNH_<(y zuq~en^Z}!L^O>wLGFM+J`ef)twf&H7VLdG%xpE7Ci4|`AmAjTTPU13a#9?c+cuSP` z;@J6Bd8WNW@#>f3uIR=m%hI+T%FZU;zJi|({MSzCaQ@4(F1vQrj^@x|ToKbir9ns{ zYH50w5qeh3GraLiBATgNIn_le5L23|GGgTgS@ONQ4ZB zff19R}J+DwRGjSvB6P`Iy39P@uxA3?p{b z;!#oksKvw)k{z|!Y@~S9;t}OjXCCnVw>)aGkT{S5Djc;~cStaka{?5IWiDBVk<0!O3UF=*~dgvmFNld zCSDF%5k9=`-OpG$C^$~!r-_|wozu!caZli+1Do>OSPGTOM6Ui<=qhmjGIEZ59Ddfr zrtqp_wiS`h$6#_e-HNpKQM98oUCjK&H!wFi^YLC1ud~foFyNTT95Ur0$4XdGdw(%! zC7dc-S62VI=Xea)m4+y#{LXDA#0;2@w@H3087tbr>6sC_)y2UUAt`j^hRt)NyGP`p!tWI=T(b>k`= zqALNVxvEGl0_5EWv__2VG0gf1=m4H!3}Dx8rzxd>iG*|n^acZCRYD^&N+}Arq81$u z6r8TYX!OfZ`2C+u_|H}A2=g*>5wGqyZ^Z-L|Y*ihIl1=ph7M+}Qw+UQ-h?!U0 z(ZneKdB^2z`He61nR=U!@9=KCZ*SDHPzerKa!Cbuc)AW!BAmz+>f$k7x1E2Y)-7b> z)Z0j@lT7I!*Lc|RzkSJP=s}vU^y?}EvG)^`T~~1o-Jmc#?vS@gZ=;Q&<}Q!W67bxQ z&>Zt;-4&)lyvj|imgoS9E)R)X*Ry$aD!kFtF{H8;QaFlm$t5!EQa9|*DB=J;wgc*) zBS~qP&5nU2%#L*!w?CiP`jtvFKm2R;czzDm8sLcEkN1q6$xr?puvyP4gS2m^8xwYo z!z|3LwIRoHbN}e{i*vI*k{n$(LR|x2PumbDo6X%t9MGZ?+wRkAa5IL*4xxrCCR^=oL-+Gui-3Ldo-!!cOb)K z{uYxhUqzHO;=|95HfuZrds$QQ*RA;{G+s~MLTdT~YyKkPy0$ugJl2*2@;Wk^e^|0K z^^lu0rSIxD>MM!*RCA^;AN4s9^>vTdH&*)21{d2e3$|P9$uN^G#S-~%P2IC+lb zI;wVnmf`@Uoshy*zi@Ylx1L4;k?od|V-OgQBnP6IkKgX@@qK=A%!?H66@r}SM_15e zpL|0Fy}7d>uBdHg+j&iiKk1cYvBae8aqwS8);Q)^20G4Sa zd!wU`0c(A#$mVE{L7*a%9Eh3wS4>i2*UL1%;Yv6-;%KjoF6=+5VT|q-IY9E)dc`NU zP;3VmTJFyg&i_R?l*-8RX{x&rEbTZXojX+*;WA$vrup`y_QPD=*tFlJze7ahZ42Wf z1Mm#Q}+41i1K&F_! zc&2oTM|rtqDh6^x+U%VWQxTv#mx^#pS72IMxW#g$$2ZN(`di$MFW?t9p6SsX7HE{; zJ=%>Ys@eT5ZhSn|kpCbWi`;kzU)0JUE?jiue>$$njSt$(jVFdI>G!;JamhU}QgV0F z%rSL^m)s>gKE{J8v7}_+lA)(Licu&@o`1%KH88)yU8JE<#KrD1DVU+(;4T8K_$6e8 zYtnz+T~68jcJ7igmAH!l+~sr%`mec5=aVE$K30Z&n!ETzk-J3KFLsyen2G?oi==|P z2rP0JJ-(^CbZv5XIe}jy)du+dgqLmj{W~5CR(o@t!7h3Q`$RChc&m*UE4zkhOC=Nv zar_e8qbZku-Kc4(=$Q@;RCa44uS+H%tkH{&`K|QV!?A@tL+=IHhg7xZrN-Yp_xT%n z#FfXb%VhOQrYmp8-!i#Rmp0xc!jRt3bNrU3>xcRMq^=O!eopU1xjMJ~w2+qc>Kv#Y zFG7T~t~_x`vvSM^vu>Jf=Mf$DJU!;c2)ak_7)FZYBFO;mc}fNKtn8}>guY;3T>ynJ zl0s7y6Cgen$OVas3UmQquo@`kD(~wYn(BOr9O)XH`iZ3H$2=8VIoWmgqy!{~kA3#Y zeM*w0I#6wys4?t{l>J`zIOteNHw`_&le#*UR9yDI-zVZ37RK{qHqv*9PQr01Ww+BO zi~jh4(|wWhDVv#1bNYUwZw_=B?t@RRc7=ENck`29Bf7TE*btt82kG6I6=_bpSLQBy zy@{-Mjl;rbHV`sw&Q`$Dw9gzJ%xX&Q@x#9N`?0LA5SEP$(qlPd$vn{#6hkNLKp%*AMmr?iuh~D*2{g*=Vl5v_#$a9Cmp^H%EA~XXp@Z#RVsedsA1r z{Nt=$=PyBCbeSKW@NQP3(Z5;rv!ScSsG_pKc3Z;E?y2kQx(W} z&j~LV{hSzBtFX$;m8U%X!$J*|@1;h#YZ>cfX7+`@;!y7-!?|+c?Ud=7C+^j0zntm^9 zOP5?hsQDNx5`~4*`rW^$lK}ze-h|QJkr16^aoXdxg!0z!;#=rLG{v+Ut~lq zgR+vK)+jre5$8_}V$)5nFWY~ga0bb9mF!W0E}uqt6F3w8oQUriF;_buc*OON6=e@i zLj6xeky`CTq4q%09}RRxDRHy%9k#Sqzk+41{7s_gYL5doqWN5&^4|-R9g@t|UIxw$ z5^=c^J)i3$WrrwV4r1F}?A1s-n$pOh5{QEkGg+UIHA2AJi$$Lr=-Z9%b(eMeS)x~o zo~!)?Ga)i#1|xbNk8Ik$umLPZvD&=MOL&PmbM>e2lfOUESBjpi{h>)goF?M6f!JRp ze76hlN7t6WD$v)t@I-J{8qZ4jUjlKUNcea-P=1+&&j@s_5R-Cm6h249`as-PBz%nv zzbN`afxg{^%eID;9}=-75QmF|tKlH!bNI;*Uh8GD(}mBE!f6pV1>#_l@V8v}A<@4p zI_D;U-8b$v(k8%hzlVaf2`rN!6Laz#LomtjdYRz1E((${fH<$ z^--VHx)Gq=-f0(}uCbrQ(*{flz zb}?-r^pf>!)gG>f41P1P<>)FQzbRyPD83l)lAA3*zvL%>$!JnaF=?*8ji3BHS9K{J zQPBy5CwRnJPcUMA18EfGMY5QlmAa8|HL(D z7%}?qoHSpg+eecUCv}N*^=Q&GPiv9VS}~gRRhN2JQePcSI?GAdigXqvrp~Ifl8bA2 z>+B)_VJ`;#>Xqu_8DS~y*ICx4w5cq``eb_>hH`6;7}qYo_NJI4n8`YXj( zZpOXxM&nj`qF)lz;D32e-MG<-Ry$uxd>aCv8#g-9K3WbX@+e!c`M$vCB{y2%R*Nj^ zzbU>2@MW@3z0tT=JqPED=~JVO8=Yvk^VNv&z)^{g=KHKCx`O~9|NPID=$n+tGFNu1 znC^l}b^m77b%66-D!%UrzBen8i|G_7kzox<7sD5NyU~_C910N5n?0i|i#f}Jjc-=FCp!O0D!||V%=7GdVRyaArG9Q(O7;7S z@8^N<&1&~48+z+Es%)-+?@ep>AWw9an9d2x+_=$+T8x#eKV5wFf$z-9&`D-K0_`d2< zR>QndTT;3D_Z2hGgIO$TXE}vc02@;71<0QuVy;&EMg{xoH;6JNh^Z1#xdvQ3;xK;$ z^s#}ia*Yw)nO+3#l7HrEX&(R3eV$xx)xCPIU(0j;9;baP(*AOf(fUNY#%cc=X%9K= zWYPZJX`hU=8=ZEfXcswcpGfQwwLdQ65nrN@A^(-v+mUcM-t66#WT@Zf{u`m8>Je^Ir zhnur6HJ;X-eW3Ak&Dmc!&idSE)0aN2@Ol?V<%l5H_%$L9RjQ5cN-7V%k*_X8teTkG zl~kPrir3qXsU*XsLAv#kO})5xCk`wkV5s=UCCLQ6wg(eRJ$d} z-zp54-6U+~*mg3b^^)qCatEOqgwB+J`N`=UP2+S!xmB2_1t`NfP-QAAy?h`j1Cc{O zEQ^n+EU;3Afe#s@=AtSC)cMh?{B1ujlX5v3Z<45i?kY8*LWEN@UK*T+aZG1wKs+d( z;hbAdgggizO2H4?AfHJ!pndEmhf<3PyRy!V$=jlofI`mGmd}uOQ)<$#q;*!RMjCEO zNkf&tG}yR?r9rPtNs;3odr5Gz>;g83#Qq)<3|jrHtcjG6h5R3Xq#R>{B3?r~P^J7( zETOnbT~(z~2Fs~h%BaCgM8kt|I#9*MVHWJYKBD;S+l_TXWOYEkfEy~8t9)G%$rexH zAp};XCb>WaswTiXhZhRK*Xn%R&7E)&xT_<#1632m*Jga=ug0l!tP0{|l}vBqtIBXL zC}>32^r*`LrHtFA#kVMGY;Yb*#Q^D=&8d6wv^&oV`yvZTP$DBdGzal?I1eAWjd~ow zqc7dO9o)#p!A*T;W{Wv=o{Un9-ygB{LC(o}}Qc|Xtk;dCpbWQb8p%YMQ_Rkl&Dl zi#v7uB4(Gww9HTZp(sk^N#ycCQ)f}Uuw5<9g3Y`IbdMMAn z0PlAVp0R9&r=VVr6J)aX>ytv+Rwv7Db*gvU^HMl<<=9=&;pRP1^j0?mS?|~?h#mE4 zl7K=fuZ&m$`R{x`lrriNS?xsALiL14)KhhoH5|*`iU=qf$CN*Ca41La`f0C96Drhd`2h!6 zTXaNn`TM-SA{~9x(PBe9eI2crfI;cZ(JNut?oI3K)cH?+S3xF_-Q2Kb8%P!={+d9g z3FBWiU`***aU@1#o7u?UDr)vDuQwiMr4|^0zr4>FN-S`aUt|>i@@8NtYhpW^SJXC6 zAo;Um`H+=Xli_dG3FLuN!N{t88QKOY-p_B^>-&??TWTB2qn5MiUpfig-M1ipid75uCl1rY}#M~^yvdpQb56s ztr6>dnBf?5v&~4DA;8V(cz-ZsyP=+a5qFH`MZvY01fqimQ11a)8wPkPLXwPMw_zNo zcwB&Y>$w1-gaMf0lIYqQNe;|b_rNiTh;?92`7@m7FiHu5mAwY>C)`*1${sBAdjobj zr32rh%KZW;?CWig3{L?de77)f_N}HZOo#j^Jzl%TupttR#$m3Tfnh!jQYsG2W=aIs z152?7`fwUy>@6QvC_xzD`B-Vhg5cxWu8naGl#y-fZ2Sxo!1znY(*$_#*7X~H0Eba#R3<& zAxtT7nLfi*`TJPS+(nL|#ThVreVjA+cPIHqchY&-1a&R1dDk+X2lJ4h?j|AmFvnWS zrg=!Gc}V4)eojW>CwinwtG?E!R+4}uV2oWlUN5W}yBffRG=7_D!kA>g0SplikdJkS zA>{%|Ccw-w%}8=UPGuyV)TLU93^1oU3JgR62Pn-Txk86aWXg&dVMh$fY!iu|b(~f} zXqd*ynKK87JRBhTK}Zw=E`*DQJkeBLwF89?WoN`nh?=F17=W5#15RGPS+08j!tp=HJoTQ!BQRVTZw_??Uij!{7x2@?dk3DuY& zZd)n2(&X)&QL&l)tmIWIE-!)PNq4 zV*U$|95&AalDIa2Nlr)Epp+^7AMv8|XE;^lK_?Sl*WiGqyAoD2s|6CCwl+q2biI}e z$BfL91{0-HeV#)`R6x3wCQs5;v=aOEPavuBit&`lV1V3lG$0*@`C9-}sF&bOM^EGF zQe6=>E{Z@p0;>h+)sfp}C%=RI<`2;as+OXNR>18u~z#HG_~{6;NTmzBSSfz(()d zw@F)4%>acmJ($7UBl89sB9|U?Ow1H{H4N#{wnYP?gEp?9IvT3$r0D+rczy*lDeuKQw^feTyR$ns`0uv*o3j~!bH4-LzO$npEakLaT0xz9z zz>#cgf!g6^7<1KDAe01XjeV_Z7ikYl^BVh96;S1xsHL@lgSx0779eo#1zdoblEh4| zv3ugKuLHjMP08txc|ywzVhy1>)};ChI5lhMTUo#bC|bI@KnP;290eR!^%tlC0=KS! z3(zP_H$cU{Y86E5pf&a2k%$fyL=BREZWoGz`=hmXd!i)`xYb(={Hj85bUTK#_T!SR zFNl}#QtMG|#{sHxFh~(5Ok;wrtJ0r#cT&rJ6S<{K6VSqx6R>HArOQ+Asp=DM? z?CRhvJKZYXL~*-~gT}PpF043Jw>+F0Ao4M(fD6#<7oEAfK(Lf?<6TbB0dLo0`J^zP zbAk@7J0Y-;c)*cRLxH+7xXF4umF^NclrBFDs#*%n6O?Td4;gGN5UK;=c~88pKnN@( z9&jYSpg;`}xJ3nAfMU+u3xstAOFIfUK}D7>FA&Vqk<#cZ5Td1_{8knSfdxwg4y#tX z`f6pXHRP?oAYqVV@V-L5YjiU&(10}{P8&H~1cmDg!UkC*5DK^doi_qKVfXVw4d9Ba z?E4g6tQ$m>LI+v{%^HM};NIpuGzA0H6r4l@h$IKp03ycy9^)MYX*iMuj5GjVoMv`f zx2VokVV31zR#b?Lf2?v|_ACF|FwDg%)iGT>IFCIsA?$TypHPf9a6%-I*47jv>G=m3~>WO4vZi(#0#I6!T+Mjio$GH8of z^f{1l8Md=t6FN!3&ll6)PQoAV*@j|6_DhPB$0SCY=j~E9+5Yi_so=FWjM4lUB zy?GkyG!?^B3VhVewX97I5ZDC=!<+JISc;A+ExaSS)rI8Dq~grZO(c1_g-&*-hn|s)fMXCyM}c-v#^?20Jy(&8fMXCC zh}PPyhLMGP28No=w;8>(Y^|R6qDr;-*#5j z6%%NQYMhLKV-RSKq)>{(CeRkK4j|xs2rP&s2f+A}Bjzj*8IJSV*{>^uIJSwvxhTpy z(E6Gs)*i7AkXS)rc_g_H&-VQHMXZw%a11G|jHJ-$JpZdB*2xGs27&%aYV#8I{I82x z2M};R1U5vH17Ifkf)ONdHcXnp4n#f&LSDBU@V@H`1@izMeEO~=rOcBtVd^id@y z1@rdEyn4hj2#9zf>ivsN;`M;gs#L!LbZpxVpl@(PQ8O6TxIWT!3`vDHyDC*-JTT`Y z^9Bo-W~*#@%Slw~+F3nt3<5i&fJ>s?F-Q%&O*f>5BTwioy!=aIkvf2+^P#jNk{ke2 z?HCqbO(`RjwY-FZ(ru?B3!N;3kmrUG$`hvhGl1UIG5G8D*y%Vx7h3H+bZIWm@EUm> zK&l2a^mZ0a>HA>IU;G3|ZI4}O+bPV&OtNyaR($B4=x?YgF3s3jw-RE8RBuC$#v z-{s?zFXtaL&4;8MQXL>6KV+sPWDK}G0bV;krIqpVGlOC3rjv$ zqz2(rLZ5R*YxF320WhpdZ8gryLw{cy*3H8RK=kH1*2IGr40j0W?J6oRtqG^?H!LFQ z%TT_4WG@jCj{&Nh(SVkX4D+`DO4FD%-#4Hl0*fLbJ6cZ5u(Y%qD8K8WJzDOkHhCJE zc*|j1tha#F;N3>VKx&O70mM{WO+_^-C?`%P7#Y3=kslY<+uifnAdJS{5L zVB?(BB)iLOLf>~GZ?>Y)W?jDNPeti6*olkH8GGF8c3doz>H}|oTfwudypm^a(`Qnvjly4rgdCcJ6KsFvN9Q_V!&}gp zNo~-Aeuc3OK$@4*-;Dmw=FkViTgBkow?T5&?Z(9OoJ6TGX)q;`_4J4}A3$uojhva3#);T-!h;$TNVf2RQwjw%&W2MI6f0)wdp^B#jH z7;OW8`J^5aI``)FYkI?`0wG?)s5T8x`#v;w2G)iC@8ZZnv_oYNdI%mTx#3?)YT^Eeei+Fz_T z@*>D8l-YONW4m#KY_$`f^gA8+nIR{@v=t^ccO4ah*}pbyU&Oiua|6d9uriVy0J9p5 zGOPxNc1IMf_P6YTAN$eWI44Fkb|Il^Kn)PM?FC$b&T68>&4@urS_9NFD>DH-0_pq}hY2T$ z=aP2k%sYvuGbmo>p+d0svB~K>1Ko!{aILpGVORu>uNsgkr~r)QAgMaLMk<-18S8BA z#k9 znqD{xGEzdA7>sFyTfSNCUPTeMx_s45{jL)0#N-JsaHx{6vV|Q%65(T@0X+iwfkOH4 zJ(3J(L9n0zReh#al&d;|(^0BT!4p7zU4N@WV$<7Z{5o!;A;HmWw)(ZM@ znQ!-bHZ6aQDjUSS#*cd-U4UlKgQW7xD;*V=0akMluJ8LBb*Ykzqp7>;@-MLhyWnrFmTJ0GpWfzv0E zwOJZ%s0fYjUf4B}-vNrY%`kLfD`Dd#jf=Cx9623e%CjJHdNDUd1_#JgoXjT0!oIq=icMIZr1* zK-+SYC20rfQ~F$7tGNLRI1aoqBoa;sJXN#WIgr|FdQiC102Df42kUq;PBcuXm>I?* z_qxdKKv>S);Mk@VRY76+Bf1A7w*yrtw3)V$_T|eho2XxBK(tiZ+!iGrsJdJ%I*txr zXZD&@F8bSedgE!jwep*AYekJrUD|XQ({n5Jfz&Jikwt~V$+#vxWVfaHI3^RoJu|bn zYN9u$Z)TQQg7+W2U~fZiN=-BL*O>M#Nll~Z`Hq+PnOHWZrW=-`!IL}8cDr;!rTBv% z5G1H$gPQ@i9md6BVZeG1zx_dxJ3BSxKsU+|w!J@yAOdMid>0vmVV3#3d|3>8N1?rIcI1#00j1sG%cj5T^TG5Svmhb-zw}+R7~r zGNkiOjGr{S_R_7H+&O!i58G@?wwf$e>HuoDIi|dO7cr5JGdlvEtwXO+S#LOh$;ed= zp28kLCDW1QFs4Ks+HE>#r)|*TeU;5saAxZ(RU{6OYK=2QfMh2bhGgm0;Pgja&N&g8 z9z_Ju=*quf79&9`Lc-JJk$#N0yM@0FuL2yW|WtX>^u9RSnsnDWmWFFAAsly!m9 zXcVS81uYw*76;%R2)tvX7DqtY8hKq^XwMP<79E8P!oO(fRlDobK|zz9%KCNBu*$)G zibal~hSEdZjio{K+U3y2*I~a^Z0wm0;@h$Gjr||JEhAkXo}zVJu(ZXL>1I zS}hAgH?hVwYK7(Wf4AkAmHgzNJa_cc%pEI@wnVf$pjiSNEJq|zog6kRRhb==%KxvJ zNHvLo>mHLD+Q`)p7J!CPF|q)3Gf(+T(FEnoqL2Y!8tND2i%@j`Wa-lry33lgw`Z~& zXJ)r99WGrwhnHF{)=}Iht`aQWJYmzQ`zzVOO!nTEJ&RLs_@C*fPs#u5Hm!nDEz^;$ zd4rbp+sXg(CGujD=%^SvpF{n{>2so=W46EkEOyhASH7dMn~n|6N*>e|HrZ_ldu|0L zKZcxShVU1LYT)wD9V%jac%Hzyq5Q2X(~=S-kOUNz0e|T-Me?;jUnLxqN;*3zP?eR| z`+caGL3wU&{rs6KvQDVbw4>|4TmNw{78QSb=tG6#5ACAybSj`Zdv}JnPsSU{e+jYPFvA5!QD6NOPDeD; z;j6`E6kUvZ?3!&+Y~v12D<2?}#^-^Gmd$8j{=lHTTrHG}(P~-@>p=He!(|vZy5?4n zY4ybf4U^~zlT}TsLjM*4CU?Si7#~(RKnndX838cs7!4Y`tJvR3Ix8xvcs{M%`RZ7` zp#R3d$9Q{vs~J5BPI`DZYW@t5n>u3M)y8n*VCV8(NfoXVAw4KIL1Q{DRwJt#4Ja<(ZIR>v%qwL> z=WFbzS;?-qjYni_C{3&MY6HLsn5uP)kO!l-Ng)ox)g_c|GZUZ-2$9tt^OMtbRWQ~B zY}>_#kUZ3{Mw|4YOFN^M9JF-8RNnBmV33Ey2>h9KAAe2@iyu2(G=`HL!WlLU>PxT? zP67cz$>l#+^lmOaBdMAxQ1`B2Tpn|5xgb5ND&}1P`PoW73XFafnF?`$Xvc3=S9%$b zz2{HX)ggnX366BYoJ(xU(tUg`;YXHH5lRb*Nm0TwT}-Kt6tS2tVUjDh(+}{8G4%#i z5=Zk@TAU2Nyc`LLIV?nlM^!{hjnsk@7h z7w<<;zx4HSN$*KOs>v5tlTx})%jvj~@}c0;0UUQxFzSVV1HiNx53Qp$GCKxRdnCCO z4ZtywTpX!_9;Iv9b$~Y85|bcmaFPR6oo;0Ib-s*DPoK_RyeCt4Yts1$?_W$W-9v7! z1(LG+)3J>Df{qs&BF62-1d$4^?O5{espAs@3jVW>EQz;(nC^PS7~H~9VqVdCPb10==Cn|eX+}X zAolMIj1z`7thI5){gFvr(y3}KT5nMgGJ`P)M+vh}5ClS$*m5hRFb)~LPqN?Km~?-i zfYAy-n8FBRJpH(5vg{gTK;=3fhc@sO#(&wA49r3lwQQAc()COELSZb?QdNz@ z7W$kDqJD)mMNvQZPbpsStjkzbuTne`yJzK9Mp%!%oV13T?T&W`NUAKxgC59fYj}}w z5_1G$x#W^6X6`zDpq%kUh^?rftz%x=EUg}_F3}21Ds?JhqyntB`cX6~9z~Pds8=+p zoqGjm+V{`jwb`Oc?@$y_(x_4?ijhQAD5MC6bn|m;0?7tN*ROjGm?`z^N;7rnTH-8nFmLEbvtS`V*fMz?Gc?} zz|G8LHOHauz1}bIKg-_3i|wtJy}#Vc-p1ULRB3wdgN@l&ZEah}<r+WWy>8d{* zt!|Mg*{E-=XoLL8$9%ehfsiGt!2 z=8$3=t-swAZ2ap!P!oNCy5e-te~Tyl`{Q0#neMRrGD(e;#-_IEM~IfBYKG=L3tM*A zb>rwd?1gk+oo6eIU+-e|?@MO^L&RO2_`(;Ac)o}kBfc^sdHNTPSR>*Qfmo2-HQ$Ku z6>)zNbF~R66{PF$;VfBx_)MeZNT!fz{k5Vz0%c@A#NFELHrAI|WokTaX7-Ne?CaW2 zj7v=I@^+i$S5B$gu6Zp^-(turzduZ8#GMJvTO8{lEHdxW7ul?}C`wdZi?FY@nHG)1 zCb+>#ov8tUrtXg*>#(t{2HCiDH<9>L#OpvT104vYm`bhBxF^N5JK$b=49shMem(a7 zefIGWUch(I)eqWI(4m*xFUF)@fdfo#?qtnE`^-K!CTp7Uj36r``*Z_XZEy_y4Pe-; zU|zrk+#e3VC%J4^Sae9@pwg86!_4gcy3eeP&E)+DS(d?PW*<>krnx|P0Rmc7F8D(O}T z*y!5T%wZ0Oad5@O9U$u~oMc6qT>dTwB<)rm5Vq@Pr4~xb`)prsA&R+9U6t76hl1JZij-;;_DoVVMBm5sse*lpR%S$% z*!EUGniz>k6Qc@#H8Co&Uq4cl?p~~S@%d?jeE+p^7J70ADIsmz*^0&l9xk}(dUDQd-0ARn%vLg`7gN!c{*C*62Ti!w zwoJ8PTAq5ntk7Q{syB?kp#vUT%Pim8MFW~Gz2txb7a#~KnVW?uo zN$OnH;bd^+N_EAnJqw&GSBUWc)qV3XuJ=smvB-+n8XqM(!yi=>YODJ;bx$&S2aE;J zu2KD%OLH1gn{ayD-2eZX_}Rnm#%6(z(jWH*M&W!yvc=kq1uNrI=3#iFv0)G*zF_^z>Nb(oVw4{3T^T`~Y zd(tB(oKE4d9Tw8sv>}g+JZOif!FU>s=jq79Dmq^}L{BwKVaArWwD^li#$f$jEO_=# z{%?Z9Dv#lgGp@zP#oyV_n}uW%j#6>+v#f%l);g??U|51+XLzKV zu!b7!G%7v-m1x2r!7q1w1VXj)`NYUimhc3BgkP*WfN^dGK+^RH1AwKgM^Y@K z=aEOUHw@Y;loz&5gpx^3;P0H&IQ}k7Rq}UUYQJ=rGgd$Sta+`m;Zv|x8XIm8Tcy~T z0u1f+q|5={R_7Uio6dnae(8OB59&x?*yB}at?pD~cbXSatIyLH4Ab_z)<*ew&TkG) zv2f1sOFUro*gJ0Idt;~SxpJT0&2CJW4&cw|dOW%E1OVSXxohe`^Tx-^ zc1$R&XDuBVldji24EEp0ppsr}%sVo5gJ>CPM+_Td%8cYbKh4UVzg11;CFlQ=o@0u> z13mSbG#`gjwdkK(M#_YeD;~VvJh7@33kdmsH5+uol$!=cv%8L6wow=z$XcR+Udi_l~V2~phHdp3|P4eDm>N!QC9K7+?!RZdfvC%Qn& z1XFjwn4$5ZN$~7#JkQeDL(=?(HrZ&70S2>#wq&FB5__bc5aur;D1w2Z1k57US<|Jw z%WR-DUAHaiT8ObjT{dUwz$8C!b-iq~HJ0(5w&Q}`Y5e5NXNKcgBjhWce7DGd%DjR6 z6(?^OdCMEgix!*mLqzU}%u35MoCX_NPx&Ye`753BDd3UAU}HsD48_l9ht9nJgLJsv zlQ=`AFF5YhQ`h57*)^#b$PeGtQx}k2xrM(oa+%bgsRN4Q2ieqZ-uPHqCb!CN1KlT(R0}kRhnV77M61$fKHN&RtVaNnB07-()!YHwVr^jg_)ZeramM^U z;2vYps=`EMF8GpJE}87cUxBa>=StfJ`x`}R8Xz14Y0|lf_oAA^hqkvsrK7gju{%qs zO9@M{m6rfM%)BqDU)ZUY2qDh>4_VQ9Lxm~!6C|VTQXHQwTTF!*T94U#rs{05+deeg zy99<=#TvuZ7}?g?qJQ1hLoL1}03G}d;Lsp2mJHxvz)l_L;{AtzN&a&Hhh7UZJ=aC_ z(Z~Uwt?Y4!^FP$YTvZ%=J$do?pn|Du$p-y_WAP(6%lT89FiEz|=o+|WlEOO78`bM} zK#cK0bcm$0ky7nmVbw{n(>eD&B_)^MV8(A1d+%Aa4&`=$C!54jHe>&T&#Un}hEU((gw9TRE{H?VGX!6R~Y{mn-GQ5Fs5gviBMt=pk!6V1YlLb%-+sO zu^FLNcA}7CUX_v+re<>#a$xrF;AO0Vca2kc<)#4k*E<7>q_#Rr(=R00+N1j|aIH2$ zG^{g#)EwYdBzb2dAI7d^)<-4>MwrmKHfq`snH-q?kXd*`#5%yczC*U?>z#yy8bE?( zvJAb`Ff2cN25H6HBC`W{mt|SZ_eYXTG5K-~r0tR908)z#1L=2>>o#uP`5R`WekTQ0k@1{pP{7W{D+l?ybWVr1Id-&g^loJX7*|Ntd%eztkHWN zKWPSRC8Ex*FFcnp6N7UVk52}YdLSRKyY7XQ=h2k#9$i2%PX|nLNB>2 zpCMXM;E>K8Uxo!4riAuLdaIGyF=wy!HL8Gqoy*9*CzbxxdzNHugQNzZaOei_y+qs!vE3FcwsG#2=L>e-Y$vHS9Ism5NjJDd1Qz#74?0ZskcB7m` zPO9hX<}6-HbQ7Ly(oQ!y=+pV4o9I#~{)Tk+R&%nz&ucWc=viTr=q>iL6OGGyYO|-x z#Ge+~Q>$u;YVCl>5UVv1f{?$qD9TjF-S}C>nU(u#YBDF4ZameDpw6`okcMr2s*NC2 ziKH7(6ES5L`gm%3<#E!xEhcnaKnx0zzwD2;+}M`xX33LMe;h0;)nT=9Lelvi?e}$` z?<)6kkBX@AvyG>=G@i!OfFo52JPq<= zr_}7%*I%?5BN^?e%JsExyV`y|xXy2X%xfxEQqsB1a)Vt3Kc5gW1~BCu^JHW93>yJx znY;)LyJ@TR;Mh$s+BuiAQyLRK#+Sa-_TgG77wMCKxVCF@Pn~fgFKw4m=GggJoUjh;JGHAdZ359!U;>DfpCpeds2#V=FarmaCUm(Xmg5 zNRfLFKQt|JX;D!M^iQxX*T11J+X`!my7}Bc!mTVPFlxY(_s{HlJmgU9K6F__>xc$U zFaQIWJEpvb&re%E9RZ~;^12ZDbPS}Gk>mgvWsf;A^Ad_Nliz7Q$7+zaohCpZ?V*tg zEVTKdpRzeLQoqKqt(d_$mF=O092_P_SQ?@fGOFf%tVb$I=XPc=%Dtw0-IYVb&e_5H>$0096^3JL|zx7=W`6Cfk<)y zj5`5}D~$wZYvgeNOa+*sZ?hd$rqPd^Q3b*xu%cX&QDX_%Sq1;X0ytRBA_Nd zIk9wO>4~{%!&3*ipLb$z+;lrw_+Jct94w?2^a|S2bn7tkptLZx_525izNa}c*XEyY z%HCjM(T*JQbVEKZ2AJ}hYb?&~v|xDXi5K`@PI|82Yq2y=Vg-XV%97rX8uV0Ych8EQ zIHhhCoyeSAYdnJtgIhWcEx%6Z%74NMpiK5zsz@)rJxWf@Fspatf)aZNe1MMw9uJs5 z@R+ia>uZ3JViBwVXDm*A3>=U7a(>Y{dz8+j-%=-PSud+Y=k$WkPU(CQoOJ$-Uv!p_ z(mDMtb()>$Nhi^DuycWQE)6=*be%str#SC*Z?E%U={&TcbFy?E5p=%Ob)Gp&=P_@u z^N#80{8&L}iF7^;PI|w>-?y69#OD!qI4b|bXK{}b4KY@fbceU-ggu_Cl++R zbTvBv2u^vwkzev&HA-jW+v~hUItj_8gtmE;boK_FUvix{{(W)Yb$|VB?EIK?5~~ND z9nyKM>GBBhdL}bw^pRp@7zm7Ki*bK&%FxrbmZ64GiJ$cLiT@P2qQno7&R?0X^|l`s z6UU9MM)Z!9450jWWzfV>Z+vh^J! zmj9)#I9oH{K3j8(P2*}D}ja)e>(y2aBIzHa`eCcYG-kCRx`*(zTTLxDH)wFLUhxvG;!Jp{JRi1El8~^u#Qx8OZ&0 zs!p4aT38)K+{{)!0ctZp7|Em&{?;76gB)7UG8kqxvz)wA7rZsf=6EYf0RVsJZ^jPo zaKz7Y3cGPtuCdt-kH*DW3s#ZYtgaYJQ4)VWqwC-{uY+?xPuYF- z@UR;^;yoYoqWzf2XNZh7bR17v{hiZl<^Fws^7SH)R{aYnUoP?oAye4j1vW0p*B>ga zW1RASQKZ}`?-u2$DJFBR)MRh=lymhvd7L_s|Fsj}CG#OFWi;OB#B~r|nZMC?u~d+r z9Aw2_v{t806|G%Lalrw!6}H7||8%NJKT1*LPxEB|kw!IQ?Gutc&M6y3ku{c&J4E@A zQ@#j%9SzSZmR^NZevb(w+TJIbKTj?z=_~vz?8oz6T}}Jb-R0l8kFIX+Cv0`Kxo%6+ zGn4)r{MW$qY)hO;??H~7W6Vbj+0xAI>z=PWK4Z+c3g4RazMB9G4GGAZ*;g`*E!COs zDeLZ0pSn23dCxZ z;`mF?e&AoqzaGv;ed(?7~rXUQ|CE$OnCt13&k zY1e$rrH1JNW366*&JT#?LhT=`+Rtp9(|Bg%S&e7!{ry{Iqdil{LVHuTCh5Hji}aLE zdcGo~>y~gCuvf8zz}BSaPQXlZHRYe#N7XWyvQ4vy-Igick|tLZvSY4Kda@GWsWM~@ z)=5ni@^Ov#ygs9Q%(czAahE689+O;qYT1nJn9Efx^Rv_EXIsjKE@7F0@g$SI**c1e zxHRqW8T>py?(bB0ucWg>M*5nQ?iJ}}E=|x$93@ot6>C7(3;&q#oEhRf#;$LT3w`bk zh?@hk70KNi>w;vZh(8EKb@W#i5uZmv{t8d-Xv1^l?iEZd{^k|G^U7Wkv8oNxsIIjFG!yihN?U z{(MjI50EnWFS{&WW@l0;kpB}Mne49o%`UpfR9dq2OO@V_Oiryh`;aB{4RPe^=bPLs z`72DW{&bUjj_iF&buaGD`teeFz;*J=?y*~7N!Q(;^vt)} zQTa{w%zK~Y_`R1p@(Pfd?(%=NpW21$H*(XcI$AF7yN>2c8^i=v0Hz+DCyOXBgj{Nt#oVeu%Cl&;72`O zhDA5E=uGLZ46$2>KsKt{)1^13m%d!uxMj@$(h!*Repc2m<&G75jdwF0XzU)dZVM;W zXw6pm6+CD@p`?;KmDHhw97IibPq~Mm#%$B_F+{Eu(o;N=*;(|)4+<>*;a0Jg3ooBy zCywS0LUMvD=}IPdFGd2J5G&H9TWIbZbPcS5QkkxPg;M24 zAz!f;6VDUq0|lx_%+x)a^qkDbl)A>=Gi;!t=T(R3BfvI#y{4`bC2k#|VyE1q(#+fk zX4XBB^!U(3rJbCcTzOJ%Oh5f^MW&ANA?dvtZJA@~9g^N}N^x>i3+eqf=~=8N9HjR& zaqwytjWuLs(uuh-A4;n?^F%GdRU~LVuToaeD@1bn*9}cyy&51rmlK=Kvgauc3;Qs# zF(K+B#eLIsx7c!x@ajO5-kipn;$TSH6br=jdq+2fYa&mK8HdwiK3g{o{R9pLZep_AAr*;0PnEovVnC7a0Z ztfcD}t(a3~v(k0!{w6)InD^pDw2ME`3^KXnDnFB(wxQYTZ)?)C(HQFQQWL2gmOE3W zUjqrp1$@|`euYt9PkO!pk|xz7Ep?A1y+_&ep`D^S5a^>lM?zj2mG*7UDMzxj#)`I8b%maV0@T|40jYrrCkRoW2m$h0i@Et zB8Kce>Jg~6aQ|zco>T{#(xta+BxpDH${zQ%q&H=P=3&~?mOG%XpPot}>N*7OUHztn z6k5`yJF~}KO3iObuB}L}Z7HMQ>u=2NOJCDJKU-m;#k1@WNq`~7gZoEMq0n>nd7||E zwTB39@;s1X)UE%F@E;6nCSL;KKxF0g?Z5FtF8BuJ#Gig@M4d2J)jKKM=^3m~tBASj#tycwHbesCo3Y*>nCq z5m$*wIf5#rTt8Qo%bao(naE^cHcLM&{69GUY{Nfi_;(9`s^j-$lzhnaF4Phn9xW2q zw?+&8K}@;&Z%OV0f!G#_H#+fR5nubDOD>2$kayx2L>vsnMUnVk6?m?`NyJToC=b1_ zP-4>|&lGu0AQKrY0{<+L)xuM%GGQI6%!JcLSq5c(-`?vB z-Q}14s;s0bw}6+{?8}sT+9sZ|Q~n900w_(SHQR1TdJb1F&+NXtd;&Zg2$<|!0Dhn1 zpSedfYCdwamLy)+c-oTmtd>M~?LCHk(Owmh^e!^w_{|`peZzk0mx+bj$3!!W)Cr)O z;Y4cM7*iiivxLxHyAhiRr_;IPu4u;qZH=R}Q2-Sz)lrq?m+WIDu{ zN^(uvJW=z#1F9`z8kQF9S_&#pQ{GGS_Y4zU9}i4^#*x9RVP%-TlOTIBAjvba_C6god-B*5;~t{rMff2XgVqB{kWb0tBH^WvN}=2=y@$c!u0g97J`4t z6cR4jB5olz{)j0gHm(4$)rsXyjQ%d29j0h?W;w1-?6h#A!!TNuuy8_v!U@e~F5LeO zs}p?|!x7Yt(>$O-OA@#{<3Kwv193)6(tEa9p+Ka^Hn5Ycmr&LF5I9OhTe|d> zrtIXtnRB1X)GbtgwPq`j{B9Gt4_A9X)jjQ6@_co2ZKcPE)2==#H;t8u1LkKxtvGR9 zWA>JNhE<6}dZnL@nfIs#)OMw*yj=Y!Xc75~-Y>YetU0uf!-QPm$nU`yNAoJ-TZA7O zdxM@AX?FQqkwR1Z{ilu1T3e~)CYZkZi>!Ty8Fv~cMvm7exEz!9r_8ttEWxam|-<{Fcg^cpO++Yrs^eY;Xv&~Wb>Z_zt{dvp+D7!(T1(b9?qoWpIBsU z);AeSKcdDx_MGtC`_Q2{^W0B@IucYS`&zSB5Pu97l+I`Bxi|SRT-iJeuuor)4awEz z;~=H?DSv{;OzAL9bIfIpxfy#{3}x%2MlD+nId4E^`3J5G2YYscn9l{J=aawVKO8Rv zj_SyvolGab=+vq|E8gr+YGM%AXM6hET-Q|lddD2oB*j+xu9&JKe z-WW*g;vnrG9@RZJXE%YV29x#OF?s=&#h0%o;pFOV6qeS4_`F9`ckOGxkd=N(!Is^r z4v5;wWX)&^+BKdvrL%syt`+A*$1UmHxC1h!uQU0SaN5e^7MRkx{eCT(OzH1umcE+K z`U_^#bN&2jCcDaRxJjl1E_`xhrgZzsxrw*%gtM-)bJR@VE}fa(#ESDnX}*X`c?^h| zH4CEM?Ud5Y+{8{Xua;15b}7T`CM}G$G-qGs__RE^`LI_twzGUbGdE@hGOWBHvpv(j zDm94M(m?_Ye|35~`)6G`?*N<5WlHxEzE2NWzg@p`Gb#W+4{u0+i=Lh}J8nMg4)Ilz zB-+uM$<3+QhaCJ+b>B+4*FVxpe2`Rc;s4!9^-KIbxL5mU)M?iMKby_cZa<&Qwb0%Z z{ZZNBvGWccVf2NjI(OjgM!wg=zN(^~7LAdtKXk(-kma=bfEkAMNlDKq0!T1(fEduT z0qeVUI^Y`v$u9<8+U`oYg%K3pe^5cu)qp|K5PgIeO-b+2SQO4> zy`F{0rtW#FW!rd4+u<2c<p)beP(84|EI zNn%8ySRtc{jE9!fbV9vnbbcb~$x(FzS^Yalwdg@heEwc5;96?1l1N82z8ds=I1W2XW_TRfy zJ9BSKv!(~S&d`h@zdZmnVWb?FZ?VL;6=MP^ZH0ZEVJ60+7D+`dM6&D|{-UF; zYfsX7X$3Hjp_9l@aJ<%P#=1!v#A`CV(pF-$k<`K1Whuwdr>=@52k3eofTX#BNvTse zDF+~}i6rMi$}y1oBS`??-16I}ilmd?8!2%spA}XMRybcW9EGEr;Yi8Th?SHyG$`g& zIgS0?6=lNz4h{O34$EDTn)-KJL9LBRIuPzJt`k<9d0KtzNv%TOxYtK+W6*^~VMt-O zr_cbX`xN@;>P?cX0c!!``CL~=#+5T;yEE#Qu${?w3}vznjD~nsqTma;#(Ro`cFl1N zhc->eFv{3ySi+@fnwXwUk@9Zz`(qjopn7}6IKWt}Y#8(JjKqBr2PlKV$m{^(k4KCH zh(B!@Ncl(-kaQkJcWG)L#~UA5+q8HP4`J{b>fbSB_UERgRRy1-vnjb=ZuPh{Dq)6CG>8HrmZ=j3lN%f zDQ9WSUAKeF97`va^sW=xz@DW7F^&m1i~dQ^+2k@q*T)3w2!U{=lith8mju#D&!_FW zu-uw^qzApfo8SrH&?ZJO_h$8I8XK*gk}lN#)ap43#S6BL<@Fb?A|V|38TIM}9=V{<$?B#xk{ z>4-CQ29*k|G)XbdDdRH zz4qFdXYc*&i?KGu)Hz`10nyKjSQnt6JBBnb6KV28_wvYTcpa|e7&x0ENp3PvI{>LA zlHBF^)B#B8NHTzn7f)(?>`*ErJZUaL+)i(5jM`qJTC7}v`3s5dO09ANyJC%i0>_n_ zi=H>ZxO&th=_skO_6ov~^-Eos)g_B=O^Gj<0AIjiYG;WW^sOo3psp`b0|ah^aBdZCvV29W`B$4KQsp=*5Nbk( zG9GGz>UVifcv#iiYr-`u{-G(Sy;ccVN6!*D%T4jXo|t0CQd%8@$u-erw;humfTT9T z(kk1{`3^vu7fFGqKVUl4*XE!F$hIvjgzKE0qYqpYy-ovQO+}IbUTN2x0?$h7r}OC~ z&nQqI1;U%N-^-t(T@*=f9#W2h)DTH7&K5Lb%FDPEEQwqWfLUf3yy5^!|DTk*$@CB7 zx0@_O4#qri0Nq~bLL+26R{EaM0d8@9fHhJoYgRBQ$L^ngSLSzN5Ji8=F=!o(q*(?8 zfo&1%00JGBG6Z%&N(R({4<&Aqz_PaY44t1);%*V>ZSTKp$C0`c(s@;*@7!oqfF_66MmN(uM=pe{| z%LTnhXNQ?NhO9dtNlLO6Xa^wO6iMzrGTZ>tvnSAC8i`B>G$$SY&Nva#(ob`vrn1A@ z%U!m!RbJWU!a(~SM+5wb8qNKa?U%$$C9O2lZ?{rmmIdqtvA+mkX#of_jt=^ne6 z-nutMQ-JZON}3{OJYw!PfHWI`%3Zb%)(j}MrIt!`@A4V|mp7|wQTInp20TNHdXBC9 zrPrZ8Mm;;(tX)x>VjJq|L)SsCgFYi+ndAi-(xFK5vWvl?5R>bXN=8L6X@hTOHL)qBl59MU8vfMd9Wt<| zyz^Vi=bkqK%J2Fcdzw9H-Z6{gEnYwkYS@oM)|h5Q&n>J6IE$a|v)DX11m>)CMVM-+ zIF#Bc7M=(7wDC1Wjrh|QS^`I)&jR5{1j6bUrO)@%4alEy_9bch48@V2>Z0%Qc#+2A`~;Kf6S#fKQ8CU{ z-rfzHb2s83Q&8$+I)*&#iX;cfUI!p;ilpDKJl&DxJV-ePsm+ljAo)|yT>)u@V&L-( z2}2{d#T9V z;l)F{+wQfc-{uNSucB2E>p=ONWeucc;1eoE_<&Vamso+C?A6y34o;h}vJ~GTmt01H zp|L!tJpkwZBl&}IjJv150n`TGp{A5Rq-;TK!N>m*Zhr@ndF$Q8UZ=}7j)AlxlIENH z=$$(T(#A+qGOQtT08&>Zxl1TL4nW!zNd{nAcoB39k7>J70qWT0YOG1!T%ua6yc|v` zS-ac_SeWDsEG3ARxYu#3i%R~U*nAU*6?ju1s8rmnE00`XDLPAuF$Nse{t`9lUsJ+C z9V}4;1a6yf>Vi9f8&qGc!m4l^$pJ_zhDHjBE_;vci&6$yma6Ppfjtc{_7e{ApVB^R z)L%ql@~PWswG>hllU#9>kclZc_Me1Y%p#uB9K`a?xGWkL%6}Z@Vsld@mD-meHqXX5^hNraxVrz zvXEJ2NA#z99H0&uu>p@oa_u)G9E=Up`&Ix2IqPliFs4 zUU3k0_{A_!%~84$^}&exXheN9qCOZ=AB|w>>qgLN+h=ieM5P;16OEvGlM!QM5BTD$ z`nW{ptLO5nDy+D1F(10#%?BR2y)F`0I`Qiwt_VaHIQjR>(S;`YX%XuJk#!SJe5VsP zi8wP5iPMRH;%fhwh`)TQ6sHq!b;;+8czqz2;@s%OM;jpS3B*#IKdU!`PKr1H5#P3x zX3f+8lJ-B$4}C9y%;A0(P#eMO<#{Gt>Mr|$9`&2wB5WG$V%w3w3@BgO2hR2R%6 ziZ38j9DBl(%EAv{&o$qP9~bc^5eq9;ld@-s{|(ar6_e*38*@N2Z^&FJZ}gk|(pnfv zt0nCt(!0s={{d^nzgPG*j=$LORu)&R6ut#K`eVsH;toGoq=gchmcB2$3HQi^=NMft z{*b=qPP|scQxh&ct^yfq#tBz`mFPD?FN?R;NuLtwKTMR8M@D=Zyl0LSk@)u4z%dXx zqG!%_@z;s?VQCI!ynKsBE;AF=d^pu;P*PoY)Z5>pOZ~NkcH;7MP09iyYB_ z+$$|>z9Hg6k53x#p^|topdlD=QyEibG~fk+xEG@8o(%XBnx}Z+LB&ys9MOPkH{ezg zyUKKrm&AhsKZZjdcv~6M7H2A~_)Z|cCaTAPmzFdH4{TQ)vm!?{;EHq11KNXD{LN#N z9{6BMJQ(n-5XTK=OlL&{#umACS3`^*xDw4%Ja81IVm@+21D@pu{JV&M8;B}GYp099 zR~(th5yg+C%>E`3{};qqg!Y!igZ(dsLk>K9l4-@+;Nq%^KS4nBUq3pTgga3_B?))D znrMz22VHX&?NEpIxfx%kQ7i5ioqeoAX{F|^l>a_!?TUpUDw~K5-G!x9?tu48^lyw# z-HgPYuD4ah_VRcOOINsYg%yiLe4R&n@Q;-WTkWz!d!C9f2^v|J;?Z3M2L|1urs{W( zD6PC>B5~{$M*N0|KMzDLt;vCxu`70nax74^9QF*Wh>dcoC|3tcDYj8p*eK%Q^w|E< ziE3Yqe^(aUOJZziiL$yZwok{{inLk9H$mZjx+J_$SLuyO^{YuYZnK3JN&m|Oie+vA zHSnNZ@1L`;3m{*i|5KmD+k)y8L_zgP6Tp$9*B_jUfL`WIgK;|t=O z9$|~}}l*g>S zWyPT&thOThq}S;`5q&fCGIu?p#oC1x7Vn>%sJ~AyMr2Bw>m~dqaTJ!Oyydb?-A$uV ze3j#m0*5$P3<{q(et8+bTlmMvEA+j0%KEXBstD^|$Q09g+p$SI-ikJBGW(nm9{7R6 zT5CJ|;cZ%s#O~Fblm6|_^(#;c5Bv?`mcj>E0XdS+vCc>Jli8?SL}#r>HB(Yw1a2w( zMFpDrgsvE85Eb^O&cO~sRsZ!*nsZ>ZHXnp7BWq61^*LXaXt9h&mXss-PGbnW{BDbYi^RQTdeh{nkmn)VxvYQMpkA# z=B{|eT*0c>TRnW#!no=y9zGPp1H;T)VO&`4fxqz6zl%7ts#}lz+`rO8?(sQ0Wm4Ik z9V>x*U}!G91#dr!ldi{@^{wl!P0u{<^$?WsU%gvTzJI%8N#?wmOeLtfaA}3sKyi)D zg5@TH_vCUGx3F1i#SW5~pZ&s5t7NUwks1pg`%K6fHJvT_xepI|L~ntIB~6;%WJ%lx zVPaG=YCDh7f1!3Yicbl+JnlkQtG6qK{X-Sd)^HS&phvoJj5YVdh&b^>1Hv{dX7Bf zi|5M4oNTc^wO+ocZsEvTn>Y?D&YF{dJ~pPke?GI~zZq59+qI`t+Yt`}v}&ul9q_{z z@&2D_ikRDq8dm1#e{E&;%hs&`D#vZ6NEOFQv*lEWp(&usYoCTQfKt>6ko138 zGlvv@#<6V%Zq%}|a{|bF_Gz27rHUl|2Mo(9M|Le5sKw>|e-S`}q*aEh`6kTyn=47a2>0I4gI0?+<{=}^7fZ)b}q z^}r$A?du7vatx&YNOJKt z5dk{kfD%{7-Ddfo0ky*8a>o^T8C#Lh_C1mI~NhC>%7v2-vJ9YFUk!$2B}B*)-) zj|9@eNOIlemSZ3tf~2bf?0LmSlxAB!b z-b?S}c%Mz9D;rN-b{F?cB>i6}B|86MU>G2yqcLtV3@ef~BdwBNy)yq2)ydvJ(JCU< zTWdM^kdAFgdG;1Q=F{FA=Bsl

Wdc*=${qgnMMg!4 zV;TkSbgUS90ywsvU8SY(bGR){tGS_>m0FxW$(Oi|w8i{1WoBx_JA0(NlI$*yG#y)Q zXJPh8ciH#-_%@cNDGxRqp zicjexY=vqRx?%|-OSFPxue1;)H|gyHx5 z*HXg6gi-5@vy+9pY<*0!(9cfS{Pv(TuzmudnE93Z5yX~y7~}ZeTa^kY>$pPXhk>nudFjF+xk{Nhc|O!#X|PV6;Ix0-R!w9 z(94_g{PhrOAh3Vtu#-OEBHYK%EQgr0ph&=rgkpCqlL!^4rkuOtoA&x5kXCT%={M$0(Js4g5d?3z? zb0xi=x|ND+b0C&>K|fBC&{8krpOxYaGm&?? z6&Igdimp*&-2qfhz2(hWJL#NRGbVa0P{i*8kZ6u)QqrQeKtel6y& z2#KdOJF+lRMnoA1l+rhcv)$wui1^_^tcwO*nVl zxki+ii!zy>cR?f#mx=VOQe1@>bY?V_dYk@Rkb3pR+RSv`ep(wGwUF zGp$MMv1IR)wy~xqwSnC<^xoHVZ-6=}Y?gYM;cIv6<0sg>^1F1F2II-rB>kgwVbONT zxN#Mqsj?4blGX=WkKA`wo4}T$PUBl;srilV>dE9r)30vP2Q6Ml#WyJZKso}YTc3q) zz+)_M(cxmP1)ni*7VP@$^R__K?4?Yx(^X;gDAOA%_8zIcuDaH6$>b>cO%cQMY< z;f&JSo*S{I{DfW+yb+;S9qJHwOR9qtNv?9cbygMIZYqY^k<*})u{iLm;>k4Ih>qNI zmg{0W{CDI8NixA*`5L2oEKS(Xy^!p{ZQ=FXNxvuA`Y>nNGWE!cNCCR;6vndgFWqPHD>&HgGZqV+Yi( zO3k{cU^fntBbf1!}(-T0f^I9dfQx0?P5 z^jp*p5VbTK=`W?hsem> z+2;UntCFt$QPP36%ExVCxd$=K5}EtM=JcAqE*7*>Rg{WdzIUZwm;A6kZ1vAA$~h2| z`k!L>knL$PBu%{}I2PXk=~*q0a4%4#2uSLmg75@+g1*{AwowDILw2M&1EPq5#DtYJ zMgUAIVjNgIVJetGb3O-ZH)jcwP-fVbU&Jr*;4~8cit!YYgXQK(HmQ(F~1M*r`EHmyRz}|9@rfc3qn~ zk3o0?{1#~)Ky#t_j9JRkYk~`};hkS?3OQh?wNUwwr8jlO2*IA#+ygDSAIjusk!Js+p*e6(EJ*g4 z;^lvm&W$sT`yZ6hG$|SlMmIraY%@&IRuc7IT@7Lrna#v)_A#=(DcO1#!+ZulN)bc2 zqwwml`4C~dw_}7SrBXX=H*3TsrHXn7IP^4;eKr_|UQf7T%kWI7yWrBcCC=4aWf z#fq8NI9% z7^XaHEwrTQKQY^aA_c6w(jjNUIjUHc1UNCKy(|eE#PVt{n_@}B;`1-fbT>ZV{P^#h z3oXyCXuLKV_-lGnT;ZXC9%on(&;)9`-EP@VXz}p*te-?Ylk+u78SaN-1gRpZf$Tw^ z&EMq*xjp80_=b(hQZJs#mxgtr#Zf>E*~Wuypt7k(AjwcdGlkSA>4nkS4$xUphxk+HV&2-P0JfAg;j2}g)3BdP$;QzZxFs6JY1D~X+&B7?jiCQ z7G5E+_tEr4D`RFcW4Ga|Y+i>tzm#`bBmJ8HT7Ii6plHs~iJqJdzxcRj-gS z^3FFEGtAk@Fj0(UVrrz= z;~06#bv`>?!ErieTK7Z|2hir6i0q3b2e?_f<@`g|Rwdb&G82VgtrC!nRtYdxl|cSh z1z`K+)^m7LUsWAj7*uR#Fp{k$z@4bc)@orJdwnfs|C7oh8i5Y5N&l_Htx%^z1OG}$ zN#8(7s|RX~=Zyi|RgN8~j#jI_npX}+%$$fh6fsW1PmUqc!;v&EG9Qf?C&BC(n2$%& z{K$M$#5f6N$G|)iNe0lfs!UCOU&_o}&v1+zeOkBtfH%Z-mFX?VDl_NvsV&KN(3io9 z*4p9g-6U7{C+@SSH;pa$UQJ(Ve$g~tQ_)s2)>cu}Qr`L`yFq;)-e(*a)MaPTPjXyU_VsnRSoigA}#_k0+p3!zoC2_OfNa|h|=qlck z{wAky5dF*u(Q%MxM~vpRrD*IWP+0NAb6`6O8+J5t1KQRLm{7)%o$4iw{hZB1G-S(E z>+(+MhR`&25rhm-$Ng8?t()YE&I;`qTf}FHjAFdMUv)~ap|;$eI_+RLAZH90^v|2!P0^#LCyJggf~ zTkJK{k!xWdWZ@sxC2D%P{hDn}PYx{#G8%g%4^0#)YD8xwe9COBS<{q8@Xs z%vrfPDFlk>%oLV zRgtz;O`tC0Ae;2(IqRA+LHhBhxdpe9#-jD{A0=DwH#4vQJ}#y|yYh+R6*rTw*l|xbaBtq)YUK+pLY? z?dh;6LT@wN#-OvN>bWa@0mF@NQ}IF%Cm7eKX=4kOpUYGfnT1RjmU9w%%hiyVe8T$b zi-!j_fMjOtc&3rrH+Jgup%QfwSnID$BlSZ{2DY$=IjO%<{%3lK4loBn(z_w%;gFIyi!U8+yFCtIJbWl!0%`tm4YK)*o(&5QQS0i zD4d-%L0v0C(@~0b$EqIP=v7Vk-3x7fyA$B_CXkM|6)In8wJkZ9vqM0r$6eP#e@^VA zc)?GXhMLxc7&S?AXjNZs_G);2%UM#90yp;(sw5SzAww%uSpI2li|~2y!V;Ys{BP;P ztjl#BVv}ljsBfN+r=k}fpuQ<8%i?iJ$-o;}?^Rykgf;RbQPKhOaw1{^uqR+b&FD2U zHNyb}dMzsIn*$+ZPe(NdOqNxTxn@t?Zs@gmhUq}71CRs8>swD$=0K=#^e;;FO|T_s zmIHg@d^nQ?hM{Z+5~m6n28$ga4Ra#KfslrI5$ixKz@CIq-R4Ig2SRnLi`bA1&!$ww zIvJB3g8}uCl8; zRo#JQz;6t26Y$vvhxrTU^DJmH8uN%1hCecl%?(bts^qVwsyEf+!Rip~^WYsp;h+a^ z3&9;8{9*_;xbkfwxQyW23N1@2(uK+^q`S`PLxEnepiQ&+j=Q&(ea1@1H>hy>4lVv5q%{@eY=u_zO(45>y*RF6kLq>`QEq9 z=LN;bB?vxQr+eg;==4IalcjfR8pEWq%P5~TeWrq-&yWaK3v{Y1P20RIA57&JD;`+h z1+1i&xlTQI%okSu%nKRz!K5;A7%elH9-tR|$mZ#kOr=DLV1N@3Vn(~7Z=zZbdK8@=#1jS(g)o?J%T*0WIR?&6ktC%Sjbk8ngW;Guv}ev= zl1loQ3L-Jp@|-Uvt+CjayN;&QnZ`ACff`jgs&yJMItH~Zk>mggQ$(gH4ZvWOgpm_k zd{(KM72Vd6HhKoSGP4~rWyZu%Ews_w4S=LlVu^8#5~J+Nj?nW`h3ZiW;$+4SOAp5w z5v5JhMSL>wU_e=`3u|Z6KM_#Y@)~MjLUSM##SI$nNyBb5n01O!=UQ|y45+0Bj-**` ztg2)cAj$r*Oo3j*tP$0YiC@(tCa^or(mZR+s4*=BnB>v>C+YQFt$wIsEAu%z6Jrz# zd}^u)sYw`nEz?db7vE;r2>4m&U$PC5D@LEJm{ENDFiY?k-^NhKUh(u(~>agC4)*hTm1|HMwl(*qn+Jx|?`GilRM3YVSzQ8oK z7h~1%rnxA4m;ebnYTol;ajjyfDL4p;fnm}sRWy0Ul@N|qUHCpSSES32YS>;jS(GWT zi67$1#g84Us)OybFMzF3_1A3F&E$SXqp=g}XDPjE1a|;~l0XmY0Ji}$i9e&bp3x}+ zc5^lUX?+9J2%8*7KfU-iz$ZIrf(}$-~a(xbEt( zwip&xe3T+q{0Xm#w%kwJa!*;2^p#<@hm!ruVmJgthBYq@Z93Qb`nbhsv9?(jR=id$ zpNBTdxYR=rpNMyBYz}Ux_oWqJgc}R|Al9Kkp#D665Q-_q` zr!x6Psj=rUva{%b>wsf~r!Wx-1X<#?;-eBffEYUO`Atb@hv~dr#2wPfQs#kI&@eFY zOZr|f0GDWq+(o$Cc%KF+Zj>V0r<%)tXd=JSH+6|r1`*bfEnOEyv=_D5=yBgZJ?<*S zJ>Q8H<0Zp9u|?8QJj2JmQYowY@>(x46f&jI3z>?#mAwDH`rU`7?^qGDYhj=K6H3{m z($3PaTlA#iuv(Y&K5nZ7!ihlB8-%ervKP;2q2Cflf99EYDw*#2>3}8;T0X;q#lgy(-yzy)D!uTy&E%!= zQ4RVQlRiFbNi!d-A0N>-+uh;=dt6Umn0PuYPT;9`pz>xkFf~ZD;MPiLnHkB{y4 zTf!qel`AS(VrmLPO0^O*kFY-3?+f&FP{OFsvdQek%#43Jt7Q1|G9N|n26pt*0Rnp@{htt|+aFpRUd z(NLC2Rdw_dtV`t_>{Rj0qe_yV;atn*2>I7v}x&eH;3t}ALfQx zEm=_NG#smVfFW*M?x(!<(z(i1Tkh@*-{Vwt77s7HIWu#=RT$H{o)}oBlHt>~$}2cJ zlbM;jth8ok4ut}FaYbmhS~%@Jefg8B0Lj3=xo40lWM^M{$;K4PIR5t=Iv-edy&u7S%i-G<>8xy=T5@tYC68W%Em(}PXX zABN}!0gqG6?~Z|2mBqwS&Sa4X!S_cI128wErHnO+=~HV#;O#Pz+4IQi0P{*thonkn z5jy~8C}JE47VnH$2PhaN19wG|E5$~~plf#|8KC*UUU`nv3{g#^LTNWr&4yXx07e>v zIQK`A17Hpsh5?NOj9LykPXyR<6%6!`CTRBN&Bi*z#*Ea_C}n{1e2YyIoX;|u>~}T! zoV#5&;5H<^8MOn{qG|?O_UXEnK^JOOjJ+hJ2{lcKeOaip6o3p!T3;(3z+hAX`L*ga zwSr|oPp@Oz&E`Klk16(PNAb1jhQ3M!g3}SX}3V#u1Y+MxQRp zHPBcV!Iq6h_~MpccYCOym#v`XJ2TdxZXfq>k>=9P)GM|TD*oUba>LS-qA1nYQF*?c z@)f7Na*9l!WCozv$#%Y8>ymWtK5vs-b5A#~(yb-kuat|f=s;s8KcIwU@}HB3(z$H$ zE_E8OXcsb9*i9&t+kQ~UTy~$+>OIusp*jzBduX1A(sx=6H6GgF zv}zCSaM}zHbvkW=gcHM{)5bm2=^=R+T9b!HJ=EcHCq2~XH02JQ?M^%Hp&q9Vd#J-h zs$6g`^N{K#p|s1XMic6G+D;EOIc_}Td1!}o_IPOAXcu;)aL@=Bb^-P| zxFM6jkeRQ)r&47noUt>L%MOd0J8;|{*?Q+~hv%g8(Ba9BIM@VO=L`*i#~oV_IP73u zI)B+bg7aW%&99`Rc6h|~9)tl5U4!gC2bJnBzTWNlu{CGm%jzbflO5TE&}AeelKkOO z0-S2T_0ycPPb0eJ@J>;+SS9yc@>slWx!<)h+&PxrO@IQV)_=jxujXR7+fu=u98CX}Nu~=>-`O=X~ zpO-(N$aHk@n^Vxv-!5~Lt%GxHz9BpG3XqN4iy%K<&A2_gQi%KkS)Oh@&@JZvcN*@n z#jm8l{*R5P$9Nv++BSu=w_Umt!FeG0%slg(CuIumBKFXq#0$?#SNx7wUAFpe+wSa7 zdJQcF+5x6t8*lx{9s1-kOz}pU%)%iI5)~}$Q-s&7KY_{Hf2Hc2`1SUf`1)r(WNo=u*OQoG9BoR-1kuOnT*f z$JShFA}z@p#}L=JQ);iQ6Ohzo{n_D)P*@-E#+a-=sz??EoYU5XaBa3B;O(gl`P}KG z|9#vbgW|#zVq({rWS1b2aQOoV#j>SsbwOc8uskRV;leTx+mn=@{4M9R-XW>umb@mB z$*(I-PRTP2$xAz>_R5x^!Ji#YfFTp`9+R?Vb=G66EmQ`YKWnoyJY4lx^(ro_ZxOHK zY76aw*Y⋘o5A6;cE-4oSyY(N5p5>1iU@vvd^B@uqdt1z+a~4+nWDOjf!z0+raE- zCU<2$Wwtf{%~4g1LZOC3H0coSq<*yKzdH^xQz(p&ojKE>zI8#=zO+;&`fKxbJyguNxSn<}>0LwHtq-?c@7@0-Zy{n(L2GRs!E-Hxr&SHthr;R4 z+TQJ%-zt^Af;}{Ht&Q3+nB5Q<{R!hn9XH=Umn&h6@pGpcSWu{siFspS_9x8!Pl)+y z8PRwm>Hk4g|H+ATqYnShb_EH4*7jz1pGG3Pm~jfplMgcMe$EVHvh{`qD7pN!y3@(P zodhzCSIG-W|F1>y%4DCxA;@7Qw(=8-V^fI3pTyB_X}t|GOF~wv7G&ZJHb*RH|UYKPR{$2`k!ZVSMLLp$sOo&dbiW9vqX9Jka}6j_7GCd zq-Sz0(|FjuQoDT{Xbih@16&l%t9B6PS=h-l>A#UoB0|NIE*y}pnf%pO+jTMbVL6W( zG#VD=4jf7}H|(`CLRKqfn-C73=HngBlDA&WgF>L8lP~p+B4>3{zUjp`ncSVq2S&0g zrMclV2S%hhmpzCHnZkkbpHUhPsG&J?VAy_-+ix|$($VMst=c))8gC0XUm{AsQ!EyW z!_^+OrHe$@;T4yDjkA^8$w3hgH&xpX01&Z~S6o_pWr_+PSt|vH1)O*OfGH z6&0M)^!b53LVM%4-&QQPF`;eE-(ByLZ{3fyuVk&a=a^*QCWe4V!T+GV0Z_e?= z3Qr3mS7Bg1@|Y*LyB8%o6jCN%%L@vZ`;(Vl@r*U=XAT6PUcJ+JJFgX&77a%2PGE ze?e$h!yip3*by3gLnrhJEL@xI40wOi zx`wbnS09mV7r3PVJ@d3qy2d1#$)vM=&BMtWj|ZmlAn4E9?8y-J=UP)DWfR~h3zRZ& zf((>mqa^P>?BUwOMbof0>(AQkNYH3cP2Bw#=ZR^#d*flXm291Vk+l|E|qGKuARbS!dZjM=Pq-V5TUK^g~H4nSjjvB2a>(AQk@xW`(|GC$S ze?`Ca|IcRND;H075an1UC$<8y?yEH*qho_Hy&o7>wRFc$x&f>KC?+R z$4$f9tUoC(L8CuwD{oJ-PkHrM_b2JU$Sz3BsuzOV|BuyQT?iRVG3U zp{V|H%4GGIL&~fFs2madT2%k9&eB<}IA(QLq-V5TUb{DV!d#8lJnUX88m%Mi&)V#% zz-!O{xz~yxxFsmI>8nB)K z+RnRG2RYFdp#JYuQ;<|2L*zZJtfVm>oyHVAi$@U-}DwCmU4?Il$ zXS}Xj?oZ~uLfD_Hua&BK$R_=Nt0>@pZ5q~Q{aKsc88rH{w(`fJJvjfcMkq<|7c|UZ6EePfYBpDsY;BlDKddp^ zY2r`W5yXen1UMkc2F|C*7|QVmVr$7Ue!S{9&`P%N<*cj1oPsinId^@}wLf_1 zq`Bt6h#tACYd|)0wnkz38`ConcZwx1gv-ddRTMjfj) z^E1cQ&CiWbeqW_HH&s*1Yh^ulcRb2*rc3#x94x4k!BMJ!o6QK*OUo(zcgU!QC3d#|Hyyq|DND~fBql&zvRiU z*?ANNwV+A=S^_QZO6~5-KF^3(9W>$*aw>no@{KPMuj7?R4s;pmmzYgqRF*P_*Wq=g z+erVU6y>cNPyyNvcR7dd@ZDq?0dxP4&HV?`<~mbjMgMAzHYr8N&CLfwVVZ#yo*gyh z;p4DS-k*i%n*dul<_#NRY0e$vgfgox?)6@|yX5azdU+rIZ~fgD{O!-_{(jKP`-IB7 z*-T622AfgJeA%|eKOpg(N04RP7EYgUpN5j`@9xud@2R%j(`~uOZ3)nS!FmwZiu_^w z`p4)-dh!PvNEL1LGSQAT9`;X(4agT4d`1oFUz~hT^P1-OHm_~|v-kdBT2p=Poz~Re zd>2ja$H|gXb?NP-zeq7{soEOIvA5b8NVcm|Jak3eubvRKj;cpOTl1CfyZA~yL%g- zFc0iN!&DEv>Na!W1bT{ZM?u;85&SQH;(w5nBFI05ro~_M_`fajnrZQun(*G8$m9P( z;!ejrK#BUw={q#$M_}}UAD>N;BJ0qg7qEQM4OA3Pj<9njF%HuzY{M6Ln;pRUn z_g!2PpY*>Zi2tC@Tc95Oe*8OJ!MCNLrlcUoZw)Bh71nD>c-}fHQ`7$+F8(oz-@5hp z(?8 zk|6!}QhG?gLet_uiKO~<>@Y6YloU))|28ju`;ecS{)b%rI}*RO@cZeP1o2Bs-~x&Ql+pPK$wPydT~6fZ7`Po`fI#J|J+uh6vkt6jkza$rqK zL5x4<|64tNwO>=y|8f`qg2Zp_|NZoLd;DMU@~_ae_;=r6{{IIa#leySkN?}tc?o`J z1wYov{{>})ta{gf!TJ}lQXuzHKIojkgjy(;6~De6TC3BFPP-6xqungpc~0Bmv@K{f z+CPa_3vF7I58q-@euhF?d^m4WcDd+`e+{Cq`Vq9-ofe`z5zV=u?eWF$l*xswWq$B4 zrnXHb8*fOa$-rcm_$+wGq4rD4s z2N^==!tz9_mnt9d;|vW<(k=7Lw}GXd=jGz5aVzFO~HwBDX-st9_8C z74uJ13NhsaD!X5CCE~)AGJ7{V(@HV*x~d6MJ?YWA{B4sG!#Zh+;#LrF?8l&35vdSM zlk4bFMEUJCQ&f$@fI$nDs(J9SEdBmF$sxU>QFL+4p*rQz<9(KFbsu7~4|)z&hRryD&_*6=8vABe|eGxB~XzDdNFdi1K(D6m5FsxO)1I+4#@Vd?hlcJhQ<_j4IP z>SQ7bU{Y8~Fkk6V$&p>6mVV`NrS}LBI z!-Vr!XgRD_9*VPA{G^sVUR(SnPewCh(UM2e_|WD$Lo&@PocQ?k?=5n?Ay?=?K+7EO z#ZO6L7UMw1JI6t?j;@CXaoWnR*_T%`cbD%Ol@Zk}%s4EHW=jyvjWC_S;zWtZp@k?i2*Z?0hJn~~ST>S=WwRDE&Hd?2mYMzYFe?CZ*-B_(y`Q3Gb*shR%m$Qf zwP@?yWLxIfAVl5`%w=~Fa&Kyx-!`Y2Tk<`&5P8~aKSib0ehcKl^S8^;Wb17VzcnlJ zZj!)44PWW^H|FAkl8|mJG>Nf)so@Tr30mp*Gy+V1q>VVP0L%Q^NUbbj*Hr$1>`Tx5 zmaT2hAFd-rXTitIe3psp{fgiTX6>nujRSGH-<`}AZ2cA!0yK8@aK(=_aG&#~vuu`D zdutYa4w&cM&*+JNtF}5~#i#ta^ppNP?-M+|zrv^6r2j=E-PWd@3!s@%R<`j?M>FQ9 zf>GgF@Tafu8;7R#eJoUCjmPS&!pIaJahdRB9ysW*XS40@S^WbsP6S2?#ua{*4_et+ zeK#5lrco>WPK#4Z;7mkI;0%L~Cg*4EmHHAeKrHyvT`&iM-~wA)r?65s-xU=?ID2n!fu5F9)-e7|DKrM9uuc+6 zp@}MmhC$c7pv#_OO@Xjwf?*+K)?-=yL*#3(tdEMs2ByO?c%sD>RrRqPTShimc(vmt zy2u#{{#+9n_^@X9+QJg2XZ_g`@!918Z%?`HGn1?QzQ{C0Y@`YWTS=4K-i{ks$){B_ ztf4t*q3v2!!e!hmb;_5y)8G<{0=sqW$%WoUHsbz#h=S|@+f}y_@sSWe^R)zoz&3xP+Y7Xqys4K zytT_j+C}KhzTHH1X5X;=_SkQq{c0ORCf{d!6Y>@T?SRt9k{(W7eDHNsBBO;KMnH>^ zw>-H#8K|I&^Fq(w#!EqoV^*EkvK^(Bm+eyu$CtJtG-{>*q;(SN8mRoan z3Tw`e2Mgbx)STTtkbA_&w-izH79u0`4r889FDK2@`MdBkic;|-m#H5#Wu8tmX|It! zzEKREV~R&7yJhOv-w?Wf@4iv}pG&8Y2lEB%loXbJ;Amicju>~qi1d}$svGxn>pMP# zrecrq-bzEh{hA|)<{H^ghKgnM~7jjdMM9JzRHw+_;qAQ-(jUah@NG=RciC)=ty30WuaZRD6TZ zm5y9Q#T1~uxtBJ$LU|>MNmgKI5M@ zzpMF@a5+jfUwya-g%yLg=T+Nzt>&@mSOt@}h(PkM z-?udell_m+C2#LmHRlg+y{pq9Y4%^)qNGR%i#s4U} z`O~A@ySWq{2ckb+9$oMB=xXv+-Qe)SZdozGcT7KVo!6h<7{2r@>HXaK_C~CFYJt5- zID3R910JWd3o&AlP}5>02f#eyn5rtGGNlud#VPEnbPT+wjkL%CbzA+s2idg~6H9h! zgAswM_eP88|9Z4e!6L_?Q|p|~A_u^*dcdUrGD>Tyu(3D=iyQ+lOAaAnkpQ=-=$2Gf znmGGwOXmAR4*cSPt-mknDjg)rWu!4aIkNcTf2>gKr8_=+QK;FY)u8}URND%$DFs%S z4C?vOml&f!qmliS68WkIqT#UtfWORC_-D@Jtmq8Df3;cb{5u1JV*V#nf%dm{Is$fVOl@DdX)_!f${>}8A%Qh-TH`epuD_pFcQ%TXeo45Z~>!^ZrDJ% zNVXmZx%dH&j%`Z*`P#+9E$1(IHkVN)R}Md?$Z@-k>r+i4Jm=aZ`x!WO0ChD|?d`x= zz06OfCPS)|t@8u2tA(>N$Yu(On_jCD<41D<3GV%_9 z*&H$R9H9IgV4d*(cr!`_C?36$&jB4GX&6X-krY~n{%9t<-6P2Xm>Pv%?=&eNNIuBa=nXcrS}6YD0DB@Ho@E3ECxR#WXm#CzVFRKaQ#)W_M^Oo zfVzs$20B*t9A%{RU4B$A@vtn?a4bp#k9iub+tErw_7Ek66d>btuiE3)=DDhmB8-y$lp{jXdc>*yDF@d2 z@tPBko&5%r;S>Q!;ONs(XkV{qP<$>s+4SZzUPv?eDo>ffKLEVQ)?3R=8K^V@zI0%% zH|o`fMS%d=RbkVGs&n>{MuPREp?JY2j_7%f{Afq?4E%Dm^rJw3N$(v^bcv{^1T>}eRU1HZB%9h5waDjGvmi>@ zJ^oYT;uI4dNFv1SZ}EcAkuT$fbtafbVKt+{^4SyNd_2ZbukAot5FVokHas*>B9TJ@d3Syz+7u zFIjuIhV+rV%5UpH5jBvVAlRSWO3r5a^8mjScSeltG!Hli z(l+;in-d*^w%{48PU6ge$E)_&bQ}yv1cro-8vjinRul_NVT)c!}j?G@yhTjTk49 z`Hq44UP$I`>o_Q6=_^JF2Xsr!*oBHx=dp#Nnhc!0z^&-g*;~rvCWP(yN^*K0C+OCv zXKv&^c4k1IWopNx+K{3$w>{#dl^*{@WE4r z497s46G;wO2M#wSy%)VMSSUA_H`?r3*4>M|4zZVN*XJ4{po-|21)M15ELwd?+9GA` zP|7jzZi^(3AH|ibCoRdMU4aJEj>zNym?1FDoWqIM1w#o=F7>G)?u_i>qB=zkq+N#L zO)Ee{I(q)`g-drvQwk(%YO_EbyanPY6eYV||9%7PE=rnCVjQ5rIsobJNOIe0dmIC4 z)JPXcKrNZIK&$9BkV0C5C>y)9LL{I3V!c=U>U3i!RmaUJZ;CCCw*?>(@2YePWq3ke z0RD#xOUm43bZPZkpdjD|4&!J0?b|8-E%^nfW_dT^%*w`JT()UtVVxGE4_otgtmtYkEZd1V@S(HBzXnG4~~I!I+7fyrGxV3->HwF-Pt$KrK>c16;YDd zc}d|Bh3TIZ{+5W4hWp8GExF@#JaV^()A=OSY{XHxn;|v&F?qTleGjOl_eHO@PB61y zvllA2&h>uG{30PWD>VQ+)7*FqcLkzsTd!-S zZB@lP*4wM1qCefnVX@t$*!ZwQqXyKR)DK(l!iyfUoru;r0OlkZn?|FS!^~Su7*lq4 zWOg9*aPI}nw1M|pB5N_Sy4&$$DZfrdk^@9J4kku<#A13R@;E?AD0L@KN0OwH`f=jj zpK>H!FAaV%dVkb16rS{4Bc!AjhAiThx$ZI%A+L)mqa-9w^EE?nLC==WRdnRA? zWee9FN-4}6_E0njOcWKM^HMvJ{}1?+Rh;QG`-4%_ek7CnCoNvVVr2oz()UM(qfwCq zShXHDrh8>umilo1q3=et#v!&L$$@%)r ztQ*lCgp`B|y&ZB zV5Vhw{nO^8QYER6{0_jjC}JEauN)1LBp^CziQtgcg3XL&k<$Uxa%42cZ7sjeO!}>C zyq`+}Xy0Sj@s%3S1SfrGNvVQ705(*RGXg^e$yD5+`jM`9IMfe!OjC?ju}!TX%OlBo z@R?&Ut))bYK66a;*}&bheR?I?5zDRvFy9pQI8a`^h9a|o=((ftN6!g1&+Uwy4xn~8 zs&xR%J#~57N!|1Q1F$%;`lf>n$s1x~FPWwoL{M&W>R*z%Lu z7e!L3RyYQdFlrn#1rE5z(_C^u|JJWp@S^OpE1u0_4nr)D%9a_Rcnpv-0~p>qP&<@r z0fYLx&^eSEC8tm^lu8?4&4RDd#W6(25s|{k%`xz{yH37E89>Kjl{3@pHGu9{Fo3>k zBsmYHpoeKPNJ%~Og!D?B4ON|y-vKb|BPIYt0kfJ30jxP`g^`|#0|?CU_OJvDMI%-$ zJgMR4TJPIzL~njuN)PK9x(Ta)kj~wXV*0Zp@Mhm-5N~r%ZnHzzxIzU|QqPbB%LN;M zcT{A8iLE~)kunc0Lk=-Hvz#4VE0g;B!D?GL$p9GTXYC#QFjnpf5${QvO4e5eoRT}} zu>=7AU8x<;k7TbAJMKgeeNhXU#=eq9gQRC$)Z;)0vmJ(kG!#h=PPJdQzNH-V)7PF#wofXNx5O#eOuaG?Wm z?+259&WLr31uMahWqB=u)pyC#p;Xb@E()&!o()lJzqQDSIe_;iaVW;+0GJtP%M4|p zM-+7rhj@3T1d*e6D`MrLFqyb=;|5=t(sKR!&ZqWDSz+y;0Ty%883Y zI_2Dy3hB0x(iu$|N}V=YILD(B2f#cMF%HC{f48fo@CJwkRpNj9=BIqXG3ULE)lvFB zRRf}MAK0j0PWMYI8|j`fDKA)*~Xbr_8frItjJ1E^jWF#;&ls$WcS+9<_p z+Hx^iu{Hax#QRWl(Y90|qNl0E79emfC7d8i{BNZ^3>{IvKa~dm{*@fh0^!_;?VG1i zgdk>uxI-+L0=@dt^t#_Uxg9bFOD6+Vg&e;MsHAh8<4hYLazaN*Ux4_^V544(Z4K05 zBI*=!sZPgB2Y7`Xzb&-?`%?kJ;{FmYKvNT|={P(|vVmHXRgbu)jD_kS_81g$d|ydh zfQX?TDpm$wCDnP0E`{y@!MjWCpv4y;tcm%`Tysggph;`GEfix=$Ya=4;tvopbkn2Z z+G0A_ErkzwPy0nLQcwGV3^%!TCIchq(v1S_<_2rP^!b}L0D0)u4l)#d)*`h5yauV~ zbh97OJss89{no;wB+W$%g6Vg!Olp?wc01;j?2s?Ok&Cj!sq;$Izy~$puy;PxSTs63 z=wdA-AsKi-U!o~dDvVRIx~`-&K&a|bZ8hfxXi8RZEKvnbI(HYEh#_R3LLUEMDTV+M zLvINel1EYk4(dT1GxpE?O!mi_%Gv;ef4DTGFG$Qvsj42Uy7;jQpIJ_7EAq4djF3*t z95}m>&u@Ecdb{#D72Z$KDuqNsMF!5};=B$>+JClKLg2}A=bp}^- zCjEO~S@PTwz|cU9;6#D=>OO(=8GCT%TMJ7P8i^nISX}-Z^q7n82huj#CMag74wvi- ze0Ve9uyB7#cG8;x7rdDaXb;jeH4M8$myXudAtW}GN@Rehl*m0L2|<%SJv606D&)3T zKHDHt79e6cSc)N}QKh3Kv61wQ-HEpbRl!!4dA>2ELf%*NObk<+x%H*E0;JTGZ~>Z< znvEr@pvly9Styneg*-KzO8fyLhVBw>GBp7QRjEk^a;Z`&`6A$CrTW=9DkxT|t`|?T zx4cr7SE>F|Gy%eCQtpNgmZ+13AmA`UIEFPNIMv=BTJTDLWn4oYaIRt-Dhge;+hV_u zlI_(bv@`4wq<*vm^pA$Xgb_Q3l7rZ3EcCfE*4t%x;}}T0To2*~sbem2`x?F6xMAAk zOhCJ%CI{%zxk^a;AjJWh2`J|Mk>3F@2P4J+n%#i1L5=kcYgFbEjC25*S%!hrfiUtK zMiVty59=8RD`5*z9C#fShc)nm=;r*CkPp1ZX}!4oAxgTy`_*$p7U%ng;e3=-EPk;?##%QSyibU@F0+kK9vdSOw4k-O$f@awUh0PZo+M)hQJU1B_1* zn6Eb(4M_)rcdKK34#)z=Z5EeFPU@Z&qTZhp^i1WW2K;3CP{SIw zOOTa;$^5rmm>0wkrGg?dIpAs!rRJBY0RmT7!Uc$2GF7P(AwV!|AZ!k*7g4S?0RH`{ z219k+*}{0fjt1P*(_&a$wJ1tBK+$voNJ}Eg0dm?*RuNhjNe+Nn9x)DttZ9l^2jD9W zx=R*l(4F-DwQhG{l)dH~`i_MsCCU3`SA>|(%0z7rz||fx4p3^s5@f#;k0h)A&qTat zGAO-jfteIIg;<6`!!W@XdZ>5P?6e;FO`W;U`ad8yQ|dAWJ|toviuNI+DSc@weDDmj z1LHn?z}phxvOR_#DWYRH0C#Xdt;L}A3Lbf|PBRhh!00)_P$Ru=zh5E6Nc=8MG<1j$ z{X9)&XMQE2U!5@9}C6GY{67fe8l*CH=b>=!mWdlD;tjZl6s0bVW-Vv2nzb{(g?Mmu7PU4T?P7R@hu+ z$m0aq5qMEy`9XbTe3|Lp<2KL)S#&r+F&QakuQc+;0p4HogOPSy(+x?*z?vGj7DJb5 z9H{!^08;K_NUMw)k^@u}*8^!yBsl=4Gh!UTux>LI(k3S@_`8FeafaduDD5#jJz3N@ z$3WUwN~i#KxxOsvyO_hX(~T5EbKYwd!fDERoHo}2%Iv8g8v=tHEsZLPWCz;ZX_D#K)J`3#B%EZ9&|-V&n$kwfD|QvUjuBH*-FNYBgH4Xzg+sMXiHp(tE)R2=PKt`^IgZ145HQaY^Gj%(2*N!?3)$ zw4`zCdB({mB(`O|Vj%22{`2kZ3Mn@G`LRrE=mn*}WctVb{oe8(N;yz_D77zQ94P;| zzbBFe#IL)%1&6P@f+>fGQoACj17P$)dMq`{F&KmYojn~<&;bNjMT`UG_OwTmfM`!f zaIibVFjpAWr0R=t)z@rLMjM5Hi%<`{T+Ny5X-ngiw2XI+rS zE8Z#~^Yvk{keY+%Z+}kJ2|q7N_uW*fH>q7>O0r0(=wf3DTr$wA0cSHZjidms!>K zejd_yBIUfkMjVw;VBFDgcuaU6Gftsp+k3thr+(gwT+)>pN zNj1T|*F}W8wx;TZ5m5=pSlv-o-Cm@pObb5K1l@?rmW_S`MDPEm5-vbfCg_GsR6&!| zFNZ7?r(YD(sDVkM5`TceY0_n^lTG*UA6$I>*waSJKEf1GXYd(|xooY(W{s5tU zO$isEDfV}isDdW#UuB_azd~+*ONl=~(f${6G{E}@DM6=kGn=u_rW}%QT(q8UygBKA zmmRfVb();v+9Z|+DZK7b>J;2;zd8zD+pqfn9DF9f;E;uXmJDn(K8D89`oF1r8~Cd0 z^8bGac62K1Gm0sd80Mjdf`PJP!E(#3&h#v?$VQQ^MukPjH_@o zU%y3(MT&+s2pE_*K#EvqSl*m@i-fR{o8R+wUGLA?AnVun|NGxO{(HdrT<`0;-q-tj zU+?>SoymGmwP)3qsB<3xn-9M&iP>Eo%bF>uqjVY{di(>AW%+q54rr;aw-Ce8tmi!k z72jp0cbB_hF@W4Hj75TXuITZRQTKp}7TrwP4OPF7Iv=13Ax|e3^!(a3J%bYpB&3^0A{x%az;Xm7QM>- z?`rr)BH;hj({=_N>o9&p1=g73NsJ@JZ^@54%-D7DojS57=(?A z1D@;%MsEfXuw#%^BMfJF9IDNopU6JQ)f*~K*|pKaL1dLl$xim)L`%E5SL+Ur54;GC zyD!?F<~yl+rf4}$i&Jbr&mquE%i2aJ$UC=|2{o!2RAbdn-eH%!rOQN9pew*PRNWhO zUICu{za!1PJ6d!;?%LMh4r*-qW2WlSXwhl%SM_+*c?nM;q&t#_DH2qeorI{rbVv0D zFi5j#tHpTGXiapOos|O5Ub_qcaAUhuhRC`N9@! zi|PvbeSG(C(5Gnpw%+{@h#&LL03n=pX*ph#dsHXHTlf{0j7L2HgiwNimG=R^b|3eu zb=R&Dx%Xup1I`yyKdXCg#{x`^UGZRJIrQ@v57Li`FGaZ$ET-wgLgQ^-aY5yLUYij zY*R$*Hk?|debuiIA0D7>?{nS#`Aa#`>f;Qy@4boh@%{D3_`S-3;^^JKnQ`PC#BtN% zrxC|&U)yrTaJK$==;ODA0VZzM=TXQG zXutNQKm6;tBR7P<_0oai|KWch{=H`%5&j~D{|9gie-&SaKik6p@loN|Rk82{C2D`; zZ~Be9h6+a2pI@k=qN=+$Ztxmw7G{-E#W36KE+;%S#l5*T2s!e`3(Wvx(}Q0?jUz6; z7+_OffKh?Sd_oaXviSuPH~o}|3{?cUKtkab?usZ8l6xJtkLPg%KN3kcU3d!NvyxhS zk7Q)XZ4)!OW}ax}rjJZ^Cl4?19C+`iAjabntuNI5=s>1wh8+W^0z_RRmHg}XRasJB zIYKp}Q(^$j`oR0UTg6Kc%n_;)V_pX?PA)eVC~A()XbymxEp~{~*ACUX39)Bo=e|{Xk5U*iYW8M)5?7+pzp|MJj#S{lnX$~soFCXW2mwpAi zFAYd>6p%LvsarkxHdZ~)0lK?2*)@Yh_zS;d&qgp=6yM+b<9QNW{pNO(_Al>HF`Q3Y z#h=E+j@5F$w`20Pbh?0o33s;WijcEkf=Ep!$zgCfKSwR z_%3B>_G%XEw}Rhr2Zx*^6U?ehWsGt0bzSIm4jj zJs8znQCkncB#mV0ueX`;xh3(*lw53|VN(i+`=~!H@;kfLk1?GruXx|4FYcUk~!V3i=f)KJ4^B(cCUsd z*pa#rXn1eqYOGb5*1P6Q*8lm3DZP&(TFuBv>bVQP8m9E#b1jKkekK(T3u?Qtfwte3 zkwtjpn#-*0zP}Gr?~?APsrr3(td-i8aFTvoWVDa#5vd^e1}^K8pXy&zW#{jKnZUkJ zV43V@!=EYq4;{aM0DdERE1z@xmkhtv_6o?g1J-Viy#kFe}}Z1%;lQt z?8Dre8)9)XF~!Hn72%WxRDJu^pt3JpBul4*A99o=HGjRktsJ=B{_DyRKa0no##sE` zgx7So*Yv#}k@*ddKM#B+>+!f$_@9D5DjpjVh*qCfJQn^V`CU#PDe@O3l~gW^%j4Ia z_zT78gMm0Vlih9cdFm4;c>6UFDOIY((`Dt2#Cdpbh|#>O;5@;^6o?gsV9|QJ z)PL~|DNrDOC-!-_d~OvnSN%FP zljSgTh9jT3$~}-Q&fgJn|LFxH7r0cu1*;nIY7zegQQi>iC8Y?zL?J6;cOa4?PW+G) zXNmX&h*Uf^49fM_`?uf4B{)}kF86_17+)jS`77aU$iApxro`HR%O&X!&-^s#)E)6! zIZGfVw%nqjm~!t%CZk!WZOpzH=YTXzyeUX?|HGDT|8RhsS=SF850IvYR4pFs{0u=5 zp$dic(rDn|cc3_}{eC?bvf)+TR2?hY?B08oIxFS9{e>%c^v)D>_K+Do=Dhmj7SILa zydF;Iy(JW3j8vyC3xB;g{6YR+d~PEN@oS6}Uzhp^Ws3_XKKnASUt5kjlgOj^H${4< zNV&=m^WxReM}YIEIDW9~j?+YJrhxUI=1{y!>8x z@$R?KSBjpie)$SWtKG|o&5Mz%9~FL?m2`Ok};FDN}&1|!1>P!uS)Q4$utYKy14ax^5+L~Nk4hdWfoec$YUTM zrOd-l{+Y<7v2bEB7KEuYM(X_SZ4y$M$9#r-J4uj#+>t7;RBeWjgx~1+%YftRf1mI_ z1K&TsO1D0rX1gD^>XjwyHd`SspL>(OL+es~V5g`0?3}+HMypHh0j2qny3{Hlb5A!I z%o@Y+3%t@`elIpLV3rwXSu|DG!PTXf;!Ga8k^Wo7PWs6+gcv#_)dkvqffoah`oShs zW=85sT(eS7Mio!dRer*l@mTg&gP2jon+pQQ^J>HJ3w*#}elIpLLsKab`k6i}wIiDP z7h@`p6)DC!%jRV1fSON!kutsz>ey15$y)^divG55slR6oy zFKlKkc>BFLqi8|ph7YI}(Nx{Xmr0G$9qiF`0CSErD!-5>Ab*B_(P$$03s7$QbfpHw z$;QaHx!8XBelhH<(}4=`$*Uqt2#is_x96n!1l5>hueen3H;2 zfbAFfA%pqV6@%02Ot(zxF|ZdDo3y-ny62P_5*;xz|7JiCZ;PIO$ zRUcSSsr&9)TFiwPfNI}d*D-3RaP2iX>#ClL7QIVA$JlLP>)4i^irSu`Jr}9%_W;(l zZ=EFky?^R|r2<*A1E zHX24BY~VIDt%xn!%Y*|_PiL~PG-e<0`I;8WGvAJ3xo0nFTK+Ty(OaC(TQ7@BW1A zqeY8d0miNe*_EOBRBq=jgum<5IQ&C#_$BEUassn0O$wcP#0;s;WM89wDo^B->8O4` zpSs*kUBcfO-L{UYzj7mtaC+%8BwIs*bw;KQ?_w^vp{gh9+yqdU`!w&4Je;Z89d&NU zozdZkYXF$XYFctbZu@8{W(GwL*Vs|=m$dtJ;Fsm`OBDuS2?;WZPsSwIA4@m}#q%-A0Wg{@F|#><90wrnf)uB~Mw7h9nUgbO zE&5{LPQkZh@O>aA$yhW7F$PkRVaWdufGLhK4j{(?NF^~z>d;KZ7)V2mbfE)w@7r?5 z6BO(@>w=Xu+tHv^03E=C&;mj3Mf1!}qP{mbr?RL%y9eUiAZ9`VuXFx4gHnO-JQ+6^ z1I^OZ2{l$(ZR`3$W;TV8&dp2Bq6#hDvsU3Yb*BfHt~C%Phe=6IA--}To!CS$-;F85 zO?|SL7s8X>*=7^-7E#9_V`NNn08A>zn0T$GI|fokOmbjo@wMc&;bgkm`L@G{xE}cs zi*qwlGotn%+NHVFtD1S6n8@}~sia#E4}!NTYSW$~%j6oP^`_v}7PZEzJyGWvw#@|x z*DRl6t{zASqRt!p9gtda)wjRU6RO^xHJUi4)L1Db8Y?;Z-%u25l1y$!YW8AHqQ8;(gxc2ka1nfIHAZAjOnKc7cYfNs3#Dg*<`Ic# z;UsgHA3_US-k0oCy0aTsu6S`K`pwK@e&!z2P<218W*xzht^4XY1UftFd{(L6QF=Gr z(4$2g-2F9kQ;`1C-PZ;8qRZvRkXK6l;PUhINo--C%tWA`;_FDdqWsdA4;^N8@i6xc zs#DffSJfRZlo{P!yER{*?RoA(UwQFgp2ix}QM&zC$YO3I`wWq4S8bmEP=#jxgvvKP zZ%NXm_P@6Er37nwwXJ4x^6u|oZtuSOnX2Tc5i;-3#Aqi=%ITIZmSKM4x#3}a3M60|x^;VUbo&7FJ>E}aG_e-?m+%EjsEH}5Ux=Yz+vN0lU* zMb?}>=k1e{l`zbi(7Hb{=e?84N8*Uu-b6X1(umr>OEAw(U_3B>Z)^1*8EhwNqOWh9 zluW>O`F)d;8$e+WN_YJ}BwYUM*6N>%YtAoGshJXNMe#qCZ#znxf_u^V?yfL5rFo{i zM+WzzbLHk?m6L=RoXjhiC)Sa%w*&PQFD5+Q5U*j$fE(h~jpW^)^QqFq9K)Tn7^fd| zlHy-^_IZ55oWys9fAK`acQ{_Pe6IR>2+RxpUL=$DOQ<{h(U%1Z+q0mmqr2WG1X9`6H{{s6VfKg(S*V-doon@S)Em;&Ko8a|7^C3;%J)9}nKb z+bU$*k?rRO102gRrT;tcR`D;;k4eKXep&Sf87vp<%tA z7yqIBEGMPC{ER>d<)>vTwNgjvcT|_C%015u$IZdLXq3BK<`A*gdfPbd*1KC&*ayZI_SAe=IdX>tFYU5>$`L^F>t6y{8M>d+^ZV z=N`q#55HI5ea5LuCMqijk*jQs?UoYqRhmwayI}VD9U-4~a%e&hd(Wto^ydf6nnQp-_xJL--GZr>|AM_iK7~ zORv(LUdM2*&35a*mDJE|JD>Tai{_L8X#nv;XK1+rWyxRT7a6>cVF*pC4CRFkr^Y~d zw_$~2ORqCO(>r~mzW7%{K?COXPQPCZ>I&7aG7*6cYeH9UGNm9uodwpEFZqD%=%=gl*S|jOAy9G1Rep6L_V@-k4alY!mULG_w(at-Gk=vg<_JE1wc(T?vu`MQQLi?<0zf@^#Y~0e>q5_- zgM#04{KW(CUlTrS_{w(zTZyZNAwS2Fx4$PKD}?+6$N~GceEz8+dw=cJhU`Nh{!seb z=NC}nkf4L~U{?hewz;OVd75!5OD_0@_5bIEd9`_d(U(m`ktgPx(Mbviz_d9gxy1aj z&(;x87C^CmuuMEouq~RxSc-PKCmj$U<2!r|t@cPd^!?m)7%=JN6b3?Fu+-=NgKjvt zcO~P&nL&tO3mw}yeWZ=OEZGd;fCCqyEcq$M z*bc*Oj49KSBbdkWA-oqb(%J!n?e<`~0ujJ89XcL@z= zmXceHAKsDp=<1(25uP{Y%;h!}az#1Jg;@~~8iB3PCcNG%E5;v_&-|XQ zS@9XBLuZ&Pq0-u6p<<`U3}ENA1FSjjGz`)OaJkQs)!zj#IhcE?~2O$(UX4uGKvc8misI{;~T zOmYR8;&2S4lZ|wt12)C6l3iJrKSn~Tt9pf(D;a_j7WRy|16%0mhEd>Za~Ii#KhP$m z8gFa89AJMcI`x8Tc7_o)rE5GBqY}7-*=_Mxp`B*0hruhWWF2~w(1QnS(QFBks z?Eq=p6k2MnOED`H(;Wzh1P;W~sKYcrWKOt!=Nh>nY+<7fwNf6gZcH;EFxxtS&%j4F zASOA0EUhpbvjYRG%E>WFKr~e)7V`-XS8xk9ol{ZlO>vh(uVUz4F<5K^^2vZYnMOOSFy37g{EQJ z+Dw(shqIl|)WIwc5bt1ZuH1}C4!~RytLy;rUf|iC<|ifzh~wQUIK*49g*YbWbO5p1 zOlszIAk;vM<+<}+C5qXL(V~w7FqQvueeQjUhTP-{4K2IQ%MCk;mx>e>O(@@N;#0AB z2PhH}WTc6NV`*MU-KI`^|Ies1V~-9{VAHY3OiXfMV0ur8br%rFTV1#~-hw^!SjfZ} zqfX_3cvDw6CS=J8A}eCQGXLY^kQ^Xl#-K!;91C)QvR+WV!s1Lp8gd%N8hrrE%Wn;*UMJES$_FdT+r_{ zpf_6dYb)r_Mx7rM5Z(41(>isT#0HjLk_>`hvB=+Ok)IdG&;e|^Oc+_`zjI$?ANdQ$ zHV0(7O1F1nV)Fv$tpL%Y3**3E^wRj8mV0I?v_w9g@M3taCK{(}U89MubS80zNkNS)$oEZ@5m zd{dlH92n4|(EBoh(_^2kqae|p_-u~xbm}Nc?gT$0mgoQyr{_QPxaJkAC;vCIot!J^ zC_NphHupYF+zuf#oPm>>rZM_tC#Pz2*Cfar2XDpMa+nJK_duDd2gwXufucos(Cl)+ zkcvC%9EsiSWWogoP`?YXV~W!Z;Cy0=W#3H4uoRhLcP6os<=7LoOs6%!4vS=0Y-IkqBeI0tBO8)=!7rL)pE)Rg3YsM1l>rahv_=+qzr2kk&P?N!#t2ltW78GO(*_t z>3VaV0ovja9U#O)+IRG?7%qsp9DqxyZ<5r(WEA7pP9FSWXeyV+=64Dy;}}ILCOM!W z!Gx?tLU?3?z&)|R6|pZYPkhM&j=}rNm?Sxt3mgM!RZMa~`AS;XyTw*JH908`WKGQO z6tot`mVmUD=UKZuW^#Z~)`JQ9cboQ`oF#dBEcm|Ik5kazF?ik*lO)BocMPP5Vv+-v zhZp@ZY%3mV#3m1LhjTKsYvDf@J7=16XDr9@RG^L_h$mx`17Pwo#%0prIEK*Y^ya8T z7jq_NMs4=N-kmS|`I9;j&Gp#_dN&$^NRTa0MofP8Af`sEnG59@%vB$2p!>S8o$8tC zgN*O8t=#nv3RkZBTTM&@G$phOaqrdB#XT18Ygpob@#@cNt7%{#KhD@cC-%|CzKzm1 z?}uXk?{w8G^M22?iT1~bO?TBb;yherg5kVoxenxXeu)W0X|qUxye)08y@79%_^{9S z7 zd6<=ypmWvW+DQYI^Z9hyAgBO>$Bd*#vC0|q3(wP6=gU~d5Mex2;?&OYes!498sgYe z?Oh~8b%wXBX|l_ppp(5s`k?Kz5r%*|!yDFQ%wb>{@i$xW!(9|Z6a&IM*2(5zz$}2e za|ZKR-OSSf{qlzBFwD9>f<2BCWmr>|(7RP8h6Kj3N}% z|7R8vGUTHs9R2@l0Q!s6um2IsFO_6l?ASD3`uo<|C#RzS?+ymFzh?TQ_TvVi_EP|+ z_H_dOL2c7{zDeGNWiCZBWy;n5B%)FKQiPkeFN(FT4BF;aYEyfzx*5j8F7v-qEb%qb zRN69cG<~3JTBJelDY(_Zg^k&Fd-d?@hls%O#@&0(yE9b}M+;RNpL>`>Y{mYo>}^(I z&6Tih)4SAMTdulQa!)Y1bz=V!+V`n`a_QB}CH5DL+DXo99v~^_@zZfUS4Cf@VjMGm{B-kRw${QZ;ESuB4aH-ForoEDqp?RD~&Yrxg}kWjhm z3FsBi$fnUZADNCXU-MU;bzFFgSpS=!cs>2!+21$e7Hi0Tp4B?n|8jp{qq7(0R@+kZ z$s0D!)@A@z*#ZOp+5Wye|11cA116vA>T;G5%qT zpUNQBbq!nm(xdk`WFPije!HSYYH)m)-@(T0OO4t4ePz*qsgYTs@%?`D_fzEA7{b-Y z>DG?)SSjR>A>_Nd^t#ZjA5u zE6nYC$yQI?e8Idj_CDVL%C2J|t%^ww(3||n{eEGlKQ5$5b`0Lv#NL<0k{tu7J0>}R zgQa za}1Q0|Hu3NPF2brx!>$3;X@D5zcf(1-*3g{|110b zp1v7bNACA)DWX5?`~7CF_gz2#oBe*5BgFRm?fNFtj@<9}lu$?S_giVm{{4Qp26th< z-*<%=Ts~W$j?z!+^AG#|&M2tv`~7~xM%$ow8GUlLjy4^!-|zfK*|aoZzuzR>|K5JT zX*a#re!sI7{(${{ufk>f{q_U=%l&@!FckLtjl=QJ_WM0|V`0DFP}sEJ?_p3!?f1J! zT(;kD_BRMw=MlnwznQ@u@AsQ%?*9FLY8v<{D8t?bJQoc4pnpFPu zV)gn5?DyLMBJB6O15khQe!oAQ+#m4kB%<8|{>lLSUN%nUzu@>cfw#RePYBuM$gjUS zAnz0MT#&E1-|t6+t?3o*?knu~JC#jwh5df1wVoIM#eToB2761NQs0IeNd}^NT>nnrpw`=h-A%(E5Qbp#<4}zcQ+3 z-|u$}knQ(->P_V7=7+XNv`aAZ-8e2b8K>0FRM&K@A)Sm7Uc{NG59 zyOpArCL7)hWxZ2wJc9BQQGV={XH1sw_d8p%ZgTt$1MqJa{wt1uJ9ra+jF6vpzwj_D6!RBYr+56@g9Fqjn4~zlj9ZtSo;qN{}sm{Mxhu#N%&8Jr@<^g zrsaRW->(c+@tb_$Q|b{iJL-rqJ37p%%xxMFW=DrRw)7_R!|bRdm;%KrK0A8!em@b& zuynsWZNr5vKa2#)VA}WlrCexyE+fp7Rv4Bk1_AIkGf#S@juglH{l4++5%Z)SpTQnK z0(azozhwc_KXbZJ80JZ*8zni)Wd0BK`<-I`D!=#X0sH;V3^Ggj+B|8}n5wU@k;1;; zZ~sXsczdrDtiE&r{@cQT%kY)&1GWs_2t&Tjk!w#3$caLJ5#$m3{TejGzr7**YVAd} zAFiEhTmF16I}=ITNX*u`nYyrI0ggDGlM#>i7k zc;y0v43~Y)2TZqjvrx(jN*%QsmX6Y|Xr5(wI-A#P1Ixsb4sVrUf5H-BQd6Z1cS$3=+8-=^8_iby?r03MsIOIJ* zSAZbzZy3F~v7HwJe0$ejWH}~h8#YSEEvA7@{*>V3AudkG$HTn+F<2n_Y!XLQe{VYb zU_Bne5^GWl;DEpU!^m#1dJ ztQ@f^xSQpfh-jeHnEgYB>n{}RhJ9QI;uewh#=({0yenzG(>$^^Efk?vWJZ&ST`8N; z=d0OQxwYh(CRv)y>vDTbL|L%L++DU!MK-Q5J}QX7H{9Gj*I@2dwnU?>RAg@Usi7## z7{z>)RDc@M2~-m90+3Z5_>loWJh)vx@iJrj+K&=zt|BATr74sPLZnxV34Dp+ zDZGmLE+NS$x59*tb#CPNM^2lpQm;a+`l8!dygtxtA3IG>b^Te)*puTHn|SV<0?mae z9U)5$8S^B(+x)PTxp^h^DE14!jU29T}EW;#oS(b$@n|W9V!=$UxaQ_xx^}& zu2h+Qm)d2xO02@V5+nWA-6cxy!^#nO4eYsP@N+Z)f0J9pv{}>{YE3=q3}2u#m<( z#RNVdn2Qt%)ty4_GNj5ej=tbX%TZJ&HqT>nmjriS-f@=&cS&#$kLeaH`xnh!$H_sM zD}tj;j&Xr=SMWJ8xch>;Cb-kVoeu6P!969oi?qiDc}>Ax65P$fZH0)!G#_`m<=Aw~ zd(thhS5as-K~xnYsC^{1LF<{I8nOpf)=EIBAsZ<#Wyt0zG)>b68Knscc6y!q43LIv zg9+ktgDu|1?oU&_>#2sW)NBPq3p*t}nwFO5fe_r#GBHit33aYf=c&1+g|t_8tbVqZ znz~s@yKlQ{HWfN~5+AXWdN4KUTAfv?;il0cGMBvk{el zey5^0AtjnF%dX4rs+D~RY5}a|ye95Eb+fDLQ-BTG^{g~*3^r8MbCX|zW_FvYj!0B@ zIDZq8Rg63bKcfIt@o;scbpz-`tg$w(vE{9HQ_*s3DP8u~xMPu<{ICn=oM9}u$^?70 zC#kB68(WTJ)m*i}60~mQ=A-B~dNG^n58eNP+{yP#h^#TUvHg!KpsMOI(w{TgKj(Y@ zEJeN0N}eji#+ElTAt26WChxDvdsKd-^q@+V4a_6bsnyBZ{MrX*APMj|VZqaRBZdUv(34W}cvf**e2J|857YOeq z4P3@5DB{&EG#)C5ABM=6n>b!H2>96+-+lRmq@3N)Cgx>^d@!E}i4H>D3M#)tOw23b zUMcq`(FX)FE(EgDg!KpFotAz1C5FcmlCU}i(kdYyNVkMuCMFML6YkpFrHAsLFpp~r z`Cy^~%B2nx3H)*n`l>^itRbpDke?uNWHuFI1yf@>J(xe)@U%QS)!dU@dv!t;FRb3K z8LLX6+B5JyN!@8D4mI?{dy-plq7H<21C;=2X>w3c@*12)!+Yv`lK&A{Y!%6`#ne76 zR(^Yu32_w_odYdd2`tZpvttik6;@jOT^-m3)Mcxma6+qH=VhOj6&txzWplc9EidSN3PgG}+amOL4fC4cO7HtSl~zr3%f|8D ztp^X!`g zO|Dj4+TIG6PQIsmlD`1K6iCtCmPkv$+%9qarL)PO1BN(cOMi+3+#P&Y8*@+cYG5(r z>t;an)st)rU{CV#d5%;U5UUmyEvo_4V@d*<2^qEOLN+wNfZ>@GQF72WuoY~%CAVfw zmO$rQzL+n|;z}VN@`F)ZMj^O^duEvH;6gMbPw@mCHQoG9Tb>f4F88HG){lMYX)HV6 zMjHDwSr;cKz*`$NZ0A}CWKg-f49^4*HjLMf*5#?Gj*o$hN4+|Qd7_s6Mr?|S4ous^ zL$OTaq9$(&7;WgN)~~Xp5#9EZ1ynX_HQrHuxn)?(IeKbiL_1ulnBJ#Lxp-p?&(SSt z&xtF+Y*;D3&U`}DezW6t|5`RR2D#I@;-5MKotw=ErgC6t`CE{Vh*9U52rkT5ih$tx zH~Ed~>A9$L*;>6o2?(V#X7PliBcwg1%TqIA(GF-Azhhzm{n{K81I$e=a7+wf?oP+V zz|c`szCwCu$5z{?@=QK5%R>K_f5pG0;hX#n?x?-f_rJKq&ZLE`e-E)%N#Nr4 zPr=#HvXN}N3gnxJBN=-GAgk~oZv#@s1zg$>>Ml^jQZ4{9+3N4`NoPxE@##tKzEVUy zF|D9xfg_AoCeu;f1}ym=Su$!r=SxTF_`63y^q0@!utjZegbP&~TDE6e#*RmDttBt| z6hk+Cdy>Zix<2K{1CpVLg#7z-O!Yx&*OSy;mB!YSd?^OArK?Tn_XM4Lk}K7?@Rx2G zyBW|Uz}!f~2Cn^~J>2(5wD5*1l^bpnyBdHzyirw?>L0=+YIDIJVg6m)4S`nc;E38j zad}wD=SC(s^c~=j$1^NFfN8V-?La}{TLMVhv)|P7NHT$b#OwP5X}8At$C+5U7Y4D) zz?p32f7qw`y?jj83aIg>0^cpNGL|5cO`JN0fLFyN0r_FXYWz0!ST|hFFk%anQ!>IS zGGNqx8gZm^8P~u2^Uu)}@v8UWmt};H&cWT2Jb+`gV$LCt?AYV++%a|nI7lz^3Gvq* zpaJ|XpxOu8m8kQPW;*coiSdQTg==m#jxMxD1KOe<_I^En1=E^)Yt<%QsIGc54OwCU zH%;2N)Tq&bHD))_7v*#pt&;A{PV^M`&S~I+ly7#^Cmdu1#5F{XyEwAjo>r{d_r}pa zl;87Eh&DYx`U76%xPMJaOm|`&vC_j1G>*6?$`EvbcF@V_nAm>!>Up#h8QK`!nn|cp zbHm@^IjOSnKh52^v?LG=m?PluDw`+blSiO>FB-L}XEj@0W!yUvqG6VGQyC1Z1EiT5 z^|XABy;u{C z<~vH-Hy1Qf@ULx?rq|YFH9pW}N3cnseX-rYqsegtG|@n-ql`;%t_i6#Kofxlo2*JL z!};3Ebi;`jP(_F)@u_H|+_nYn2s}B_#S&pl< zo|xPtMI)zW2rpVVl;3mja3J)`l~L(D&v|ZO*7-GES=C1v8uY%$gBRVpnM%<=4*(7 zB2}Zw!`WyXrn&G|(;xoCf#LthKMQ~2zY2e19DXpDnezx`P(kJl=Ch(Db4fd9oG2c$ zWx=@IhuB2L8eNbt*lytdPV}GHuRl+X46xr>|HOWC8HF5WKePz;8y@tR*(Synkku2) zAk+(1_{usG9Z_OSLNBK1MJX|8%BSNvZEd)zNqHtiBwKcCY@7X?<~AlmSH9LfKuz@B zjdbAm)}FezvFg#9XlYODI_^JMWpBQ!XMgHG{Epwoe8qf;Z|ReeszZ{aa?z08Pv1{7 zIB=*YQ#VlpPu-3@nA-4#*cjKo4V+FF4&>Vkt~2myII=_nbeMz;tUBq`?dcYJ!*Ia3 zn2(kol+zok;9;4g%@(*QMdP*&lpB8ymuOGdv@y!4*oAazw6nkl=3oWwM(*gS3T*okPLP4I7uv z4WV%r3o4Q(M1x71^u9-J(ttx`h}{BGpaF#-5rl}uqB?nm`qgnrwux)s@ zX(9!?1MZ{brH_=i(&eS`p8H6G0pa$6{x=0G`F6JLbL#Smx6u#CRQ`G(vkJmG)7M9CjndZsvnfBG?G0jr*U zPp&3?sy5j^bPys$@9Rsq_7&TgE8P*GmQ8%4Unb-5B1)&Nq$(>Y1RH#l$>mr5RRXv* zSfMqaNRQqn%qG|Rm!>r_M#chT+N$_d*$+2Yr!VK>VF_-MxtNdsG#6DSTPoetRa6I2 z=M$d;B!gRyZYiTz7%hBOxGJXOqR#5iJ6RLe9d(Nj*yD6_u|>4-#Ho;I)P^Gr=VybU z;W89~P9eVhGxK^Y?rSj$KQA8ciIvV}(wVRLJBD1_`giW|E%_8USKu3$08+_`oUZcF zqRwxFHO^5N3t*n(hZi|t4cg>OUey+uBO`UQ1i8%b3)H$L%OPkYWr?2tP%3D7lxEVp z58l>lU4^EZfZ`jhkG}F)8_<&M2G9}bJThJL_~O}BG2H>^P0*vZKaVA}oV(IF&VPfo zn}%7_Q0nBmOevdAq#P?&H{DOq;;2~tJmGpo3aqh(vkN@ht@4SaI`sp@KspcoL37Z)lF?4;E{o%&a|+ebxd95 zm)DFB@iU+F<2^oXr;$zKNT`tKh73|ae+nfalPm6z)RpIXLf6P3EoJl_X)Tc>4Zdp~ z$&pHvYf989Tl5u}Cebv3y4o-w6^0)08)T(!JZbPZesBKuOp|sb=UkHDdPmHmna^n9 ziV7Ojo{r=vL6hFYC78d4?DJ|@tU{sFIalbYV$=oiV{}+CqKQv-EizUMeOpgdQT}10 zlwQn7!zJcs+EVkOW;eBV56Z5?RYWwI4kIEZNTbHHT5gN<<8jzf>FvOa5@n^Lj;ChG zh@c8=?Y5d*eU&o|q^o>!R!WMoA{|MO+8dlv559d3BP|JU+cTwR}Za&LxUGK z@<#1nWcoHUX=-Yu=gMlF^vP_Bh@CXM(^ac%p)P7448|r6_0iC`GrvcHMPS*dWw1fF4|d_Rls`iNP>(xm>%n$_ySLc-J^JHjD}B zH_VEH%+(HIyWj)E1RPRU1?ut`!Z5L4%u%2Q2*WHd;0%&sN}{%1p(tUByU0jE@0kU| z#?XqCK`8oI!6-{pY3G|x16N4UW{1c)F~r<{pt6<_pyjCvf+8kT4Zw_yDV$iwEkh1* z`H|rw`d$^mC-)(l&oZh_1336)G%=-Ok^^8y#ux)?qoMB~LJbqOsi{S-n;1fCsds?^qbO<|4k61-uuok;XMHb~cM|MatZ=)EM{f zKwUH}?|m?^IQnY2A+R<&aYHn^EmbpwYQ4h0D4(ZN;Qwf3K>)GBIY>z%RAS_7=Lzmh zU*jHW#ER#v?vSIF1vR6T#d3oGXXSrO?5`-MIvb_HF(|MrgkfK@f&9pCcfi|s^!s+n zw)2%XRb96KB)Z{;IxtRil$U8~;?2&Me2m5>g_Cw|)2T%*fz#YtsUF!f*k#8NpP6iJ zN?Ca&0I9k)Q?>m(J$q3YTs)*|S>0L#@WTs^LiIO9TX15&&=AR`lI0DNxvWgw2fn`{ zlFQO{jR9rJrzV*q6rN4O5Kid>LLn(MMC${7dCWmW6mZlE-36*i>~Dy)0xNL^7Aly4 z!`rF?H9+827H|ep!OU26AX;>is$O3ConrPuV(JFu!oQ-xA44k~rz|8Eb~VFtRHZAF z6PG(NRJwAx+%AXEJU|Fq=D4`hH6a8OTBF6mFISBQzXcy;w}3;+l7i#_VUyVJ@>FMm z8X)4hpnx+7o1_-84l*dC*Ut|s^U(#IqC&2$#Y{^k(M>GMQrCK1x>ZU&6#_(KBM9XO zR>UiuN<|zXv|a5uD&iQT>+LueO>Yel?YkgV#0FTVTkga%rW+ihA~u|Aj#Ds~04n0*J5>Uk$R4lN<(qv9TK!{}Z`AsUL9?!9loNLb|4czRMDWiCT!66V-{jW{<0^Y^Udp*(Nui?mAP$Lb zzk=u|(ijJEYhtg{3pljf6N2T)LLt@xqHIgB2QjtK-3mTpQ}zY%D^h`lu5ZAh*?|Jp zAWV5F-Oa02=lw%>bC!2EDVd%fuzw7(2TQnqqdxB$YoJkulCJbrg8u@9BEt&$8+4RW z_Y{1@QmEJPLAnhzYD{EdB6wJn3SKd4z@fk_4{RtKAPd0;NEK$Fu1L)*P=k-ysKX0{ zz=BZ&j<^&Ts0PWXbXB#QP5jF+W1*|MA~h!{+7GRA9JYL_V9@2MBA3aRh6hs+j0KQKJMD52c_xX z(&f#oA)=ofU9Yjab$@KzU);T&!^8&N)q$NQFPiTlP5D21X=zL)8n`*SO1KZUI!)>*}JW$Bj}HQ{-QM zyUowEKN)qG_h-q6#>NGujzNK)Aq@Lc%gdkquMBvTH?3Q!WdWsc+`UzMA==_VGjHS* zbAz8B@b*==xX>N`%)iwg9;$gXjdzaj4v%_=W}rxq5vK>Bd=$WI_KSzd+1LR5aPCkj zQehK6l#G*cS|d$~^QKuCr)3<%lR--OCsnPhA7DU#)4aIAD(_Tuy(+@$EmCk}iL`)$ zZAB`0pe719bZIIG2@ti@&d`pGt!IKxjkNFYDHf~rFuEFP$Dm?~laj;bp+BP23&M@T z`Ue3=(DMpZgQx^E3+YaG9^IWDV%=#LW`bJ%5M^07V*RqLw<+#T+^F2|;@S#6VkvY9@o`k65))Y^2p-m?f>#=qfI|VjRVKk}Qd0vT zODhi1{ghx)*@#}C1|M<8xwW8eV4=SiaClo$pc;fdhb&ZATz64-zEh*a*Y1iBv936| zwBSF6I0hjc#(bh+HchAA6WIhJA|agS+qq>v1- zx*&!|>>A@$O8E)m?k_Yu<%hYuNTMi=KENVLXN6kV!8BygQPX7`$E)N8g*P#0f)@>1->B;5n_O-`(r8e zM+?;8BTkDg1wvpUEdq{cY${L#1n!{%Zni_DMZiJ5uRt}3wD>$@h?giYmKco3{yuo6 zS(cGUfj5R&Srx87F%G!1?8_yd7<0%vML5keH$*&xssK2Ak-$%Jqfh<4dXIMQJWr|B-@vbeeWnO zcuYC0-azp;gc=orvQ~J4N}O_y0g%`Q84BTu*NLgW@jqF4hQc)Dn-am$S#Hb5UF6ER z^}pYGK>f7EWFnIGJ~+wJa#^@b2Lk_sH30=8{MA0Fbsuah3k|&MIMwl`Jrfz3qdoz>mtb^ z0S9%YTY;bjsRyPGnfpAspq4BokwnRH_*_|_8boC`>}HZFk!E_j^F`8H#vXRPi(2Nf zCYTsvAGUB9Yqwa~9j|o5%LE&ftV&HFOf0`!Eb1x{xUm@XQkWrXAVNPtE)SbHrh)+jM9Gb% zbfxANj30c&sj{R%2rQ&Zz+v0zp*vWBz!eotD9cFk0uJhdf)9g~8m(#Vwb4t=&7lPv zrqToRDd8EQX@VkiHZzuNZS3eauFa@Fdj>jI;Rd@p2`II%L~-5R7!S2 z{$tX-K%o6G0s@w%)`S=?jRi0c3OIz$QZlHzF#rz?K;8CuEeol@ZYzfKi~!C1r;vSUPw?Te{r*A`>JrqR3^B7LIH>pnyQq=7nv2cETih!dD}Lh+$}w(Xm* zInK7%yi;6MlJawvqYi#h9tV18-!>;opG_B7zSq8Zjy96oR?~ITfXS6KkNWzBAyNAe z>q%CimT9BJGdo+cjZrevs63#c#y>KC* z&N9~^lbh&lqs|J!gtLXOE-H|@6vS+8D%@cXwFS8e>{X?)fs6HQ4rO!1f1EHgi7(5iwRPI*pGTEBoaSWsqCl&LG$$k@47V|m15(BmD)eXc{<{=gt)T*c^uTJ?ExHdQKdjyvD;V; z&Wqjm1Y%?PAxXkkR4SPHGG*@b4{?Y6@X3I0sp0-{y*__1>a4ksJNMne>+@&fir!Mk zM#z}H>L1NA0lr|C zEM}KkMUoiAkD^$n;{I2k#fqmB*x z4l6fxt?fuYR!yF6>1*#c37mKBVdX@n00ukvLZL$#=UvzsS`)RMb%d~RgukJxhqp_u zfQ~=hm_0;RlZb|W+qG>|`f&iHr+qI6a(c$^rH#?a9K!K>zzeaq=^l58I$JsG*Zik; zuiu#1%0cY8QG5Q~xLd2QB-Rwz8`Gv=eA==vfBkn1Vdr_0ABHJv+pW{MEgm{&;(C(j zfwq&wE%Y)J!Jg#%LCMBkfVm8i6U`0wseBV39-z8eAK9T!J8;UE;?!X#+c2x+NXgfW zp(nWyBbuC^0qx_wCQt0h_V|jmhUyyfNzr3G;OIJPY(ylkh{VwZbIdpn? zmBl#uI7*+F8*-0K-O#g^2R07Z-s7t4O0L|5c2Ts8IKKae8kLiM>N>vV(QnS#dbBcEBU43a)SH}4(AdYM2=H8az>ITgkE`@eq_COH6RXN+-x%e_5BNKYDR47&kho>c}QP(kD_O4zpgx}-FOKMzuU zvGIQ8w4C&flnaggym_YSc7TvPD)`)Gq%oY+0MOaFy5o8`8L`|gek z0&ZPb5@b=CkA!n}U$*=UaFIzDHVBb+ua#2=dYve*-6bK=tBwto!RY-Rr8V$nlV|Ze zn#Xg>l3hTx*@rvIFEated=H+bPF-|cFK4yb#1`FFdZE}jMolk?+Yut;J$+p^nTUP$ z;mi6S^3KH#Y~?lpfd`zFJk@wv*l+}tqLR3;WpN(iav>B$Flpj2X^w$Z5|cbrOr!tf z^4Xwoq@m@7y+A`^Ue9fGw;Y3*vX~@W+1SIAo?*O`hL%p#CL!gbVKMIx<3)@x*x@8N z>Z-h2!xqjz;*+tz;juplhL%rqO7d0h%87=SzU1HJANkIEb4aczw}&kv z6CpFcXrg`V=GrX@jc!@nkUcP-9wo(CifvZ2r#54@+PK=|{{9=VYTdZprVbg>f&$vj zCu%>;L1dbonmal3$n7;h?J_4#&0*phwVe!EwP<6@!^d_cy4%nJE(nwl? z%7c<|GTCzF32Ib@(cZ1Tt2Bc}`?8#+bR!^`-vtc!daMDA+P`-Woc%^T+<&z~7gsBA z+_S#@kCzW0z=4@D7sgU+MHf`@)Afxz6(q{f)-_@~3>owYhLm~Qx7j^EM1EaDy@77{ zqW0di@H+5jlds=w2<-BVlx!=8LCU1D%AdffTdp98&^DYhjIL8J-mDb|{c3btAm zP(&u!39r8i$V|5MR>0V9*zYB)b{srp)%t=yA3*- z&3W8pBP3lkA|rIW5zYhUMj#N(_BPybo)OSi<7B+%NG@d83`RH&n&GE7o*g{~Q27ai zUEb(IjtN3A(LPLMex|~q`kaP^;%lg;Sd3^^`8kHVZhA}-kY9FVkzZ-w-p%E`96xL6 zTWz}gO>gO_t}lNbJl0uDcA;(5_VPP$b1xGPZO!7QUR+|m>?pD-WtIwZ+)=~RCj5FfGQ)ef{RI_|&v0)ps-Q=9N!Wp&w=1i;ar7zZa6F9F> z)a`S(Ss^?2Y)A^1TO*RM2K#XrV7B^r2#6C7QV}jUcI9R;m%p(;cJyb*&?p z*0gWFd_+IP(b2C>tRw3x!m$yKs4eQYXw=@mmKYH6Z3IljZ`Gh7+(na7Lxq9%n+5V8 zUL=w-6Y4I9J!)G!R=w}4S`>8M;Y&Z6?4Au3fqvf;{_+rSXxC4Afz*<_ngNND21 zohIOpj#-f7wFi=9e({w6hcj8Lt^s`wQ&vRI>dR%j+)_H5{bTGF=%UV)eCA+cg>__1Eo3 z3=J9Xal^!$`^lDOai*-LCDh#(!?_M2d#H|zstL8y4EeZ4@g;^Cx2!vXWg-GTFI>e{ zn|-KIwb$9WZerA4CZi9m*w^F?VF%um9qiJI+A6S3of=v0&cWh8($=k(S!6zvw3+0~ zfv8i$VfIe~tFp|FT?BMwj_V$fGBaiZ!w`J}Uz7Z~wgUWgfi#uST=(y0Kv zgjR2#(zo$Zb)$l>cVv{MWNtm6bj!NTXdasMIwr%Q03+*McSo|%*ciNLM%!u68k?Nu zx|C*azdJqX=IOx-nP#uDy>y_q*N^|BTyu|QZuQ}Y?C&$#wLqIPlh8d{)b|GY^E`V zEjDY>GNbpWvkxnX8dCOGNbq_-TYV>RCYxL>*+`3Sdn7%2Hv>`ZE_vmj6@k%pRJSWr z^=Q=oA|q0%SYs*xqy=Oq&7;4%=qy#)9mzl9ry=)cjybVILSi~f^)6$Yeur|dj+V>n z8rW_!H@on}mYdwp2R<5Z&1`6eab`n;H$K*+=0o5DDN==r3p=gc_kmpTyECjiCU!OE zPHs!bmqS>VwmfXL4zq`9Ld-u`Hzc-jk%xTchFBCci9V56Bi=GngAVrQCclU7sFFCx z)TfC-l_q(Ma}2#zo0ey~60f~~#R~C#Jo3=QiNhh$^?I$A3t3yAh|+6&xy=G-Fg>_* z^!`mcJ>0%|&ZU~49^614({3qizEeKnX-hdUw7zIgT3qKA!^Yg?-#KqYQ@-bzFo<$s zXnpaVQ;m(gerg9B%P!Kx##s&wVCG2Z=U@|v%z zXkmDgpUIEfzKJwj#Xm1MY@&4K3><~o-<6(yd{9~|07Tny5YYr|lkM|#E`|4Tp zYlnoO%jpO**c_+Cz{SZHV}UX^`1yb#n4NJ1lzC8sD&6+LvJe)x`N7Xy<8Xu^_h|yf z7}}hHH&hL{IJxIwpe!&1?}!MX0BVMXr$o+Nrw9=^(aE2G{Si-z)C}UCjgNs#=X{Q) z@W%2715!c?$Z8?Em-hrCCLdaBPD~{mc3{IeoB_5RV95Oa?Fy-KN@Bo+B7YJNnRoKF z2Sru^X#QSvaB;oo)noGSXQ*jPp3d$+rX&)8ypydq2Pgu%zU9mzcbZW`a+!1B*6 zjIdv*&8}x|b{rv6o|;qxabZE}dEy-XA~mFLgKhi5Tgky4_f+31hlB_i}c|etNtFf zXQ{rdrf$eSqF(H9-Kl1sALgWKfE0-uLCs40W(vQIz33+ZG;wpK0*!;_Vs|Jiv^uk~ z_)f+|x~!?WFqezx`7qc_1`VDXzPJsu3ncR1ezm6K_6rZHk-2bO_h`?ghN4yG8jH1H z8gs*5$0Lr^$m7!qd~Q;k)zp})YbX1?mxhilr4~S*n~&6!7e;waDNVvylSSlon>qd= zTCD^zG-k?=y&oZQYyriWQQREXo^jtJioIrg#$zvP&(5sv7_648Hj75}i8-g#cARVb zN^7$<#b5@_83LvRR|ziel)`QeiTilG#oD8W+=U1F+o8#!9rB54J*(S%L2mMYHRfjI zc#7gPwb2)gBQ-~=!H2|6PhL$=x8lq-9aWp>eA4=hv;^a9)GjGa9Yem6$;!8mxLxz|mwUfJOQFeq<;#xbTTdfL(mfl_eVu~I z)^j_O#ezI%Mx9qmMItwxjQ!oWQ$(qtl;K%xDD=sc1z|}u2dC)Q$haKyk!@ML*p(j5 z{;vnf!|ha-c%%mubv~`#U~fSjeU40apS_^$j~73kf7i7tP%mBemyYDEZ?#)yQAexE z(SrN<)l~a7zAVI!-&VWt6^L3#WeW8Aw@Ja$8|+ir%%>xHDH7CKq~fc-NCY~G%`j~< zSVxySDo+7Mik7A`9i=5ku}fa6#~94bTxN#SQQEXdNnK{)Ri0wbu&CBi{SsTW`a6uJ zd2@QBP9T?7ZDY#m+?G0@RgIue;wQekkPrL|>Df>V&Kx+dH*aHH4O zW%K)XFwqL40%lA#hEKGh2m$0)*-eSE8IL$6&l6^2x`o#!5aG3de9g`hQ?Sjgm>a`Y zN!*X7z!UVhndCvtb0uECWH;t&4}Yt6-$Cniwd}}LP1m64*3qh|{~UF;0pME_jjJs+ zA28FhMR(Ptqs}_$8Ljn2ohJ)yS(}+;`S0ZlT!78dqRoJ5O2N#i^LqiD9WA<2Afi=g zS_PfR*LDoMR;UGz`mJSl3VJ*B#IUw#!LJnbq@`ARqt4+7kgFSPwCLHl%hhG6A9bz? zE+u}nXrZ}S$C9hFIkN+E(m?{@pE;E=7WPGKlasmuX zEz$K9Z}Iikof>wWdQU8V3203GLHB1BFXrO-xq91{s;ZHcfm5J#)uAXe1 zcj^aRNpRz7(K_UoYa*^S=bl81)O&KICxSueLwE#P79fmgfM2~oBmDCj0Ow7>BYu$C zol8|N5|&(9Ms*npjG80Jqn-0~rrRac6qPA*K$v4>QjyWl?`ZU^5aJqubF4gLURz*b zs>o>Pc?vUfcy1>=bp`+L;xD-*DwJlnQ)e^RTU2AiY#1~k5Mo6UB zwf3dcn1XAN_acI}*Vn=}8Y@K=84X8voW5Z2+u}_=;7xv;8pzUd!(qM*h7)(WalrXE zbQ$^L9kxXyV;lyjLSrvY4T2cFn$HiGWhQg}g}E{P75&dngq}@4MFCe>_B3^q#BdCPX@xIdJOtgJW?xjd_;;)bgURYpo9e45zN1 zX+-53pkwN0pe+De8E)IKDOY}7{7)nSqmoyso)g7G;R^M9pvtU|(-{cV;l=fn&YQ7m zT2b_OxSf=2Fvs^I;w^ejF;iajF+O2|l(Oy|d|06E!Hz@8fzMo>g%o>m>7h!pUnn`i z{xOJjEc*nGy~hFGCyRjaD5COigt`IupLoRfp6UnE!lV8n7}!6h^EMJ!ch)gG7#Gfd|Ii`q8)0`7&YfQg z--_!%<-sx!P{Q2bss(mZcnVUzTp#eb2YdVrLfy-xun@W~7%RnXGTx4X5-k8@uOrpl zJ@I!Ecy1RQoZhO_BG4!aKlvt0bxgx|7XydFSK>)F>F%Rac(EsgGBBNbAbjYJLx;LP zyqip5_Ye-*eGg-H&3VnZ64woVxevjF-@FY|o)V1L>&R**Tx!E?vY~N}pzFiHsPyAt zDDlDYzy6D#R7u4XOOc|mcICl1f8jp@%sW<_kQ43RDYr>+&rhZBI$tlw2v=9z?|_GC zC7mCJ<}4L4Yy(j_gibmIiPKc#?Ks}RD(@D+_!Ic{lL0?P!Fx^+__aI*G2p8SKeR-M zz6qfse-+Roa4+HiQt**16yJyeS_Ga(`27O!RBkT&oclOb;)j*3`V8F94LB9XNc^5o zEHo#!>BL>25W!ra6MM~x=j%k;vIyoRow&@Lc&bj!F&8vaCvG-l9%utC%HN#$vQFG+ zPJC1+Hk%W->ck9lLBG(6>&=*JbmBU5;&Pq1+MHOe6Kl%(}@}8#Q*tK-QDKIS9PK|w=^2=37xoAmG0{N_ylCVcKbXRf|#%L{hFBQ(+j8# zxrf5%{2VtOAHtptzoz5r8GRG3XvKU{r|b9Yfw3oi9|GR5!i*YSpnJ^q+*!YkoS`4= zhbVZifa6KTx+lBt%vEwGx79 zA-MGVa=aK!Nb@^K;oGRLwQdkD13o=#^FkvApKWmM_}C0wBgT4Wq52NHOFlI$Xs9)l48zB0?WlgPhdlZ*Dk(tC)#vXX~V7;Lab^f+b1kIa6G zPo@I7lk&j^kiR&ECOM^|V|z01oNoml9N_lJcEq9-aHO_{P$=# z;CL!e=4JNb_#h^^q$_+^a2W`wlx=2EXSA z{Sy?wGH(ID?Blr5H$Eja0{nW1SEplZ;O!WGagNE#LloebYw#iRD;+rjzkcwG6~eC} z%ZPMM?J-ckG!;s|mt2)VzBc#`zx_+@YH!Eo=2u-kKCCoD;svCRg1Rmpzg4&RB{W zt8;cS9~Os5T(gyl=&tLK=;~R`Cp+C$EL}`@J-wOKvGajGhwh3PedV*)k~H7RLee}W zmHYOT`;2bShGCgj|z|3W#a3GBc2`okt*s{Zf|@T=|3`(G%(R{a;| zk=D_E|6Ld1_a_Yr_>E^D`^h()eXG%BG3k%?-}iAu745$OMf)#7(f<4XD&2qIUy1(9 zPRC)lW9qf&$a`)vcjWF|W894ybJ>Di{InrPIu{okUVEL;{w^d^JeEM1q?Fe+LM3INWl2{jUwG+s^CX zZF~E7TfK3lg8}nTJsxnpmGLXmg*!Qcfadq_54(V=`os4Y4?(|nNBgfaUrxw-r2od5 zFKd1i_1}T>&&}Xh*_(eXLLKATn|S?qDEvnHZ(@EU{dZ9Lu8+v~bnt6?e&3JZ@O?iq z#@jDqz8twZ;#_rPa?+1^oh;~lcq4U&mqvIK;uPv^pi^#KB)AFjU^T8)WJ9Zv3pXM* zzKngDCy~aR5O*NNDdg58a3Qa^&v^qv{sIrk{r-xl@wsTOff5?QsdCfo(8K z_*Cm-xQgrh$kpjOLTd4`Q%)`U4Oe`Q6&t$m)hPc}KR5IL5qpxgpfB;o@ZYx&{9l1I@?VCq+u05dd0^6muzPHyJmDxK z9sGAs{F(+XMp)KeoMu2X0A;2#jf4|*!ZAjI8wt@XJ|MUNX3MyKBxf->zz8o{P3y&z zV(g!Gk9{@;Tcfyfl6+8JS-$R{3R-Sl7ZFr-(<5B-VvM}{oR>J%-lgoFL-F`Z5P#vn zJh1Z2v%q=WN%9n|uwncnzLHcT~ydM5l0}_pyJ3l62G;jo!)fvChW9`L^&y z7+-t|f$`M+Spc4%#T| z62%BumC-y{{1BG3q1mbsC%0;FNrOa%+6HovuYg+-k8*GwA;$@1?En6%3imW10=_>) z5c+h!#E$`9Zf_{eC(Y|?ZJO7=JOI3>O^{y-GAQt@H}p3Xc&J_AdK_a=MKCJgTdq6@H6N?m4Q#afj#8Xv!w@P3{EwI#S6C~`@5H`+T*gZ zf~Nxx;0ywv0uZJP7l|e7as?Vj&|OA81NdgQ6ZB&}W%?P9)aBOlaUfHx{&34!MUh)f2kK!L^+lx5^Y{i>O+HFn?q0J@~SkB#y^ zQGD(o=>2a?{k(yHNNG1I&~FKP4j^g;>m? zV#h0t5B~y;i9!k2YSE7rF+)g`e=c-(6YEH!10w;fs1iQnFsBm|&^fvDjnS z!%O*0kBf1!!Vo#1s!JLu=f5d_M9%-aM74ArIp3hrM9xnE4RRi>l1`^N-o_-cmVpN% z0t|Y7yhW;UBvEdTkJ748USV5ZBjp=9E$ur;fp-vm*+8&IfqzACu@r!l&H>Uq6JSWQ zomj^T5nShq(f4~HXke_Nyg#^DNg)>FrwXH<7*7I&`aV#apDLN3ORPIIojB5bMxmWT zwChPM=y~u@T5Es67QISJ=%&U`A;y)uq=9m-R9Mun&skwhJB`TlP)KK48VHb%iJ342Pxeu35#9X+^Q^5qh?RlzPZU@s`xSi&|a*l@%p zU$26FbRS^t0`q*j6{G?W@cW^`;{8G-RHHyYF+ke@dRl?L0gz$(TQCxN15c20@m~NA zO*8>V3Gg`q-b7#;fb6jIjDh+W-;+wLAn?BzA&xsb^H#i2(ec0JRd>O`)5;r(zQ8~y z9tx@?`gWq@Ce4Bs535|il3X3)7V6uw>BWoBdb;pEmGdji`90eyi1K*jf9WV@VzGZ z2WmK(N%&iHK@fVrTi|LMRMSOXin9rSRKs_f;Gbf)4|po!cW8L8z}0l&M+*KnxRzr{GQne~j=3fm3opPvvdV$^{6Vt%0=whJFzR))SbofeVakuOvpWcoufj*NnRz zZFn4!OuBg0j~DdioD0yFdN@Z86Fz90U+ za$s~M_z(rT?03S~r?8!&H!oy-?EQ!ftVF@?B5XHc$lm)Ps2mD6_sUg(Z{LsL!|+K6 zknhJpmwbEMgyuJyZ$0t>_ReoL>>dU45Vk_W&PQDGZB#JY@z4SVa~QBr1^X0sIaDSv z&rOI|1a>oPaSiQt;Pp_Z03gi}PGU}i=p&v1^&$$wb{Pj6|-dC~krGF-&+s*G#d7UiPd4CXrY=uSN zriyHZ8Lw1@9{eWEb|#3aZKa&YP}-A7-k5klNkt0Z;nt)3>*%!tq&Nt&xP z&5ISy(_(1O9GvC}q?sO}x$jZXJVVoTDw>bUy2{x5n>9GizS*F8Mug@T(tH+atot7r z2Ax;O(By8+Aa!qzrMZqYJ2cI2E1F-Aq4~|hX`Z6;-+c;M4SMQH^Gr?iD1_mPKhdld z`=At}Gxq>7R7H&L;>V~+ea`7xVFcbzcq!q1&fjXC3Lp6608P4xyakqm+0Yg3xY_#ErrjB-&Fj|2_zYeg`B@qE)?$_py+`yJFiv zA-r4Q-gLJyjaI{Itzza6M5&c>aJ@(v78@-2%M?zKIAtUg^km*j^4JT*=@e=x7X5?G zfTv3_J?VuMoF4S+Z(*L|rwMmxIOP%%H0&f`K=~d~Uh*oLL_`9`mNH7@H$`V z+|oI?i97dRu$pvX`L%EElAgRpyoYkXmhY@`B7xVG;D8Yi^t!^mW=<^Jlue3Y;6|`W zgVO?JD-p~M>4gI1!~+VzO>8e{l}H;3#EUQ7U|!KqZAP|o$%gYq!MrRzjqY`17X;Z- zh`Cy0&X(+sbf&G-Y4aqv@)^zYb_vcFwIvJc3xp~+u9=DKBC%E@ZPL%p`q@oI1bmr1 z`ypaHwCjf)KCIT5>vhg``gx;%Uay~%^z%mjoT8sM>F53Wd9!}rte>~av!A!G;qFoc zc?u0jnz+8cpgX6m`%KnzH()cmC-F)<(gLAU*PT1d*Wg>?Ob<$Mv$m+*C9ah7T{~c<$Sd4)6i$%U}K{Vt{Q^MK}vKId#arQoU0`4hyF z#`VpR(--b-06}eo^f|AN@t)U78^=K#3``Xn?Ib-{PxG13jNqa}mA+RhaL3QpIUfm8 zFDSUe2FEp@Kt*_uEw{I{9q|!YfXadk@rEvQsb}2oMcdt$ zzEx!#zg%TA640u*0Roq9pWuiSxzsZ}_c<>lL#~RQxo=71Z&CyzTChQ0E2#9rK_kfD zBhZU?dwu-wuKK2&D1Z1-TQ4y58-6&T@MvtvT0jTBp2FY_d zKH4N0m){`m1BkwH!UMW*Xoo!F&rtUBTr;*o$u@))E4Rt#EWp!-^hb0$3Lx>{JPZ0Du-6)?wx&e}Q>UyifRrV-EbrnVB>ROUdP9BoeUig;!DD+tw6M8{m zHZWYBbAjOXO>BBqm??$!Faj4n&Sn!=Ifx6}eNGReWDp1Q@M)8er%G4F2VjgisK6)< zNAxr!s^rk;yb7i8*XR8Ae^kut8~+KSVo{)sxPiOf8~8xf@@dzaPmh&yTx;G(1a=7~ z2=C!{6pvxrPsf$s$gP~I+mHRJ>c6IigqmI)nd^=!YPscDh@nv!e|6d4Hi#&~( z?2q(0|A8p02E~G-Q>8Rc57uST zI=z#Wg9a6X#9xR?LE)bmAVxxE(=i9!!$#Y&^2l-@+&sKYDa@n{U0vNGg*}E8J`SA# zbk)QYfdTKzMCit(O8m=>M;bgUkj>K(Wql!*GY~~envv4y{NR-&aWz-goq?uaxd_&i zvsCtraLN|) z;T_uYj_sI%m8GYYb-SSfiHao0rXn}uF}BEY_KMu!6)m!)JHu2*kx9ZjZW>S^g<_+Q zt4sx^m35E9<=RLc`xV)*j#xDGt7D42B1f8vEbo@L&fggiW__4c;)NSD;xZJ)(hxn! z5WjNx>s&y8ADBV#a&`TwXgX5n1+kW3gcmo!TEVNT;StfW%NHhxYlgIrVhWI zG!IXBe4<#<+R73juN;JgkPBF2DMzFN<)%`j!VmBbBasY3;&+d{9!{t5t!Ovk5gsZz zYXa}YAnz>D)l-L5LB8%(Mlfxge44^*2R!6%g8ufa+C?N3Axi?hrU_}UM-H$|>GB8G z^y^Ul_+!W12;7e1NA{t17!$QWB?l%^GD4~dY}9JdB3!*ApJKpO1n?ffU0uI*@%~gA zh?Vq7yaox12JJo2k%G8i^Z5d ziEns%%iW0$bez@Tm1Pb|@CuKWn~a?pWR*+!a#z<6IWOoaUWCd+5=T!J4h=hfFw{zY z6044p;~XHlI-fraN!Z7CvvWG9AWcSHpStpcq{&DEn?O=tQ%}*)UU-fW5%f8;43t3e zNr+;fjSNUZW$8KM9(dFX6k+$M1^~MDuo@-hfvH&76;CH>z)3iU^tTYul{<8AZGMs9 zc6&;ILf7!{tKC-!>>^ycR`2)xTC@*WkJa0G>+uNRi@2EEJ?aExLecmnizfFLvZCm2 z&rwlwe?l631}b8!<>7!LbqyZ)&44vOP9o#j3##bbA^za+QPOb!ku|~sg@+nx<%U0a zT#+;0*T=w;BQO2pmHjSIQ4(2^p5j{b@<=@K-M69|TbU%^@-&H4R*V!on%zmHTM!g&?aWVlb$3F$_{7@csW zkuc8aL#mI#8JI#rXFAaUsR&ZsMv98SjkqcipmYIc-J>H|VyI3Df-EBVE#>=tnRH;_ zXCP60zhhkhWIn=%P@RPFEFlMgil8J_739njP}UZSxHfDnJ8BzUzn@Fj@9ajfjGQGX z*YDfl=rsqe4%a7tMyQK$b=G4<()g~}9pdnv{E5SNM!H9R6IcP~bo|ZSpZPIc^B0m2wJbm$ zPTiD`clZbEb~X|F=~Aq|p%_>we2vc&PsLv#fzRGH0i*6IGf;*%!7y!@2n^4?y>_z)=>c9aw#d7*)6vo9E#=wQUCs@Z8+M4}R*V5{?kJAJ z$k2m`c7BXmEyjbpX(8W!fj^cS}MT`d71$Z*A8Ea@f>F*b- z6lVdDT%C`SFR@#F&TOP`EWmIz8{@#4c$7-g7Q#|fZ#jQAk^|1;n1amot<5;GIj0+y zLO{Uz9K;;s7+k9Tk*+ki%iw%=fVXFJm6LY>Yk^c+>T38!FWb#mE`FSiVmgY$C=J!U zRMw%UMamKm%7%O69YAt*zDSYi>fVnOS(W)bFFcE6_<=_X>wuS8s8Xo&<46Hug9dng zp5G8P;Jldt5OM>`xCkoXT&t6Djly{;;;!Hg$5SR-K@~Hiik;wxW1(sCklV{^==8YX z%rCXjQg{Qe1q#wjd5)D-TC~&a^6n3P9}T5E9502k@)uf(B<#U-7o>xUmmq8Yuu^^% z_OY_-6*xEUb#=axhk~PuC(ezzZ-;448C0kcul$&Ov*&8f%%~{Z4$t*);!%(LynEn* zt_&QeVWNy_2=>#_=-2{!Q(d7ydQN(?v7ZtclP>B>rA&U*)%9K$$~PkfsAX~*;Eb_MAX@5UUsQ&67@csHhU74>I)g2A|RIn71q4=7pmjS{f*Yovhl zbqFXMH~PQ|#sP*ZjG8TRX9cT}`wGtTn-GJ4ux8ezdm_`B4M!!;83LL3RRonq`zr(3 zRJeJ2W#)tORUgh2rYBcqzFrZ$04{TIAmZx0i7N~BmQvtSy}0>wLd*h5hzy#u=!5+E~BPW(Yr_8EBapib=5<@ zf{@V)O_q-KEs)E=4Taw_u&qDBc9=9FDM)-uaI8M0n=Qa$Fd|;GKHr|8QuU+8A893 zhVcBGEOr;a!XV(BOOoBA-j*jU_|<^~l-G?3;eIj$4apFn#avIe3nS{32y%C={lLlm z&ig>7GSCM~1&DcJjmEL1AY-_?$L$iK48M4BBRei8=;LWlcDb0DwFq$r0C0M zK}AQ{Q2~$46*yR!snx;@fzF#1Eco@TV0s4(9$a=$hri<^D)3r~D--8UD4+h08BWJH zavjrM$Cf$ZW1<(%B%WLPB&owi^j^MrvcT235t3n2xi{!26u)fW^zZBld+`eML%;3l)(FVi7yHHpQ6j&P}k%U~5T_Tci#hEDU zNP4U*HwuJm2=*(6Xc&RVQ3wv-wPVX=$SMKeD)Dtj?1`1b=`ox;ZmWQAOx*h$=jtp* zLG0J7ume(-KHD2iKNHgN22ac>50=8|F?QMH5d^wiV72*y8&ZaK-Z{z{5r(1TfaJ#4WMQ%|0B3a*uU0<`DVC=Z0A;gZ$j<4g`DNLj4USABhz2>dJ6>>=O>5C zim0jRs9Ox3V-+N2tC6BWm~*QXAm2j}n)(Pq>@^T2nSQ2K3J|v&Ae9w!ag_qlE(0VH zD0$g0KXG+E{~0F2m=zxcpB=?}AHxXZ>dYUI{wr3}d{T!+T+<56y&e zy^{pHM=83_4h7oEgnU=v z&;drdR`H%JVy~q)?;zYp!D+MWPI#PG-!b4kq2wFEsTnf%kLl#Jj#a>fM9wBhPNS=p z;K-iHh_AE=qr4aG38O0-7a8=Ga>xb~eHDdgQOi$h7b%0e95vowg;e+jFU1EAWH>$W z9HPVFhS=*mcNYq*gg4R5ZjAIFB?pF8;LS(>38mfVe1hj;fphRVgY$;@N0fFWj&By6 zhnWmCwlewA%FM?qlb<8^?#ke~pKxGqmgxkz#Aw|`CYZQvX3&2JB%9TZyT2H&7fp9H zIZ`=Z(^8CrncRk<`N5Xg)DVQB8O_q{U&zM=7>x?g?e=z|Q(+1xs}em3pBEUZhv3kv zNtMBog?b1Eb}&gs;2lI+aXd+Iv|Vs+cNyt`Uo_5)fErj!Xr;?Buu2=w=D>XX-=LVeFk2L07vc9*sw6Nlv%(tz8m>C*ALYFf^3+Eh_?_aoI5rBb109YKQ5o z?ikpLmmWcP&{MxlMMV!dDDI#?!c?Kl0XnX=TVR6WULF1KgUZ0G^sAW?Fa@mC5f^6utSKSI}YH-OlU5mU2mp4&_>X?I=8A)c!6)oW|hgNBW1JBOSAN z(Ie777fayT`!H<3b0+e$H5H}Me`X{*BWGP%2W2U?GI4OYTag(QqFzh(P^k6wlNcX_-=ZavC` zgcs+e)ldzH2HTK$i+Y1tI*@Nh#WVZp4w|Rs>Lm#v7NAmq)-u4S+!44|b2YGzzAq>& zoVdEy`~?vVP(+q?5%8_p|p;2BOhorcA#&UcI$(sbF(CgdpJ*m@(qpt&V`vbIn+g;&>gPTe})L@ zXL^~d=M$l^!6@Ycqe?-AQ+Ai?lv)1?t{2Ok-ZwDO5@^?vUpYu`R@rN5rk6;bs3**xe z*wlhTrnoviZsd$^Y~hQH6$d`W@&Nm(eO+(KK^ZQMFx!W4v7)kJ1Hl=S4Mv>#KC39& zfp2;BV&N3hWMdm6&ZMY0^kbz=jj&zXluv;$1V zsC-0?FX#c1rXg^%7#Mpd9*}lo1bgBrrUXX42+_H^+^66nfs8Olq~U9GF`uK05eD`r zu#<3uz9frk^GfY%@D#HX%a84$_MPeNfVjGb_pkW7Ze);(PX}kN&db0O{ZwHCXJQq3 z?Q>2-psMaj=O-(r4D3H6SwsNy$4&^$F**s?8cY&7S*Jp{uc6uySrSqpozV#5RFGQ2 z%~34@)5qNmT~Hf@rO8l;IXHkrLycos1>+(UY!p^tPX{gtD_mvxhAP(2N3++1tjv*_ zitDnW4=8@AdmlJ~duJRO>C+bZCS?k$bQd7ph33{$nto=j%ex_rz{L9iM(R%yFjcI> z0%aYXpY=**e+ZbQR~uGCAz;zQ6v!cc#G#qg~V6GvY(-nRNG@~^{%Cl5VkadI6h(pYcOa%AygnN!{1Gqm(moIU+ z50UE_?#Gh*hr~mSY9h1{9WdU`cEvC?1ooGF6mU={)#tcf!JnDh8pUjVE`7ttoc?_BEC-ZB# zng-J)!gK?l`ZL}6LVTI;9l-Q0CxGd>Ku0MYyR{GTeK<0r5Ao`k=tKNrJOLK*A$}Qp zEq~$p0GEMdj`XhJO-Dpdyj*L(`5&2DkY>06aqg)s!-KdQ--pcNYMd!_HNJp#=?edY znp^C<7m0jlZzXy|hz{tHI1>Xgdi8X`_!Icmgl|*u?E3}&H5sop{1w7)QSddr0_U6B z{7L?OgkP)RzegQG-`6W(1%H9?DuH*ZUe@Ql4tV^*A}R0Ur5Y~!Y$Rss#C@!vk$9|5 zlvXejhv`JoCkz0cjYlKPwcFKOFn!VY+QWOrd|W$7LcFwgN~xg zz`<}85^*#{FW0 zFwLP8yh9|YxsHdkUXw{+4jL=jwPr3D#WyGJmURIqhS-*N{uhs!`l&})`qfYs^g1et z>{{~~ql5E7;1U0?%r8xaYLYknCc7Dr97^4$L7zyKa!drJih1Zlh zAhT}g-oF{UX86*^SMY!{y4xivz5{`5&H(K$Njm8mCUs9F9wBZ(j@5B2keo(3E}S|K zpja&YyU--q&UNQ7pA`@Vy%y&2X)K9QKB(ZdcD)Sch)~QH=Za*X=FZ zk9|K^PbyXp-lBu9wV|UJ+3V`LACdB+5KagYL96R)c#nwW(8?+@+HtMyM-?4x+fu>P zfaJ%#$xl?`RgbPJ4Bn{X$LM?9K`&RI^k6@LZtVgK93Hq~r(PI0~CToQ(4`yA@?KDi^Qsko^vP*|G0X|?+itk;?rbfq32&WyDqi7e6rTf3{R!Xyd-RFqru|&*I$S8zb^6EqZgM zyCOIjTl$dNgQ=9!$F8+=($Gxut&g)%jQZ9`WzjRPo>Ktu7QO50`3%<-<$hPk)OE0u z4xsT{A8g;1r^_ckdV%4^*Y0}GB2`QX-3pcdN-X7i?nb1d=u_9)8xY~$ag9C2>hZ|@{_JXwV?_WQ32pjFR9oT^24Y0t+xI&IW z0++6^Gr`+hf&CaL)?SA+d~5wL%4Ug;gWcK)IDg^q0PI!!P}qSA|81WPGb^^DAPzJC z0pFpkWvDHF4ZRq{z-55(C-C18ehJ_m#m{5SpA7gtK;zHV6@*QEV!i>KO!Q1It}k7S zwBtGX!^_+6quYbfy)z9$q~1sBQ9=f7lpUe@7vwX&xPBpN?j$YH+^A^Q#n9X}IL(Em znJ$%}gUJb`*`jHB70t0RG#?tAW-4i(5uy3NHK2L2rg@O_s-SaQrMd184^H!Luns^a*kIj}ROd8gs55i;S%YRVNuM;|Pw>$y50Z?Xo$4FSG z6ZRMhHy}Z;*?VQa5{f1~APMd0UE$PS=H_@4xphq^pKorC>j$rCjw`07PxqjvB}ij) z9FMT9d;EBi&wVJc3r22$3d$p=%#Xsu$c371N2l5kvS{4!*omQe|91|ATVS#y+NW&nZuZ)s z^VSNZQ4Bk1>LZ3d>~oIatVX8L1`H*Tzv0s1H{EEH+f`cVdW7Ngv7(adoza=j>9EPi zBR68h$B>o40dL^M^w7VU5nD<*7--Hyzg4?GCt|webmK8*WGxTi%o4bA(+OK<(Q($z z6VxiL{{S%?1JCJFoz~wnRW10J;l4ATg!Vgkabw@NRmZ9Ju`2pXn;p-&7 zs`zXLe~$328oplOsy#MdBK+M&_zmFz8u>B<9KcQiEL51oee%Ax8cCiqm6tUp5{qU4~Ii!h(-+-UHurgN(Q3!K;~f9 z*v=5!zbb*loPrpU%bn*53LqPGo;*pw+Z!qYklO%>4t!ZRNP?8JN#{AjD2E9+DBx6I z5N=lpo#`raxpVI-4cRP^EPR=gS=5^wu*b)gQ5b5L8#*%u#wjO>DIDt4J0ZJiNGlI+ zks>0WfuE!kxuA$7p2|cFmG2zM9L}xN-o5@58@YttOz0TmnQX@@e8c0vvUDEnIb(DI=Z$boD}1*h|b=eHkY z`%@;ZJK=32eC`LF_2IH!jHr)6j{?0b>p|cj!&yMQmi1pQSTl&lYmTN~7d{4$y4O7o z`y1j$BH_AIRRJ#jVk?156BhB1SBm%nvAzkc1Ui1JLc5Y^rvt45FMOi@(9g)|QoM+4 zjuPN5s14tL4iP?w!l1XnBPQt zMe!_@9-5?b1%WK3eNW~3TODA>D_9u)OJHX!PVQtk`i#9bICid)?=%JbAz?2o*meVU zgn}(4Y$sr_l;aef%5OKi2%~s48I`Cq3{bhJH*j{cqF!z@c1rwmV#q1tJ2K; zLFIUlmEfH@z;?~kupcSdGlb1mu#XmK*m4ECo3J95^j7#ZEUsc+pCRFv*NZRr2>HmEBVd_)8pv`0*eDm03gB4uKV4holhnfOrdK6oM*^Qh1NC zjGqx^l%Z#5L5yLb^A}3#JCfHk3=)hs=^U2eGv^F?a?9QP{i` zN5q)YKo|I@>W`n`k}`ZSq&#?N{PvAF-5tME{_c{$56j<2^%isO-_dWUhzWn`A{vMRSAIslQ zs!FlfTEv-!by{tMYf8{5@X&o`}ER;7ND< z97FhphsOU5;W|hYi$^{b>XKV{&n;82o zV-GO4k+FX<_G89AVhmq6IaE6~8L{ga%VumDW9Ko}$XE?y)r_rT>=MR)&e&|mxJe#9 zm$82_HkGj>(51t9jGe()24fd7b~0nj85_gct&ELe>;cA-7~`f&_`}Z-`;@Ua8T-m` z#9n6XOvd&y_6^1!W9(wawllVfvAY>-Wo$EJs~GzgV?B&*VC*Kwe!$o-8C%WR9~oQ8 z*aM9D8GC}UD;VQkJG_9gcNn{fu}>KDGB(nI*g1?H$5Y8Ql3FGUl zC%BsyxvT3MY8qSXni}1?e5`6|sao!yP`!MDdtps|(^5D7*R;47HnlZY6OL?XDE>a1N?hFWb3jSxt$Tz<*Cx#Dm znMAbJo=Xm=Tv3Qf!`d!a#HRJAzR6crKZL?jA49JSa$?)tcKK#Ku3cEwVzcUza`R#p z`moA{o>eVuT2kX~Yi^F;eWLZ8WL?iv>5-}fHq^B?RQY|i?nO;433{#}aVpc95oI#T zb#k7^QlAVtOfD#}#v2-6wG%|YqbwQacnYlb%)pye5ZfOQt6dse7Y}A|BIQl`qRO+@ z1Y7;LZmESr864+F8?36irKwu%k^wB36lu*U(6;>;d^oUYhd{?#8aC}&inv8*QBHiJGnm(3XDrTYMHR6QMsjIuu3d zM}g7)5(gNEZ6z<8{Gs0_)SL(lrlE2m3x!tv6@E_s>TSud$Vz@iR{RxxUjFRJFE7V} zzq}j^{_=8$&YzIe^MqF4vPBj>(P-d2&*X>|i!`uOqr~=SU^xjDiKJ}lqvH4Q=*04K zHR_#^PPE>IL$9}a9@OfyEXT6mW_~f5scWikwZ(FDS`*V$w&Xi_If>iJ%X=_r%pjDW0-&3>)RNvJGVbfjc$&suESv&o0ijswfFV%J_j z8H8U;`I+@s(K$SR%H(-!5aiUFBa|Q@6O* zjxo!(T21F$%nXcCD}QplRYAgbHrovop9u#E(Q=!5?rXARRr3p_kHwk~Tl_XQwKQ1R zC)@3#=p?j15y=+Dk!%E56lY~)01K>^&;>bh%zZRxoHFg&8Iga&mW&jUXH|Y){PImZ z@_BJ8ZqFX5emppX`Ek}@5$;X*nb1aoak^m?7-!6k0<9!u+G38wkd=fAtRz%mB_WTMggkME!bnw2 z+qna|jkl2+&1oeekClWbS>>D*N5O3Oe;Ft394$s_5pTQEwjHg;nckpQ)RSwWXP#V( zX7$9gMF!`dcy=HHEU?fsk5!v{tlHc&$wEUtljGErD;kOuJNN#YhGxIp-{dZvQR?;1 znvM_Dx!W4C5W(RnPk$$jZ=Dd?;P=EEdN@5XVZ@Of7h+M2c>BzpdYdrfbPaB5nlR#6 z5N;zTacyowi&OU&q8VFaCe%3E&yA=gu40m8E6Ic$ryt4gOp@LkOlnzb!j98->df#s zT7fY$iQ|%qN}NVs>QAcnx74&IMW#$i)k{oS;Ne- zX$>6Om=NL!*Wa?(gb+sr{(2LI+&HGxUvHuiuRGhEA68imztT&hvy926bDGw+mPOF) z=Aud2xP+^Iw#Ivum(V=*E3Yso+Ukd09`1D{oL=-RZ*p$5AwExecI!9UH0g_1o?$sB znPzvEcm>g(X^r;<)Dw4j=y;@N`~A$xl!8{kM9UxUbKJ4 z!?VR#OKp>FzVf4{EnayMzD)B_E4*BjA+*FZO?s{H%!ifn@NCJ$hmJc)gB$hCGnv1` zF3)OHwx6BIGu_kqJmn2iJ)7${`~5J_G|4(_zO7Ev`^(96ZWph-Nc)*4-|_Hl=}X;` znwCLqy-{BN7cs8r@)EXToQg!s&yP+S;-Ez)2Ko8+>`%UF8EZ*zkntg*oP}L|e%9FP z$04(&={M?GI62Dy^s4#`F=aT>~B%!=|AYOY!@uL0Q5-%sZ zQnSX3t|Tn+a-;KRYrN<@!V=H4=C{N%?Gakz*_5BjURlyJZEsoQ*_4ZEU(1T#WRJb} zm~7g4vZQCaB4Ldeo#$KQeF64&NlpD=hRV=)kLeI09$yLjq1i5~@+>=ILON!9Z-eh4 z(6QtvQh(FNUA+27@uKT5D?IZCg*Bc%J2T02=xRyNv;k;|muItF)6G~*dZzV-C7x+( z*%EJ(Jv%eWbkE4?5DCjO z*AI3TCk&Po*CEicw5ti}nCt&}_!&sYk{?5lahcz;-6D7e)*ZuE{h9}pc65I>x4`s* z)KJs79vt!zG-7FPI*y0(*Z#oJX?G%!M3Pnua4?jp82xb;g;80(>Nb{o_xE- z&fzEpY}7Y5-+H~2u)dPbc&}mTl=NG=i{$z6x$M6Lb~Su{(nW6 za#+$ll;$(42U-N%OSK1fv7}#YtrvHip z%4M@S<|A>v2DIz~M z7Cql$tG8fe+>Y{ZIju{qmuCJUF5K6)D+2a{UB~T(Qa548?~>dyW&GC*Idtt zehj7D=sD?Om%D`5;qBG4D8Xzpq29!otJOPoG5V8eS)H)F`0})0p5z~BMs1b1q}8?@ zO|L@4G@H$Ga6Q;wdzmh4#gt?87t^ai@!<*N5y_uG{cP0(m$U|}$PnmQ&a@4FCnYdP z5qJXqj=&SF&LZ#x+t(3zf@!v`dNwbyJvWGyH`Mkq_tznmXN!N|;vw^Iy3`t1KNB4* zB;?0jKkReZoi`ZrOthVquspLp8bW#Y=+WMM&Uue{{x<~v40+@gnhxG$T1d=zWPHpk zwBARF(#uO=ar)D<-q5rqzm~;=dag0}$}P0s@U&T;?ePKSC9p)Xa>y+--4C{qKkyP* zE=4aP|K|R}^L{uOvNE($c_r$ZLod&2q)W)Rx!>8~dnk0Q_=(ov`amU$XS%3k*?y*% zzAW)fFS%OdeSUqweS<;NA=3YI3lDQ&-mHJBJS*|rTTj^F+m=4q;3wM7)(2A&ydsn1 z5v%qqvOf5U(zD*jG~p$fx%9I)Mb-yIQF`|5cy5vD;-zJMtq(Gz<$4nAWB0Fz$MT{^ zlwP74bbop_`(2UA_l{+K3oZMn!CzjEJ$ks$X*r%G)OU0LTU0&RYl)Hmo|kKSc|A@& z?U!fS-R<>v8+<3^$2^V*9cz9f?UHMKu3^Hn)z0~Y>}weG@=f>OuG9)UhX8D=a7@EFH#xx&7G9U&Tvw~ z^A~wviVoE9%9Qbz6e2A(Rn^NQ3Dxc;RV{T@3*mND-k*x{n`3<;qg1_jMUSUTo7(ED zwc9m!Lrp_d%X0WMZK(4n;hvrrznN}=m8!z5X!O@ChOb9>eQa4ommYZ~3Ys(N2r zeU)FTQ(NP%YJewIKb<-0@=SH?XFqeTFJ##2pM0r`mvyat=je(Km7aC4x418Bwx7mJ zVir^Ah~DH{pL3h=EIX75&vIN$C=WCL>U_fPl2asII=J7=cqJtC=b4+EEBFI<=nTEI z;qMpw8o1zUYvCM~pS1zDCBGq*Ym1&fFS1(~O2||n%lTfy^3CI6^Ab7&9I6~G4ST|J z%~~>qa&6I5agn&oM~Tw=!7J1<9SFwjn7(VE1C ztDr~al$S`4W%I<0mw;}6de(A}v`?P3oT7N9chWzPJO_E7$#%O8@+w_II{o$PaQTTt z$7+rem812A+bEvNyKEeJoA4~>i6%UI{X5Tk;-65i=6<96gjsDb*nB-zTPaS-oXqJ$#sb)Uj zdXG*M6Y_1&1uJQn?}YTsdNu@lQ8^5UV+JRe+<0= zc$V{hqrQ2Aym(;3v+mFOdnur2x$cb8vtD1B@NCv2(R`+#Ts+qHFj}tl1=%QGfvxc{ z&tp$t@+R3k56GKjZ@(RQV!;N^3;W4slFfS9+y~1W6sPNAyMa#kf_61T>l?Q$X9GGth*W? zMQUuyrreg`OG!;Ft@7m?fx262n(&%K)8Zz$(yF@}TdYlunZj4y}BB^R;X5Ky(sr@rGfSa~X|ltx1C(g}oqC3 zG+i`J>&n4xNs@b)b$K?4dJHbT4!R5g%r%uXoopHnlCT&2le>EsxWu8HW%cP~yhZt}shjjK&^^4D*^dWyO%4(?c z)$$u|F+Y|BrH&Y_Se_DOo*reVwWg+_m1j2#Yw)+pU0>CLkDKv}RsG9kNpKZp-$;Fx4$`FK=qYck*Bzsv4KO7q;mWCiwu6`hMP}bY3#2 zsi7&mt}&y!W>HmJy+8BYQ!+$nO|S@ypC>|_2rq=RVrZ+TW{BL+_AtIj)Kp)cQI(&Q z+0ay7Q}1qSsassvIE5!!{>auTLh-29Lwwl%{b80cusfE(O7*0X7uDY$N{@l8jR)01;CmIP}OpEx8BI_D` z=;CNxXiW>sTkc-ef)0hcX0$dVYS?KtXcfEjv$Q3l^-RvBg}0=vS##&io;$~Vq5Gm4aQay>=VEv19CyW>85fk! zshBm>08@nK^bGh(6V4?9hBGf}oiF_-8{(?JaCxJa->f!2+RHtMd`9|*>S*ZCF`1-+ zHGW+q+KygFp%Iv^49uC~fnW+UE0ub(Fs0C1m#H8Z%#NeuQ)sd4-SEn(esNKt-Ev3{ z-<)yb(EJF3reg$Uh#bO4PK_V!m+_xzrwE`ObN2Q_Nl9DIdEQk~l9W_1Jt?Ud;nmE3 zzo6g`^VK!r8+kA#C=%KP&P9=>>%rqB(kEhO=Dxb7r3qsfzJB_x(hFu*%sg+(Q1d}e z79o2TJ32~X3%SY195n!AB&cy$qYcq$yfqMMkgJ<8Fayt5)z(U(x748F&|UgjM7qaB zI=VxaQb*FiqOGABd9qnfgm%-FB*SqyV#>tQRAJ1mUqsuDuc#*_Ev>D?2PQG-&pMxj z7RH1YTwB2Zh=GMlRAnbsux}`qqC7AkM-hk?14}~|=$%*N$72nQieD;U40;t!0-d|hQ=+29<#v=6i2p-!SeVC-VGjfZ) znEw`EAVU_Wh;9f5U#kL$mA*2ot~IN!rr77p@?rhr_T_T)EOuAJ6fDfb3svrn>Wl{T z=FDP_?JZaa)h))XvL-X5U{S6o+mq?`Wz=P6)fMMvUFpu4ISXEV8}O}MG#?C@Uz@9a z(u;Gnar%jGygcdnY46tld-b0WzH)Z(tv_!(uyga- zz$dt9@yZ71W{Yf~33S~P7&bT~7- z7f*5HBZnAZFZzxG z4Rqr38!cVR!RH&Ldbl4yMEt8SY-(%q;oHb&{?sQSIlK(yw6z73eAMOh)$G)ynN3(I zpx^kh3~|eHgB{B4U)nTLW*PYC@N#IbU%u%LIruU9UWsv`ic>r3#KL72?nHr4_Bi1+ zTkMt(UwMYO7YPA&`ZlaOuB@qFuIBw9msI8E97GV5WkMeZ;)QcAm^Je}@5PYk^jVda zGiH{}plL?=WR+9os_H8+bCwb#Ge#*3z!p&kh2KQ8f@Ky_L3mM1Q-iz7=WA=>$2YSF zZP!@6h1tbkGk=4%?|^*jm^pqvt!nN?4VW(ERckHcfwLLktoH+QfHQrDUs95klvaA| zU!N%azUzpRCtqxy_UthiOuPB=z}cNQKRUJG)~BW&``35RzWd5RvE#L#v%cwlvGCbr z_Dp+g)XZss7a#lAtESy}>ddnNoBF4BMob~h{GT+<|C!JHpES(>S-$x{c`^SdU*`Yh z(fptMnE#W1^MCSc{!hNm|5*p~|1r{f7~8MDASroST5{URBU9F4pr>}7i2u$1{GS-W zQ=A&nF$$5?wCjgCj$~wCvZGBB9Go5OOighdp^~pxJ4f|+s>c8Fmld7M9C+YQ@P!UD zrjF|vt_b!fJ9Z*rMCv$=p@I~L3#mstJebQ2gptJ2_^--(3Sr@^s=P-D;!jiS80H`c zsk0q5fQ(2@Gsv@kM>~$eUsEFMdbHz=*hDF8D$=GRw(&JpPC2X1pW`d|le&Mn<9dcE zs#17tMFAu5EF_bX63M+9G%5G>Zz;MZEQmh`<(Zncc9@EcTQgim+(CyUg`kWcr>aZN z^+%{kVaJhLrehpiAh**QsawZs{nz0x9q!iQULEe! zVMvGj$EhkE)X(k5DLSilxK4-bb+}Q7n{>EYhg)^ntHWJ7+^xgCI^3tjkPi3j@SqOc zkJshvaGeg9EA9j~Oe`FO{43IuYPe43Jj2(ee!2Xc^S$YCV$;>bZ13vv)6 z|NpTZ3Uoa)Ac&#aA7!^Hkbh|Tqysr_OpBGP$kQZOd4^mignmhA(l2?2TqT5lNeKOt z5c(w{^h?4x`ZZeBJ1HIEW#~immWjDK^mRPTPib(PGVCb{`+EJI^3_rgF0;gisO7te^S9mFUlX9T$R4Q zOuoVYLtileqMsK0i(-I(@(uoz*k60laGTy$?K7SRjK6;E8*(~M04Op)qn>U@zK#D= z`RLjogX!r;hvT6k&v!(gNgGhu9Q3>1VV_FJyN$f?r}~}SaSGy*`JU3* z3ku;_d0wx>jmeHPktwxVO)~B0%9LFAgWo-9%`NDT z>xL`&Uc{L>f6?~lgkRgjy14tMErw+{E} za9@fekN7CB`!MsJg(?iCJdqvBs~%!`Mn2lyp_FITZ}nm3s~TcHo+DD8^+U{O)NkHl z=HqxY6uIc~lAc2Q`Oz(MzM}MZ(!g;wqQ5dA*%?Yh@ko(&26$?$zPG z;SO$2rXt@=sfSMQ)uBbcNje{gPnJh>mTDuPSb~tIk7chsAJk#HLt74qp658!<^lLS z74(PJFJ-)UT&MYya%}K-3Gq>0`4ID|b{(GNMLzFQn4cV{+Vy;z2mbWq8zCz%8?M|AX`!@%8_T3 zBX}rBLX;yR$|)iq%E{zB4&|_REJt>WP!3c8^CQg<%8_T3!+ybhL59dD>BvXzPqoN* zoXVGQ-oFCy6Y;-&nri3QSaJS_*3PPW$&Le%!-!N{8xU%qejAF~fdBiatMVIZ4f#_o z%6%?7dN1YgOLn{u`5Wc$OjR3Jk6;?bW_c7_i3}gZWRl_Im{zgbj&_Vikeagdkw+hU z+#%L@U-I=w^f-f#HN)2u6Fc%b7=N~3ZnR#1Nw!_6+d@y!pYy~;Rox* zU!smf;|CeQ&vyKM1^mqWuHq*&aGogAh_RodSr+oycZA~%s44kjt?lWx*iXk4;2&;1 zZikI*ze&|&7}o*(eIB`PKFaY|7@EW2=P=gqQh!;y`ysSlx2t-b8W|s@8Q8C7x)akL zk`mJ%V&--acl;B%*k7a>toNarMX!|X*dY-v)}jd0!Fu_fir+3)gTK!s_l?6G!$IdT zpA`eMb2M1UjaSZWkpX&twy7mNKsB+V5Wr?oh26`fxpiqC+tV=fMpz-oYeS{ zj-p>6=hHru_4lJxFaC^m^e!Z%rbzp85Z+X(@Y?Ly2T|1+eWbC8?k~eW+&FTmd@FlJ zIo<$%)?cXjnKzb9<7XvD>ZF|SNH-X`uI)X_aR%CTXmTViWzW;m)U~yWpRO-RKEFOp z`P>7pwveBz6+e3h_Q%M&Nt%i4roq~){Yb|Tb$?V6RLXB{PpDklo($nQ>=iV#AEs#a zD#icFH-Zd*R_!~GfA;aHzO6gO@dM5q*Po)ad!r6FouVqT`4lxT+^WOgQ`Ee3mkxKI zqUN8VlR?7&AJdVE(qYu=@84GXZ@+!1SVucTIA9!Fzft}8HUyVJ6MM&~efN{SAje;v zc9!lNqo6+n=HYVBu~CQ1baA&{{8)#MKdACkbvRCkr|B?Dhm&+zqQh_KaE=Zy*I}&=TXeWWhu7e9k%dM_%5$o1F8`%^X|PoxFWM602D^*Vb_&JS*ne3S_rB ztVnw)l!M$V*7n)j1sS9zvnKEJRMlG!*!ol&ZzAV1aqEJuWra%M=PzN>!xpQ?TJW2k z?TTe^@Q~=G>eDEm#;kK*JEvdcY(Zax|IKK$ztU+;C6SkV8#=SeXkWvpG33Nz?r85B z^rO9$eP5WVzJJ54*$TU3WV+2O+FutUSre(uG2LN>rO12dt3e@~T=gQ0z1`90)8R&) zk+TWUqv|_%CQjD&WLp>GNyg4tUz#EBXGmqWW`IEy1$nL&s~Ea6F@0tf8F>E#G#`}b z+Nz`hiIz!6^AI!dGm_Gm=di|DPiJ}|H{C0UD~7Smm`*LwE%!6hP>nK|0kJJ5rB)cox=}+QzR?Z++v?P$F#{wO+BiM;I z>|iiMi<+<#Mv~rWB7e_39En)x{N9*C<~c7*O3@Y{M+_*`nMyBIwA|;UdKDFXNm}X4 zq7OwIeK9)fOJJ>{cl`k>oKFENeFeMuWO~{Zt@qv5uIM-`E`y@-O`-sA?tx6j`H7gq zMhJ?LKJejkKq8%9idahf0`Wwuqdk$L3~w-{QJ_gzNlgT$lc(>(99^tZQQJ zHn`)1Y0l49^l|`Ohj1SDjBhD=Ensp;75%PhVG^mEz1 zLyT4iozwy(Jmcx=V7p_4j|Y+TjtgN!&>T5>z6mCDpow?Je>#d;EeUZ?_il5{E*r+}Smm zI$tb==veH3Fhd*a3)EE;Uw)0^A98($7ubu zCfrAB!$Df5P1mp~q`!r92-2dKt{3TENZ$?PlA+hav=8b*t=_EF8G1iVMzp zqLHve?=@4PpYCn$qm9iO+6&6iBRCL`HPgE0APwmT+jTw6&7l50)Z3eBH`IHyVy~`W zVKwIWI{Lz`#Z=bPH${3F(vKkBuchzkx}xhtY!S%O{Sh337a~bI5aDiq9qFSjc;?XB z2n|MpbXZ#-WornZi_i`Tt6F$M3;XF+w0Q&4lUh0=(u0sLit@~>5r;mB&-8I@ z>jBiPzCY^F$|$Yo_ed)Wx_(I4t8~3a*TbmEpQ9a7%$To}Czw0vl_5 ze~r=yEF9Frjk?}sR3lMZ)B@F0TDW-vmcC-N(p(Od#|`&Y0_AW%P~GJ(PAE2&uPRL} zom2AV1C@)1$CpFpmcqBIk?MKn=vw?^_+RbVm^(Ndy%pO{r+k|Sb7jP*2f0YNe2HH(PmcA4<%ZFW&c;k;UKrH+ z+k`7$HT(-^#Na0V$nY{|-23%|pBR1^d=3V^K=hl0za;#E@I>LagvSdX5gsS}xp1@a z1k9ED4+>8fCgB;vBR87)%o08++%9}VxL3F;JRp2jc(w3h;jO}lg!c$ng!c)*BYZ@7 zzwjyHH-#tQ4dd5S7M?8pitv@fdxftT-XlC$cvv_qyj^&y@R0Co;b(=n2$zI+3vU+w zv+$ts--Xu;pAs$#Pr#Xe4(B$@`7l{Hf3tZ%u42aPT_g6hgjWgA6@Ex~zHmW!neYnX zHOxGo^uJX&|6?=W?wVfst(yKOqd!v93-ca1++SYKr*m<|@_YwmJX{8v7Yol2&I?~J ze21`N#(O>miOKjwIpNBK=6WnJV;Pt!<2@<*^ireWRpXt8-xi*N#fSSl&W!o>$#@a0 zEIeL%o4KAZ63#C&_E&4>d#B8NW{ZCIPYurz9v(35JB249fu6@p*Z73tyl~}ZW4~Ou zfY-$Ke7_CPr-XHx`BC9CZop^8XECj(7ft(TglAu2`o||OtuG_-o9$ny*#q@>*=An5dtWd+KwQ0_y)W9I+k+$WKm^_}Z} z2UsUUCGv|q~LjI_(EFOOo7J&?zS}*;CTmHhso49zHP@+ab1HKJ7~GxzQn^zg=3g(QluY!b$eo z?IChJWbAVpGmew&_YiqB?RPiLcnq8I=r8A%1AB?g)gZ~I3FApTd*2+=yw7E6xVslIDPCBT@eo-BTS6UO#I!)vK#G_>^P(zRJ;lUtSQk`*qC1jCGRTzi^S7 zCvcdWC;T_b{$Kpj-eBbzpRtP9U9{}j*DhKm+qS_vF3wtIoYrut!$Yl-;+a*vkvP1i z@RqaJ(sDW~vl}4Pn5cHVD%r1(MGY=kl^u1wD(xsA8nRqe}dj!%3bovbwM#IA#J)^+=NmF)3`Oj6S&TB3E$w EKQ|U-F8}}l diff --git a/srcsmooth/Makefile b/srcsmooth/Makefile deleted file mode 100644 index 06cdfb2..0000000 --- a/srcsmooth/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -CMD = DSurfTomo -FC = gfortran -FFLAGS = -O3 -ffixed-line-length-none -ffloat-store\ - -W -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 -all:$(CMD) -$(CMD):$(OBJS) - $(FC) -fopenmp $^ -o $@ -CalSurfG.o:CalSurfG.f90 - $(FC) -fopenmp $(FFLAGS) -c $< -o $@ -%.o: %.f90 - $(FC) $(FFLAGS) -c $(@F:.o=.f90) -o $@ -%.o: %.f - $(FC) $(FFLAGS) -c $(@F:.o=.f) -o $@ -clean: - rm *.o *.mod $(CMD) diff --git a/srcsmooth/aprod.f90 b/srcsmooth/aprod.f90 deleted file mode 100644 index 5e17045..0000000 --- a/srcsmooth/aprod.f90 +++ /dev/null @@ -1,60 +0,0 @@ -!c--- This file is from hypoDD by Felix Waldhauser --------- -!c-------------------------Modified by Haijiang Zhang------- -!c Multiply a matrix by a vector -!c Version for use with sparse matrix specified by -!c output of subroutine sparse for use with LSQR - - subroutine aprod(mode, m, n, x, y, leniw, lenrw, iw, rw) - - implicit none - -!c Parameters: - integer mode ! ==1: Compute y = y + a*x - ! y is altered without changing x - ! ==2: Compute x = x + a(transpose)*y - ! x is altered without changing y - integer m, n ! Row and column dimensions of a - real x(n), y(m) ! Input vectors - integer :: leniw - integer lenrw - integer iw(leniw) ! Integer work vector containing: - ! iw[1] Number of non-zero elements in a - ! iw[2:iw[1]+1] Row indices of non-zero elements - ! iw[iw[1]+2:2*iw[1]+1] Column indices - real rw(lenrw) ! [1..iw[1]] Non-zero elements of a - -!c Local variables: - integer i1 - integer j1 - integer k - integer kk - -!c set the ranges the indices in vector iw - - kk=iw(1) - i1=1 - j1=kk+1 - -!c main iteration loop - - do k = 1,kk - - if (mode.eq.1) then - -!c compute y = y + a*x - - y(iw(i1+k)) = y(iw(i1+k)) + rw(k)*x(iw(j1+k)) - - else - -!c compute x = x + a(transpose)*y - - x(iw(j1+k)) = x(iw(j1+k)) + rw(k)*y(iw(i1+k)) - - endif - enddo - -! 100 continue - - return - end diff --git a/srcsmooth/delsph.f90 b/srcsmooth/delsph.f90 deleted file mode 100644 index c9f7170..0000000 --- a/srcsmooth/delsph.f90 +++ /dev/null @@ -1,28 +0,0 @@ -subroutine delsph(flat1,flon1,flat2,flon2,del) -implicit none -real,parameter:: R=6371.0 -REAL,parameter:: pi=3.1415926535898 -real flat1,flat2 -real flon1,flon2 -real del - -real dlat -real dlon -real lat1 -real lat2 -real a -real c - - -!dlat=(flat2-flat1)*pi/180 -!dlon=(flon2-flon1)*pi/180 -!lat1=flat1*pi/180 -!lat2=flat2*pi/180 -dlat=flat2-flat1 -dlon=flon2-flon1 -lat1=pi/2-flat1 -lat2=pi/2-flat2 -a=sin(dlat/2)*sin(dlat/2)+sin(dlon/2)*sin(dlon/2)*cos(lat1)*cos(lat2) -c=2*atan2(sqrt(a),sqrt(1-a)) -del=R*c -end subroutine diff --git a/srcsmooth/gaussian.f90 b/srcsmooth/gaussian.f90 deleted file mode 100644 index 4cb5775..0000000 --- a/srcsmooth/gaussian.f90 +++ /dev/null @@ -1,31 +0,0 @@ - real function gaussian() - implicit none -! real rd - - real x1,x2,w,y1 - real y2 - real n1,n2 - integer use_last - integer ii,jj - - use_last=0 - y2=0 - w=2.0 - if(use_last.ne.0) then - y1=y2 - use_last=0 - else - do while (w.ge.1.0) - call random_number(n1) - call random_number(n2) - x1=2.0*n1-1.0 - x2=2.0*n2-1.0 - w = x1 * x1 + x2 * x2 - enddo - w=((-2.0*log(w))/w)**0.5 - y1=x1*w - y2=x2*w - use_last=1 - endif - gaussian=y1 - end function diff --git a/srcsmooth/lsmrDataModule.f90 b/srcsmooth/lsmrDataModule.f90 deleted file mode 100644 index fb94f29..0000000 --- a/srcsmooth/lsmrDataModule.f90 +++ /dev/null @@ -1,24 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File lsmrDataModule.f90 -! -! Defines real(dp) and a few constants for use in other modules. -! -! 24 Oct 2007: Allows floating-point precision dp to be defined -! in exactly one place (here). Note that we need -! use lsmrDataModule -! at the beginning of modules AND inside interfaces. -! zero and one are not currently used by LSMR, -! but this shows how they should be declared -! by a user routine that does need them. -! 16 Jul 2010: LSMR version derived from LSQR equivalent. -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module lsmrDataModule - - implicit none - - intrinsic :: selected_real_kind - integer, parameter, public :: dp = selected_real_kind(4) - real(dp), parameter, public :: zero = 0.0_dp, one = 1.0_dp - -end module lsmrDataModule diff --git a/srcsmooth/lsmrModule.f90 b/srcsmooth/lsmrModule.f90 deleted file mode 100644 index 395ef00..0000000 --- a/srcsmooth/lsmrModule.f90 +++ /dev/null @@ -1,754 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File lsmrModule.f90 -! -! LSMR -! -! LSMR solves Ax = b or min ||Ax - b|| with or without damping, -! using the iterative algorithm of David Fong and Michael Saunders: -! http://www.stanford.edu/group/SOL/software/lsmr.html -! -! Maintained by -! David Fong -! Michael Saunders -! Systems Optimization Laboratory (SOL) -! Stanford University -! Stanford, CA 94305-4026, USA -! -! 17 Jul 2010: F90 LSMR derived from F90 LSQR and lsqr.m. -! 07 Sep 2010: Local reorthogonalization now works (localSize > 0). -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module lsmrModule - - use lsmrDataModule, only : dp - use lsmrblasInterface, only : dnrm2, dscal - implicit none - private - public :: LSMR - -contains - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! subroutine LSMR ( m, n, Aprod1, Aprod2, b, damp, & -! atol, btol, conlim, itnlim, localSize, nout, & -! x, istop, itn, normA, condA, normr, normAr, normx ) - subroutine LSMR ( m, n, leniw, lenrw,iw,rw, b, damp, & - atol, btol, conlim, itnlim, localSize, nout, & - x, istop, itn, normA, condA, normr, normAr, normx ) - - integer, intent(in) :: leniw - integer, intent(in) :: lenrw - integer, intent(in) :: iw(leniw) - real, intent(in) :: rw(lenrw) - - integer, intent(in) :: m, n, itnlim, localSize, nout - integer, intent(out) :: istop, itn - real(dp), intent(in) :: b(m) - real(dp), intent(out) :: x(n) - real(dp), intent(in) :: atol, btol, conlim, damp - real(dp), intent(out) :: normA, condA, normr, normAr, normx - - interface - subroutine aprod(mode,m,n,x,y,leniw,lenrw,iw,rw) ! y := y + A*x - use lsmrDataModule, only : dp - integer, intent(in) :: mode,lenrw - integer, intent(in) :: leniw - real, intent(in) :: rw(lenrw) - integer, intent(in) :: iw(leniw) - integer, intent(in) :: m,n - real(dp), intent(inout) :: x(n) - real(dp), intent(inout) :: y(m) - end subroutine aprod -! subroutine Aprod1(m,n,x,y) ! y := y + A*x -! use lsmrDataModule, only : dp -! integer, intent(in) :: m,n -! real(dp), intent(in) :: x(n) -! real(dp), intent(inout) :: y(m) -! end subroutine Aprod1 -! -! subroutine Aprod2(m,n,x,y) ! x := x + A'*y -! use lsmrDataModule, only : dp -! integer, intent(in) :: m,n -! real(dp), intent(inout) :: x(n) -! real(dp), intent(in) :: y(m) -! end subroutine Aprod2 - end interface - - !------------------------------------------------------------------- - ! LSMR finds a solution x to the following problems: - ! - ! 1. Unsymmetric equations: Solve A*x = b - ! - ! 2. Linear least squares: Solve A*x = b - ! in the least-squares sense - ! - ! 3. Damped least squares: Solve ( A )*x = ( b ) - ! ( damp*I ) ( 0 ) - ! in the least-squares sense - ! - ! where A is a matrix with m rows and n columns, b is an m-vector, - ! and damp is a scalar. (All quantities are real.) - ! The matrix A is treated as a linear operator. It is accessed - ! by means of subroutine calls with the following purpose: - ! - ! call Aprod1(m,n,x,y) must compute y = y + A*x without altering x. - ! call Aprod2(m,n,x,y) must compute x = x + A'*y without altering y. - ! - ! LSMR uses an iterative method to approximate the solution. - ! The number of iterations required to reach a certain accuracy - ! depends strongly on the scaling of the problem. Poor scaling of - ! the rows or columns of A should therefore be avoided where - ! possible. - ! - ! For example, in problem 1 the solution is unaltered by - ! row-scaling. If a row of A is very small or large compared to - ! the other rows of A, the corresponding row of ( A b ) should be - ! scaled up or down. - ! - ! In problems 1 and 2, the solution x is easily recovered - ! following column-scaling. Unless better information is known, - ! the nonzero columns of A should be scaled so that they all have - ! the same Euclidean norm (e.g., 1.0). - ! - ! In problem 3, there is no freedom to re-scale if damp is - ! nonzero. However, the value of damp should be assigned only - ! after attention has been paid to the scaling of A. - ! - ! The parameter damp is intended to help regularize - ! ill-conditioned systems, by preventing the true solution from - ! being very large. Another aid to regularization is provided by - ! the parameter condA, which may be used to terminate iterations - ! before the computed solution becomes very large. - ! - ! Note that x is not an input parameter. - ! If some initial estimate x0 is known and if damp = 0, - ! one could proceed as follows: - ! - ! 1. Compute a residual vector r0 = b - A*x0. - ! 2. Use LSMR to solve the system A*dx = r0. - ! 3. Add the correction dx to obtain a final solution x = x0 + dx. - ! - ! This requires that x0 be available before and after the call - ! to LSMR. To judge the benefits, suppose LSMR takes k1 iterations - ! to solve A*x = b and k2 iterations to solve A*dx = r0. - ! If x0 is "good", norm(r0) will be smaller than norm(b). - ! If the same stopping tolerances atol and btol are used for each - ! system, k1 and k2 will be similar, but the final solution x0 + dx - ! should be more accurate. The only way to reduce the total work - ! is to use a larger stopping tolerance for the second system. - ! If some value btol is suitable for A*x = b, the larger value - ! btol*norm(b)/norm(r0) should be suitable for A*dx = r0. - ! - ! Preconditioning is another way to reduce the number of iterations. - ! If it is possible to solve a related system M*x = b efficiently, - ! where M approximates A in some helpful way - ! (e.g. M - A has low rank or its elements are small relative to - ! those of A), LSMR may converge more rapidly on the system - ! A*M(inverse)*z = b, - ! after which x can be recovered by solving M*x = z. - ! - ! NOTE: If A is symmetric, LSMR should not be used! - ! Alternatives are the symmetric conjugate-gradient method (CG) - ! and/or SYMMLQ. - ! SYMMLQ is an implementation of symmetric CG that applies to - ! any symmetric A and will converge more rapidly than LSMR. - ! If A is positive definite, there are other implementations of - ! symmetric CG that require slightly less work per iteration - ! than SYMMLQ (but will take the same number of iterations). - ! - ! - ! Notation - ! -------- - ! The following quantities are used in discussing the subroutine - ! parameters: - ! - ! Abar = ( A ), bbar = (b) - ! (damp*I) (0) - ! - ! r = b - A*x, rbar = bbar - Abar*x - ! - ! normr = sqrt( norm(r)**2 + damp**2 * norm(x)**2 ) - ! = norm( rbar ) - ! - ! eps = the relative precision of floating-point arithmetic. - ! On most machines, eps is about 1.0e-7 and 1.0e-16 - ! in single and double precision respectively. - ! We expect eps to be about 1e-16 always. - ! - ! LSMR minimizes the function normr with respect to x. - ! - ! - ! Parameters - ! ---------- - ! m input m, the number of rows in A. - ! - ! n input n, the number of columns in A. - ! - ! Aprod1, Aprod2 See above. - ! - ! damp input The damping parameter for problem 3 above. - ! (damp should be 0.0 for problems 1 and 2.) - ! If the system A*x = b is incompatible, values - ! of damp in the range 0 to sqrt(eps)*norm(A) - ! will probably have a negligible effect. - ! Larger values of damp will tend to decrease - ! the norm of x and reduce the number of - ! iterations required by LSMR. - ! - ! The work per iteration and the storage needed - ! by LSMR are the same for all values of damp. - ! - ! b(m) input The rhs vector b. - ! - ! x(n) output Returns the computed solution x. - ! - ! atol input An estimate of the relative error in the data - ! defining the matrix A. For example, if A is - ! accurate to about 6 digits, set atol = 1.0e-6. - ! - ! btol input An estimate of the relative error in the data - ! defining the rhs b. For example, if b is - ! accurate to about 6 digits, set btol = 1.0e-6. - ! - ! conlim input An upper limit on cond(Abar), the apparent - ! condition number of the matrix Abar. - ! Iterations will be terminated if a computed - ! estimate of cond(Abar) exceeds conlim. - ! This is intended to prevent certain small or - ! zero singular values of A or Abar from - ! coming into effect and causing unwanted growth - ! in the computed solution. - ! - ! conlim and damp may be used separately or - ! together to regularize ill-conditioned systems. - ! - ! Normally, conlim should be in the range - ! 1000 to 1/eps. - ! Suggested value: - ! conlim = 1/(100*eps) for compatible systems, - ! conlim = 1/(10*sqrt(eps)) for least squares. - ! - ! Note: Any or all of atol, btol, conlim may be set to zero. - ! The effect will be the same as the values eps, eps, 1/eps. - ! - ! itnlim input An upper limit on the number of iterations. - ! Suggested value: - ! itnlim = n/2 for well-conditioned systems - ! with clustered singular values, - ! itnlim = 4*n otherwise. - ! - ! localSize input No. of vectors for local reorthogonalization. - ! 0 No reorthogonalization is performed. - ! >0 This many n-vectors "v" (the most recent ones) - ! are saved for reorthogonalizing the next v. - ! localSize need not be more than min(m,n). - ! At most min(m,n) vectors will be allocated. - ! - ! nout input File number for printed output. If positive, - ! a summary will be printed on file nout. - ! - ! istop output An integer giving the reason for termination: - ! - ! 0 x = 0 is the exact solution. - ! No iterations were performed. - ! - ! 1 The equations A*x = b are probably compatible. - ! Norm(A*x - b) is sufficiently small, given the - ! values of atol and btol. - ! - ! 2 damp is zero. The system A*x = b is probably - ! not compatible. A least-squares solution has - ! been obtained that is sufficiently accurate, - ! given the value of atol. - ! - ! 3 damp is nonzero. A damped least-squares - ! solution has been obtained that is sufficiently - ! accurate, given the value of atol. - ! - ! 4 An estimate of cond(Abar) has exceeded conlim. - ! The system A*x = b appears to be ill-conditioned, - ! or there could be an error in Aprod1 or Aprod2. - ! - ! 5 The iteration limit itnlim was reached. - ! - ! itn output The number of iterations performed. - ! - ! normA output An estimate of the Frobenius norm of Abar. - ! This is the square-root of the sum of squares - ! of the elements of Abar. - ! If damp is small and the columns of A - ! have all been scaled to have length 1.0, - ! normA should increase to roughly sqrt(n). - ! A radically different value for normA may - ! indicate an error in Aprod1 or Aprod2. - ! - ! condA output An estimate of cond(Abar), the condition - ! number of Abar. A very high value of condA - ! may again indicate an error in Aprod1 or Aprod2. - ! - ! normr output An estimate of the final value of norm(rbar), - ! the function being minimized (see notation - ! above). This will be small if A*x = b has - ! a solution. - ! - ! normAr output An estimate of the final value of - ! norm( Abar'*rbar ), the norm of - ! the residual for the normal equations. - ! This should be small in all cases. (normAr - ! will often be smaller than the true value - ! computed from the output vector x.) - ! - ! normx output An estimate of norm(x) for the final solution x. - ! - ! Subroutines and functions used - ! ------------------------------ - ! BLAS dscal, dnrm2 - ! USER Aprod1, Aprod2 - ! - ! Precision - ! --------- - ! The number of iterations required by LSMR will decrease - ! if the computation is performed in higher precision. - ! At least 15-digit arithmetic should normally be used. - ! "real(dp)" declarations should normally be 8-byte words. - ! If this ever changes, the BLAS routines dnrm2, dscal - ! (Lawson, et al., 1979) will also need to be changed. - ! - ! - ! Reference - ! --------- - ! http://www.stanford.edu/group/SOL/software/lsmr.html - ! ------------------------------------------------------------------ - ! - ! LSMR development: - ! 21 Sep 2007: Fortran 90 version of LSQR implemented. - ! Aprod1, Aprod2 implemented via f90 interface. - ! 17 Jul 2010: LSMR derived from LSQR and lsmr.m. - ! 07 Sep 2010: Local reorthogonalization now working. - !------------------------------------------------------------------- - - intrinsic :: abs, dot_product, min, max, sqrt - - ! Local arrays and variables - real(dp) :: h(n), hbar(n), u(m), v(n), w(n), localV(n,min(localSize,m,n)) - logical :: damped, localOrtho, localVQueueFull, prnt, show - integer :: i, localOrthoCount, localOrthoLimit, localPointer, localVecs, & - pcount, pfreq - real(dp) :: alpha, alphabar, alphahat, & - beta, betaacute, betacheck, betad, betadd, betahat, & - normb, c, cbar, chat, ctildeold, ctol, & - d, maxrbar, minrbar, normA2, & - rho, rhobar, rhobarold, rhodold, rhoold, rhotemp, & - rhotildeold, rtol, s, sbar, shat, stildeold, & - t1, taud, tautildeold, test1, test2, test3, & - thetabar, thetanew, thetatilde, thetatildeold, & - zeta, zetabar, zetaold - - ! Local constants - real(dp), parameter :: zero = 0.0_dp, one = 1.0_dp - character(len=*), parameter :: enter = ' Enter LSMR. ' - character(len=*), parameter :: exitt = ' Exit LSMR. ' - character(len=*), parameter :: msg(0:7) = & - (/ 'The exact solution is x = 0 ', & - 'Ax - b is small enough, given atol, btol ', & - 'The least-squares solution is good enough, given atol', & - 'The estimate of cond(Abar) has exceeded conlim ', & - 'Ax - b is small enough for this machine ', & - 'The LS solution is good enough for this machine ', & - 'Cond(Abar) seems to be too large for this machine ', & - 'The iteration limit has been reached ' /) - !------------------------------------------------------------------- - - - ! Initialize. - - localVecs = min(localSize,m,n) - show = nout > 0 - if (show) then - write(nout, 1000) enter,m,n,damp,atol,conlim,btol,itnlim,localVecs - end if - - pfreq = 20 ! print frequency (for repeating the heading) - pcount = 0 ! print counter - damped = damp > zero ! - - !------------------------------------------------------------------- - ! Set up the first vectors u and v for the bidiagonalization. - ! These satisfy beta*u = b, alpha*v = A(transpose)*u. - !------------------------------------------------------------------- - u(1:m) = b(1:m) - v(1:n) = zero - x(1:n) = zero - - alpha = zero - beta = dnrm2 (m, u, 1) - - if (beta > zero) then - call dscal (m, (one/beta), u, 1) - ! call Aprod2(m, n, v, u) ! v = A'*u - call aprod(2,m,n,v,u,leniw,lenrw,iw,rw) - alpha = dnrm2 (n, v, 1) - end if - - if (alpha > zero) then - call dscal (n, (one/alpha), v, 1) - w = v - end if - - normAr = alpha*beta - if (normAr == zero) go to 800 - - ! Initialization for local reorthogonalization. - - localOrtho = .false. - if (localVecs > 0) then - localPointer = 1 - localOrtho = .true. - localVQueueFull = .false. - localV(:,1) = v - end if - - ! Initialize variables for 1st iteration. - - itn = 0 - zetabar = alpha*beta - alphabar = alpha - rho = 1 - rhobar = 1 - cbar = 1 - sbar = 0 - - h = v - hbar(1:n) = zero - x(1:n) = zero - - ! Initialize variables for estimation of ||r||. - - betadd = beta - betad = 0 - rhodold = 1 - tautildeold = 0 - thetatilde = 0 - zeta = 0 - d = 0 - - ! Initialize variables for estimation of ||A|| and cond(A). - - normA2 = alpha**2 - maxrbar = 0_dp - minrbar = 1e+30_dp - - ! Items for use in stopping rules. - normb = beta - istop = 0 - ctol = zero - if (conlim > zero) ctol = one/conlim - normr = beta - - ! Exit if b=0 or A'b = 0. - - normAr = alpha * beta - if (normAr == 0) then - if (show) then - write(nout,'(a)') msg(1) - end if - return - end if - - ! Heading for iteration log. - - if (show) then - if (damped) then - write(nout,1300) - else - write(nout,1200) - end if - test1 = one - test2 = alpha/beta - write(nout, 1500) itn,x(1),normr,normAr,test1,test2 - end if - - !=================================================================== - ! Main iteration loop. - !=================================================================== - do - itn = itn + 1 - - !---------------------------------------------------------------- - ! Perform the next step of the bidiagonalization to obtain the - ! next beta, u, alpha, v. These satisfy - ! beta*u = A*v - alpha*u, - ! alpha*v = A'*u - beta*v. - !---------------------------------------------------------------- - call dscal (m,(- alpha), u, 1) - ! call Aprod1(m, n, v, u) ! u = A*v - call aprod ( 1,m,n,v,u,leniw,lenrw,iw,rw ) - beta = dnrm2 (m, u, 1) - - if (beta > zero) then - call dscal (m, (one/beta), u, 1) - if (localOrtho) then ! Store v into the circular buffer localV. - call localVEnqueue ! Store old v for local reorthog'n of new v. - end if - call dscal (n, (- beta), v, 1) - - !call Aprod2(m, n, v, u) ! v = A'*u - call aprod ( 2,m,n,v,u,leniw,lenrw,iw,rw ) - if (localOrtho) then ! Perform local reorthogonalization of V. - call localVOrtho ! Local-reorthogonalization of new v. - end if - alpha = dnrm2 (n, v, 1) - if (alpha > zero) then - call dscal (n, (one/alpha), v, 1) - end if - end if - - ! At this point, beta = beta_{k+1}, alpha = alpha_{k+1}. - - !---------------------------------------------------------------- - ! Construct rotation Qhat_{k,2k+1}. - - alphahat = d2norm(alphabar, damp) - chat = alphabar/alphahat - shat = damp/alphahat - - ! Use a plane rotation (Q_i) to turn B_i to R_i. - - rhoold = rho - rho = d2norm(alphahat, beta) - c = alphahat/rho - s = beta/rho - thetanew = s*alpha - alphabar = c*alpha - - ! Use a plane rotation (Qbar_i) to turn R_i^T into R_i^bar. - - rhobarold = rhobar - zetaold = zeta - thetabar = sbar*rho - rhotemp = cbar*rho - rhobar = d2norm(cbar*rho, thetanew) - cbar = cbar*rho/rhobar - sbar = thetanew/rhobar - zeta = cbar*zetabar - zetabar = - sbar*zetabar - - ! Update h, h_hat, x. - - hbar = h - (thetabar*rho/(rhoold*rhobarold))*hbar - x = x + (zeta/(rho*rhobar))*hbar - h = v - (thetanew/rho)*h - - ! Estimate ||r||. - - ! Apply rotation Qhat_{k,2k+1}. - betaacute = chat* betadd - betacheck = - shat* betadd - - ! Apply rotation Q_{k,k+1}. - betahat = c*betaacute - betadd = - s*betaacute - - ! Apply rotation Qtilde_{k-1}. - ! betad = betad_{k-1} here. - - thetatildeold = thetatilde - rhotildeold = d2norm(rhodold, thetabar) - ctildeold = rhodold/rhotildeold - stildeold = thetabar/rhotildeold - thetatilde = stildeold* rhobar - rhodold = ctildeold* rhobar - betad = - stildeold*betad + ctildeold*betahat - - ! betad = betad_k here. - ! rhodold = rhod_k here. - - tautildeold = (zetaold - thetatildeold*tautildeold)/rhotildeold - taud = (zeta - thetatilde*tautildeold)/rhodold - d = d + betacheck**2 - normr = sqrt(d + (betad - taud)**2 + betadd**2) - - ! Estimate ||A||. - normA2 = normA2 + beta**2 - normA = sqrt(normA2) - normA2 = normA2 + alpha**2 - - ! Estimate cond(A). - maxrbar = max(maxrbar,rhobarold) - if (itn > 1) then - minrbar = min(minrbar,rhobarold) - end if - condA = max(maxrbar,rhotemp)/min(minrbar,rhotemp) - - !---------------------------------------------------------------- - ! Test for convergence. - !---------------------------------------------------------------- - - ! Compute norms for convergence testing. - normAr = abs(zetabar) - normx = dnrm2(n, x, 1) - - ! Now use these norms to estimate certain other quantities, - ! some of which will be small near a solution. - - test1 = normr /normb - test2 = normAr/(normA*normr) - test3 = one/condA - t1 = test1/(one + normA*normx/normb) - rtol = btol + atol*normA*normx/normb - - ! The following tests guard against extremely small values of - ! atol, btol or ctol. (The user may have set any or all of - ! the parameters atol, btol, conlim to 0.) - ! The effect is equivalent to the normAl tests using - ! atol = eps, btol = eps, conlim = 1/eps. - - if (itn >= itnlim) istop = 7 - if (one+test3 <= one) istop = 6 - if (one+test2 <= one) istop = 5 - if (one+t1 <= one) istop = 4 - - ! Allow for tolerances set by the user. - - if ( test3 <= ctol) istop = 3 - if ( test2 <= atol) istop = 2 - if ( test1 <= rtol) istop = 1 - - !---------------------------------------------------------------- - ! See if it is time to print something. - !---------------------------------------------------------------- - prnt = .false. - if (show) then - if (n <= 40) prnt = .true. - if (itn <= 10) prnt = .true. - if (itn >= itnlim-10) prnt = .true. - if (mod(itn,10) == 0) prnt = .true. - if (test3 <= 1.1*ctol) prnt = .true. - if (test2 <= 1.1*atol) prnt = .true. - if (test1 <= 1.1*rtol) prnt = .true. - if (istop /= 0) prnt = .true. - - if (prnt) then ! Print a line for this iteration - if (pcount >= pfreq) then ! Print a heading first - pcount = 0 - if (damped) then - write(nout,1300) - else - write(nout,1200) - end if - end if - pcount = pcount + 1 - write(nout,1500) itn,x(1),normr,normAr,test1,test2,normA,condA - end if - end if - - if (istop /= 0) exit - end do - !=================================================================== - ! End of iteration loop. - !=================================================================== - - ! Come here if normAr = 0, or if normal exit. - -800 if (damped .and. istop==2) istop=3 ! Decide if istop = 2 or 3. - if (show) then ! Print the stopping condition. - write(nout, 2000) & - exitt,istop,itn, & - exitt,normA,condA, & - exitt,normb, normx, & - exitt,normr,normAr - write(nout, 3000) & - exitt, msg(istop) - end if - - return - - 1000 format(// a, ' Least-squares solution of Ax = b' & - / ' The matrix A has', i7, ' rows and', i7, ' columns' & - / ' damp =', es22.14 & - / ' atol =', es10.2, 15x, 'conlim =', es10.2 & - / ' btol =', es10.2, 15x, 'itnlim =', i10 & - / ' localSize (no. of vectors for local reorthogonalization) =', i7) - 1200 format(/ " Itn x(1) norm r A'r ", & - ' Compatible LS norm A cond A') - 1300 format(/ " Itn x(1) norm rbar Abar'rbar", & - ' Compatible LS norm Abar cond Abar') - 1500 format(i6, 2es17.9, 5es10.2) - 2000 format(/ a, 5x, 'istop =', i2, 15x, 'itn =', i8 & - / a, 5x, 'normA =', es12.5, 5x, 'condA =', es12.5 & - / a, 5x, 'normb =', es12.5, 5x, 'normx =', es12.5 & - / a, 5x, 'normr =', es12.5, 5x, 'normAr =', es12.5) - 3000 format(a, 5x, a) - - contains - - function d2norm( a, b ) - - real(dp) :: d2norm - real(dp), intent(in) :: a, b - - !------------------------------------------------------------------- - ! d2norm returns sqrt( a**2 + b**2 ) - ! with precautions to avoid overflow. - ! - ! 21 Mar 1990: First version. - ! 17 Sep 2007: Fortran 90 version. - ! 24 Oct 2007: User real(dp) instead of compiler option -r8. - !------------------------------------------------------------------- - - intrinsic :: abs, sqrt - real(dp) :: scale - real(dp), parameter :: zero = 0.0_dp - - scale = abs(a) + abs(b) - if (scale == zero) then - d2norm = zero - else - d2norm = scale*sqrt((a/scale)**2 + (b/scale)**2) - end if - - end function d2norm - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - subroutine localVEnqueue - - ! Store v into the circular buffer localV. - - if (localPointer < localVecs) then - localPointer = localPointer + 1 - else - localPointer = 1 - localVQueueFull = .true. - end if - localV(:,localPointer) = v - - end subroutine localVEnqueue - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - subroutine localVOrtho - - ! Perform local reorthogonalization of current v. - - real(dp) :: d - - if (localVQueueFull) then - localOrthoLimit = localVecs - else - localOrthoLimit = localPointer - end if - - do localOrthoCount = 1, localOrthoLimit - d = dot_product(v,localV(:,localOrthoCount)) - v = v - d * localV(:,localOrthoCount) - end do - - end subroutine localVOrtho - - end subroutine LSMR - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -end module LSMRmodule diff --git a/srcsmooth/lsmrblas.f90 b/srcsmooth/lsmrblas.f90 deleted file mode 100644 index 31574e2..0000000 --- a/srcsmooth/lsmrblas.f90 +++ /dev/null @@ -1,360 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File lsmrblas.f90 (double precision) -! -! This file contains the following BLAS routines -! dcopy, ddot, dnrm2, dscal -! required by subroutines LSMR and Acheck. -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! -!! DCOPY copies a vector X to a vector Y. -! -! Discussion: -! This routine uses double precision real arithmetic. -! The routine uses unrolled loops for increments equal to one. -! -! Modified: -! 16 May 2005 -! -! Author: -! Jack Dongarra -! Fortran90 translation by John Burkardt. -! -! Reference: -! -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of elements in DX and DY. -! -! Input, real ( kind = 8 ) DX(*), the first vector. -! -! Input, integer INCX, the increment between successive entries of DX. -! -! Output, real ( kind = 8 ) DY(*), the second vector. -! -! Input, integer INCY, the increment between successive entries of DY. - - - subroutine dcopy(n,dx,incx,dy,incy) - - implicit none -! double precision dx(*),dy(*) - real(4) dx(*),dy(*) - integer i,incx,incy,ix,iy,m,n - - if ( n <= 0 ) then - return - end if - - if ( incx == 1 .and. incy == 1 ) then - - m = mod ( n, 7 ) - - if ( m /= 0 ) then - dy(1:m) = dx(1:m) - end if - - do i = m+1, n, 7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - end do - - else - - if ( 0 <= incx ) then - ix = 1 - else - ix = ( -n + 1 ) * incx + 1 - end if - - if ( 0 <= incy ) then - iy = 1 - else - iy = ( -n + 1 ) * incy + 1 - end if - - do i = 1, n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - end do - end if - return -end subroutine dcopy - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!! DDOT forms the dot product of two vectors. -! -! Discussion: -! This routine uses double precision real arithmetic. -! This routine uses unrolled loops for increments equal to one. -! -! Modified: -! 16 May 2005 -! -! Author: -! Jack Dongarra -! Fortran90 translation by John Burkardt. -! -! Reference: -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of entries in the vectors. -! -! Input, real ( kind = 8 ) DX(*), the first vector. -! -! Input, integer INCX, the increment between successive entries in DX. -! -! Input, real ( kind = 8 ) DY(*), the second vector. -! -! Input, integer INCY, the increment between successive entries in DY. -! -! Output, real ( kind = 8 ) DDOT, the sum of the product of the -! corresponding entries of DX and DY. - - - ! double precision function ddot(n,dx,incx,dy,incy) - real(4) function ddot(n,dx,incx,dy,incy) - - implicit none - ! double precision dx(*),dy(*),dtemp - real(4) dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,n - - ddot = 0.0d0 - dtemp = 0.0d0 - if ( n <= 0 ) then - return - end if - -! Code for unequal increments or equal increments -! not equal to 1. - - if ( incx /= 1 .or. incy /= 1 ) then - - if ( 0 <= incx ) then - ix = 1 - else - ix = ( - n + 1 ) * incx + 1 - end if - - if ( 0 <= incy ) then - iy = 1 - else - iy = ( - n + 1 ) * incy + 1 - end if - - do i = 1, n - dtemp = dtemp + dx(ix) * dy(iy) - ix = ix + incx - iy = iy + incy - end do - -! Code for both increments equal to 1. - - else - - m = mod ( n, 5 ) - - do i = 1, m - dtemp = dtemp + dx(i) * dy(i) - end do - - do i = m+1, n, 5 - dtemp = dtemp + dx(i)*dy(i) + dx(i+1)*dy(i+1) + dx(i+2)*dy(i+2) & - + dx(i+3)*dy(i+3) + dx(i+4)*dy(i+4) - end do - - end if - - ddot = dtemp - return -end function ddot - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!*****************************************************************************80 -! -!! DNRM2 returns the euclidean norm of a vector. -! -! Discussion: -! This routine uses double precision real arithmetic. -! DNRM2 ( X ) = sqrt ( X' * X ) -! -! Modified: -! 16 May 2005 -! -! Author: -! Sven Hammarling -! Fortran90 translation by John Burkardt. -! -! Reference: -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of entries in the vector. -! -! Input, real ( kind = 8 ) X(*), the vector whose norm is to be computed. -! -! Input, integer INCX, the increment between successive entries of X. -! -! Output, real ( kind = 8 ) DNRM2, the Euclidean norm of X. -! - - ! double precision function dnrm2 ( n, x, incx) - real(4) function dnrm2 ( n, x, incx) - implicit none - integer ix,n,incx - ! double precision x(*), ssq,absxi,norm,scale - real(4) x(*), ssq,absxi,norm,scale - - if ( n < 1 .or. incx < 1 ) then - norm = 0.d0 - else if ( n == 1 ) then - norm = abs ( x(1) ) - else - scale = 0.d0 - ssq = 1.d0 - - do ix = 1, 1 + ( n - 1 )*incx, incx - if ( x(ix) /= 0.d0 ) then - absxi = abs ( x(ix) ) - if ( scale < absxi ) then - ssq = 1.d0 + ssq * ( scale / absxi )**2 - scale = absxi - else - ssq = ssq + ( absxi / scale )**2 - end if - end if - end do - norm = scale * sqrt ( ssq ) - end if - - dnrm2 = norm - return -end function dnrm2 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! DSCAL scales a vector by a constant. -! -! Discussion: -! This routine uses double precision real arithmetic. -! -! Modified: -! 08 April 1999 -! -! Author: -! Jack Dongarra -! Fortran90 translation by John Burkardt. -! -! Reference: -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of entries in the vector. -! -! Input, real ( kind = 8 ) SA, the multiplier. -! -! Input/output, real ( kind = 8 ) X(*), the vector to be scaled. -! -! Input, integer INCX, the increment between successive entries of X. -! - - subroutine dscal(n,sa,x,incx) - - implicit none - - integer i - integer incx - integer ix - integer m - integer n - !double precision sa - !double precision x(*) - - real(4) sa - real(4) x(*) - if ( n <= 0 ) then - return - else if ( incx == 1 ) then - m = mod ( n, 5 ) - x(1:m) = sa * x(1:m) - - do i = m+1, n, 5 - x(i) = sa * x(i) - x(i+1) = sa * x(i+1) - x(i+2) = sa * x(i+2) - x(i+3) = sa * x(i+3) - x(i+4) = sa * x(i+4) - end do - else - if ( 0 <= incx ) then - ix = 1 - else - ix = ( - n + 1 ) * incx + 1 - end if - - do i = 1, n - x(ix) = sa * x(ix) - ix = ix + incx - end do - - end if - - return -end subroutine dscal -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/srcsmooth/lsmrblasInterface.f90 b/srcsmooth/lsmrblasInterface.f90 deleted file mode 100644 index 58cefa0..0000000 --- a/srcsmooth/lsmrblasInterface.f90 +++ /dev/null @@ -1,41 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File lsmrblasInterface.f90 -! -! BLAS1 Interfaces: ddot dnrm2 dscal -! -! Maintained by Michael Saunders . -! -! 19 Dec 2008: lsqrblasInterface module implemented. -! Metcalf and Reid recommend putting interfaces in a module. -! 16 Jul 2010: LSMR version derived from LSQR equivalent. -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module lsmrblasInterface - - implicit none - public :: ddot, dnrm2, dscal - - interface ! Level 1 BLAS - function ddot (n,dx,incx,dy,incy) - use lsmrDataModule, only : dp - integer, intent(in) :: n,incx,incy - real(dp), intent(in) :: dx(*),dy(*) - real(dp) :: ddot - end function ddot - - function dnrm2 (n,dx,incx) - use lsmrDataModule, only : dp - integer, intent(in) :: n,incx - real(dp), intent(in) :: dx(*) - real(dp) :: dnrm2 - end function dnrm2 - - subroutine dscal (n,sa,x,incx) - use lsmrDataModule, only : dp - integer, intent(in) :: n,incx - real(dp), intent(in) :: sa - real(dp), intent(inout) :: x(*) - end subroutine dscal - end interface - -end module lsmrblasInterface diff --git a/srcsmooth/main.f90 b/srcsmooth/main.f90 deleted file mode 100644 index 2cb3818..0000000 --- a/srcsmooth/main.f90 +++ /dev/null @@ -1,616 +0,0 @@ - ! CODE FOR SURFACE WAVE TOMOGRAPHY USING DISPERSION MEASUREMENTS - ! VERSION: - ! 1.0 - ! AUTHOR: - ! HONGJIAN FANG. fanghj@mail.ustc.edu.cn - ! PURPOSE: - ! DIRECTLY INVERT SURFACE WAVE DISPERSION MEASUREMENTS FOR 3-D - ! STUCTURE WITHOUT THE INTERMEDIATE STEP OF CONSTUCTION THE PHASE - ! OR GROUP VELOCITY MAPS. - ! REFERENCE: - ! Fang, H., Yao, H., Zhang, H., Huang, Y. C., & van der Hilst, R. D. - ! (2015). Direct inversion of surface wave dispersion for - ! three-dimensional shallow crustal structure based on ray tracing: - ! methodology and application. Geophysical Journal International, - ! 201(3), 1251-1263. - ! HISTORY: - ! 2015/01/31 START TO REORGONIZE THE MESSY CODE - ! - - program SurfTomo - use lsmrModule, only:lsmr - use lsmrblasInterface, only : dnrm2 - implicit none - -! VARIABLE DEFINE - - character inputfile*80 - character logfile*100 - character outmodel*100 - character outsyn*100 - logical ex - character dummy*40 - character datafile*80 - - integer nx,ny,nz - real goxd,gozd - real dvxd,dvzd - integer nsrc,nrc - real weight,weight0 - real damp - real minthk - integer kmax,kmaxRc,kmaxRg,kmaxLc,kmaxLg - real*8,dimension(:),allocatable:: tRc,tRg,tLc,tLg - real,dimension(:),allocatable:: depz - integer itn - integer nout - integer localSize - real mean,std_devs,balances,balanceb - integer msurf - real,parameter:: tolr=1e-4 - real,dimension(:),allocatable:: obst,dsyn,cbst,wt,dtres,dist,datweight - real,dimension(:),allocatable:: pvall,depRp,pvRp - real sta1_lat,sta1_lon,sta2_lat,sta2_lon - real dist1 - integer dall - integer istep - real,parameter :: pi=3.1415926535898 - integer checkstat - integer ii,jj,kk - real, dimension (:,:), allocatable :: scxf,sczf - real, dimension (:,:,:), allocatable :: rcxf,rczf - integer,dimension(:,:),allocatable::wavetype,igrt,nrc1 - integer,dimension(:),allocatable::nsrc1,knum1 - integer,dimension(:,:),allocatable::periods - real,dimension(:),allocatable::rw - integer,dimension(:),allocatable::iw,col - real,dimension(:),allocatable::dv,norm - real,dimension(:,:,:),allocatable::vsf - real,dimension(:,:,:),allocatable::vsftrue - character strf - integer veltp,wavetp - real velvalue - integer knum,knumo,err - integer istep1,istep2 - integer period - integer knumi,srcnum,count1 - integer HorizonType,VerticalType - character line*200 - integer iter,maxiter - integer maxnar - real acond - real anorm - real arnorm - real rnorm - real xnorm - character str1 - real atol,btol - real conlim - integer istop - integer itnlim - integer lenrw,leniw - integer nar,nar_tmp,nars - integer count3,nvz,nvx - integer m,maxvp,n - integer i,j,k - real Minvel,MaxVel - real spfra - real noiselevel - integer ifsyn - integer writepath - real averdws - real maxnorm - real threshold,threshold0 - -! OPEN FILES FIRST TO OUTPUT THE PROCESS - open(34,file='IterVel.out') - nout=36 - open(nout,file='lsmr.txt') - -! OUTPUT PROGRAM INFOMATION - write(*,*) - write(*,*),' S U R F T O M O' - write(*,*),'PLEASE contact Hongjain Fang & - (fanghj@mail.ustc.edu.cn) if you find any bug' - write(*,*) - -! READ INPUT FILE - if (iargc() < 1) then - write(*,*) 'input file [SurfTomo.in(default)]:' - read(*,'(a)') inputfile - if (len_trim(inputfile) <=1 ) then - inputfile = 'SurfTomo.in' - else - inputfile = inputfile(1:len_trim(inputfile)) - endif - else - call getarg(1,inputfile) - endif - inquire(file = inputfile, exist = ex) - if (.not. ex) stop 'unable to open the inputfile' - - open(10,file=inputfile,status='old') - read(10,'(a30)')dummy - read(10,'(a30)')dummy - read(10,'(a30)')dummy - read(10,*)datafile - read(10,*) nx,ny,nz - read(10,*) goxd,gozd - read(10,*) dvxd,dvzd - read(10,*) nsrc - read(10,*) weight0,damp - read(10,*) minthk - read(10,*) Minvel,Maxvel - read(10,*) maxiter - read(10,*) spfra - read(10,*) kmaxRc - write(*,*) 'model origin:latitude,longitue' - write(*,'(2f10.4)') goxd,gozd - write(*,*) 'grid spacing:latitude,longitue' - write(*,'(2f10.4)') dvxd,dvzd - write(*,*) 'model dimension:nx,ny,nz' - write(*,'(3i5)') nx,ny,nz - 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 & - (fanghj@mail.ustc.edu.cn) if you find any bug' - write(66,*) - write(66,*) 'model origin:latitude,longitue' - write(66,'(2f10.4)') goxd,gozd - write(66,*) 'grid spacing:latitude,longitue' - write(66,'(2f10.4)') dvxd,dvzd - write(66,*) 'model dimension:nx,ny,nz' - write(66,'(3i5)') nx,ny,nz - if(kmaxRc.gt.0)then - allocate(tRc(kmaxRc),& - stat=checkstat) - if (checkstat > 0) stop 'error allocating RP' - read(10,*)(tRc(i),i=1,kmaxRc) - write(*,*)'Rayleigh wave phase velocity used,periods:(s)' - write(*,'(50f6.2)')(tRc(i),i=1,kmaxRc) - write(66,*)'Rayleigh wave phase velocity used,periods:(s)' - write(66,'(50f6.2)')(tRc(i),i=1,kmaxRc) - endif - read(10,*)kmaxRg - if(kmaxRg.gt.0)then - allocate(tRg(kmaxRg), stat=checkstat) - if (checkstat > 0) stop 'error allocating RP' - read(10,*)(tRg(i),i=1,kmaxRg) - write(*,*)'Rayleigh wave group velocity used,periods:(s)' - write(*,'(50f6.2)')(tRg(i),i=1,kmaxRg) - write(66,*)'Rayleigh wave group velocity used,periods:(s)' - write(66,'(50f6.2)')(tRg(i),i=1,kmaxRg) - endif - read(10,*)kmaxLc - if(kmaxLc.gt.0)then - allocate(tLc(kmaxLc), stat=checkstat) - if (checkstat > 0) stop 'error allocating RP' - read(10,*)(tLc(i),i=1,kmaxLc) - write(*,*)'Love wave phase velocity used,periods:(s)' - write(*,'(50f6.2)')(tLc(i),i=1,kmaxLc) - write(66,*)'Love wave phase velocity used,periods:(s)' - write(66,'(50f6.2)')(tLc(i),i=1,kmaxLc) - endif - read(10,*)kmaxLg - if(kmaxLg.gt.0)then - allocate(tLg(kmaxLg), stat=checkstat) - if (checkstat > 0) stop 'error allocating RP' - read(10,*)(tLg(i),i=1,kmaxLg) - write(*,*)'Love wave group velocity used,periods:(s)' - write(*,'(50f6.2)')(tLg(i),i=1,kmaxLg) - write(66,*)'Love wave group velocity used,periods:(s)' - write(66,'(50f6.2)')(tLg(i),i=1,kmaxLg) - endif - read(10,*)ifsyn - read(10,*)noiselevel - read(10,*) threshold0 - close(10) - nrc=nsrc - kmax=kmaxRc+kmaxRg+kmaxLc+kmaxLg - -! READ MEASUREMENTS - open(unit=87,file=datafile,status='old') - allocate(scxf(nsrc,kmax),sczf(nsrc,kmax),& - rcxf(nrc,nsrc,kmax),rczf(nrc,nsrc,kmax),stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate' - endif - allocate(periods(nsrc,kmax),wavetype(nsrc,kmax),& - nrc1(nsrc,kmax),nsrc1(kmax),knum1(kmax),& - igrt(nsrc,kmax),stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate' - endif - allocate(obst(nrc*nsrc*kmax),dist(nrc*nsrc*kmax),& - stat=checkstat) - allocate(pvall(nrc*nsrc*kmax),depRp(nrc*nsrc*kmax),& - pvRp(nrc*nsrc*kmax),stat=checkstat) - IF(checkstat > 0)THEN - write(6,*)'error with allocate' - ENDIF - istep=0 - istep2=0 - dall=0 - knumo=12345 - knum=0 - istep1=0 - do - read(87,'(a)',iostat=err) line - if(err.eq.0) then - if(line(1:1).eq.'#') then - read(line,*) str1,sta1_lat,sta1_lon,period,wavetp,veltp - if(wavetp.eq.2.and.veltp.eq.0) knum=period - if(wavetp.eq.2.and.veltp.eq.1) knum=kmaxRc+period - if(wavetp.eq.1.and.veltp.eq.0) knum=kmaxRg+kmaxRc+period - if(wavetp.eq.1.and.veltp.eq.1) knum=kmaxLc+kmaxRg+& - kmaxRc+period - if(knum.ne.knumo) then - istep=0 - istep2=istep2+1 - endif - istep=istep+1 - istep1=0 - sta1_lat=(90.0-sta1_lat)*pi/180.0 - sta1_lon=sta1_lon*pi/180.0 - scxf(istep,knum)=sta1_lat - sczf(istep,knum)=sta1_lon - periods(istep,knum)=period - wavetype(istep,knum)=wavetp - igrt(istep,knum)=veltp - nsrc1(knum)=istep - knum1(istep2)=knum - knumo=knum - else - read(line,*) sta2_lat,sta2_lon,velvalue - istep1=istep1+1 - dall=dall+1 - sta2_lat=(90.0-sta2_lat)*pi/180.0 - sta2_lon=sta2_lon*pi/180.0 - rcxf(istep1,istep,knum)=sta2_lat - rczf(istep1,istep,knum)=sta2_lon - call delsph(sta1_lat,sta1_lon,sta2_lat,sta2_lon,dist1) - dist(dall)=dist1 - obst(dall)=dist1/velvalue - pvall(dall)=velvalue - nrc1(istep,knum)=istep1 - endif - else - exit - endif - enddo - close(87) - allocate(depz(nz), stat=checkstat) - maxnar = dall*nx*ny*nz*spfra!sparsity fraction - maxvp = (nx-2)*(ny-2)*(nz-1) - allocate(dv(maxvp), stat=checkstat) - allocate(norm(maxvp), stat=checkstat) - allocate(vsf(nx,ny,nz), stat=checkstat) - allocate(vsftrue(nx,ny,nz), stat=checkstat) - - allocate(rw(maxnar), stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate: real rw' - endif - allocate(iw(2*maxnar+1), stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate: integer iw' - endif - allocate(col(maxnar), stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate: integer iw' - endif - allocate(cbst(dall+maxvp),dsyn(dall),datweight(dall),wt(dall+maxvp),dtres(dall+maxvp),& - stat=checkstat) - -! MEASUREMENTS STATISTICS AND READ INITIAL MODEL - write(*,'(a,i7)') 'Number of all measurements',dall - - open(10,file='MOD',status='old') - read(10,*) (depz(i),i=1,nz) - do k = 1,nz - do j = 1,ny - read(10,*)(vsf(i,j,k),i=1,nx) - enddo - enddo - close(10) - write(*,*) 'grid points in depth direction:(km)' - write(*,'(50f6.2)') depz - - - -! CHECKERBOARD TEST - if (ifsyn == 1) then - write(*,*) 'Checkerboard Resolution Test Begin' - vsftrue = vsf - - open(11,file='MOD.true',status='old') - do k = 1,nz - do j = 1,ny - read(11,*) (vsftrue(i,j,k),i=1,nx) - enddo - enddo - close(11) - - call synthetic(nx,ny,nz,maxvp,vsftrue,obst,& - goxd,gozd,dvxd,dvzd,kmaxRc,kmaxRg,kmaxLc,kmaxLg,& - tRc,tRg,tLc,tLg,wavetype,igrt,periods,depz,minthk,& - scxf,sczf,rcxf,rczf,nrc1,nsrc1,knum1,kmax,& - nsrc,nrc,noiselevel) - endif - - - -! ITERATE UNTILL CONVERGE - writepath = 0 - do iter = 1,maxiter - iw = 0 - rw = 0.0 - col = 0 - -! COMPUTE SENSITIVITY MATRIX - if (iter == maxiter) then - writepath = 1 - open(40,file='raypath.out') - endif - write(*,*) 'computing sensitivity matrix...' - call CalSurfG(nx,ny,nz,maxvp,vsf,iw,rw,col,dsyn,& - goxd,gozd,dvxd,dvzd,kmaxRc,kmaxRg,kmaxLc,kmaxLg,& - tRc,tRg,tLc,tLg,wavetype,igrt,periods,depz,minthk,& - scxf,sczf,rcxf,rczf,nrc1,nsrc1,knum1,kmax,& - nsrc,nrc,nar,writepath) - - do i = 1,dall - cbst(i) = obst(i) - dsyn(i) - enddo - - threshold = threshold0+(maxiter/2-iter)/3*0.5 - do i = 1,dall - datweight(i) = 1.0 - if(abs(cbst(i)) > threshold) then - datweight(i) = exp(-(abs(cbst(i))-threshold)) - endif - cbst(i) = cbst(i)*datweight(i) - enddo - - do i = 1,nar - rw(i) = rw(i)*datweight(iw(1+i)) - enddo - - norm=0 - do i=1,nar - norm(col(i))=norm(col(i))+abs(rw(i)) - enddo - averdws=0 - maxnorm=0 - do i=1,maxvp - averdws = averdws+norm(i) - if(norm(i)>maxnorm) maxnorm=norm(i) - enddo - averdws=averdws/maxvp - write(66,*)'Maximum and Average DWS values:',maxnorm,averdws - write(66,*)'Threshold is:',threshold - -! WRITE OUT RESIDUAL FOR THE FIRST AND LAST ITERATION - if(iter.eq.1) then - open(88,file='residualFirst.dat') - do i=1,dall - write(88,*) dist(i),dsyn(i),obst(i), & - dsyn(i)*datweight(i),obst(i)*datweight(i),datweight(i) - enddo - close(88) - endif - if(iter.eq.maxiter) then - open(88,file='residualLast.dat') - do i=1,dall - write(88,*) dist(i),dsyn(i),obst(i), & - dsyn(i)*datweight(i),obst(i)*datweight(i),datweight(i) - enddo - close(88) - endif - - -! ADDING REGULARIZATION TERM - weight=dnrm2(dall,cbst,1)**2/dall*weight0 - nar_tmp=nar - nars=0 - - count3=0 - nvz=ny-2 - nvx=nx-2 - do k=1,nz-1 - do j=1,nvz - do i=1,nvx - if(i==1.or.i==nvx.or.j==1.or.j==nvz.or.k==1.or.k==nz-1)then - count3=count3+1 - col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i - rw(nar+1)=2.0*weight - iw(1+nar+1)=dall+count3 - cbst(dall+count3)=0 - nar=nar+1 - else - count3=count3+1 - col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i - rw(nar+1)=6.0*weight - iw(1+nar+1)=dall+count3 - rw(nar+2)=-1.0*weight - iw(1+nar+2)=dall+count3 - col(nar+2)=(k-1)*nvz*nvx+(j-1)*nvx+i-1 - rw(nar+3)=-1.0*weight - iw(1+nar+3)=dall+count3 - col(nar+3)=(k-1)*nvz*nvx+(j-1)*nvx+i+1 - rw(nar+4)=-1.0*weight - iw(1+nar+4)=dall+count3 - col(nar+4)=(k-1)*nvz*nvx+(j-2)*nvx+i - rw(nar+5)=-1.0*weight - iw(1+nar+5)=dall+count3 - col(nar+5)=(k-1)*nvz*nvx+j*nvx+i - rw(nar+6)=-1.0*weight - iw(1+nar+6)=dall+count3 - col(nar+6)=(k-2)*nvz*nvx+(j-1)*nvx+i - rw(nar+7)=-1.0*weight - iw(1+nar+7)=dall+count3 - col(nar+7)=k*nvz*nvx+(j-1)*nvx+i - cbst(dall+count3)=0 - nar=nar+7 - endif - enddo - enddo - enddo - m = dall + count3 - n = maxvp - - iw(1)=nar - do i=1,nar - iw(1+nar+i)=col(i) - enddo - if (nar > maxnar) stop 'increase sparsity fraction(spfra)' - -! CALLING IRLS TO SOLVE THE PROBLEM - - leniw = 2*nar+1 - lenrw = nar - dv = 0 - atol = 1e-3 - btol = 1e-3 - conlim = 1200 - itnlim = 1000 - istop = 0 - anorm = 0.0 - acond = 0.0 - arnorm = 0.0 - xnorm = 0.0 - localSize = n/4 - - call LSMR(m, n, leniw, lenrw,iw,rw,cbst, damp,& - atol, btol, conlim, itnlim, localSize, nout,& - dv, istop, itn, anorm, acond, rnorm, arnorm, xnorm) - if(istop==3) print*,'istop = 3, large condition number' - - - 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 chi sqrue of & - residual: ',mean*1000,'ms ',1000*std_devs,'ms ',& - dnrm2(dall,cbst,1)**2/sqrt(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 chi sqrue of & - residual: ',mean*1000,'ms ',1000*std_devs,'ms ',& - dnrm2(dall,cbst,1)**2/sqrt(dall) - - write(*,'(a,2f7.4)'),'min and max velocity variation ',& - minval(dv),maxval(dv) - write(66,'(a,2f7.4)'),'min and max velocity variation ',& - minval(dv),maxval(dv) - - do k=1,nz-1 - do j=1,ny-2 - do i=1,nx-2 - if(dv((k-1)*(nx-2)*(ny-2)+(j-1)*(nx-2)+i).ge.0.500) then - dv((k-1)*(nx-2)*(ny-2)+(j-1)*(nx-2)+i)=0.500 - endif - if(dv((k-1)*(nx-2)*(ny-2)+(j-1)*(nx-2)+i).le.-0.500) then - dv((k-1)*(nx-2)*(ny-2)+(j-1)*(nx-2)+i)=-0.500 - endif - vsf(i+1,j+1,k)=vsf(i+1,j+1,k)+dv((k-1)*(nx-2)*(ny-2)+(j-1)*(nx-2)+i) - if(vsf(i+1,j+1,k).lt.Minvel) vsf(i+1,j+1,k)=Minvel - if(vsf(i+1,j+1,k).gt.Maxvel) vsf(i+1,j+1,k)=Maxvel - enddo - enddo - enddo - write(34,*)',OUTPUT S VELOCITY AT ITERATION',iter - do k=1,nz - do j=1,ny - write(34,'(100f7.3)') (vsf(i,j,k),i=1,nx) - enddo - enddo - write(34,*)',OUTPUT DWS AT ITERATION',iter - do k=1,nz-1 - do j=2,ny-1 - write(34,'(100f8.1)') (norm((k-1)*(ny-2)*(nx-2)+(j-2)*(nx-2)+i-1),i=2,nx-1) - enddo - enddo - - enddo !end iteration - -! OUTPUT THE VELOCITY MODEL - - write(*,*),'Program finishes successfully' - write(66,*),'Program finishes successfully' - - if(ifsyn == 1) then - open(65,file='Vs_model.real') - write(outsyn,'(a,a)') trim(inputfile),'Syn.dat' - open(63,file=outsyn) - do k=1,nz-1 - do j=1,ny-2 - do i=1,nx-2 - write(65,'(5f8.4)') gozd+(j-1)*dvzd,goxd-(i-1)*dvxd,depz(k),vsftrue(i,j,k) - write(63,'(5f8.4)') gozd+(j-1)*dvzd,goxd-(i-1)*dvxd,depz(k),vsf(i,j,k) - enddo - enddo - enddo - close(65) - close(63) - write(*,*),'Output True velocity model & - to Vs_model.real' - write(*,*),'Output inverted shear velocity model & - to ',outsyn - write(66,*),'Output True velocity model & - to Vs_model.real' - write(66,*),'Output inverted shear velocity model & - to ',outsyn - else - write(outmodel,'(a,a)') trim(inputfile),'Measure.dat' - open(64,file=outmodel) - do k=1,nz-1 - do j=1,ny-2 - do i=1,nx-2 - write(64,'(5f8.4)') gozd+(j-1)*dvzd,goxd-(i-1)*dvxd,depz(k),vsf(i,j,k) - enddo - enddo - enddo - close(64) - write(*,*),'Output inverted shear velocity model & - to ',outmodel - write(66,*),'Output inverted shear velocity model & - to ',outmodel - endif - - close(34) - close(40) - close(nout) !close lsmr.txt - close(66) !close surf_tomo.log - deallocate(obst) - deallocate(dsyn) - deallocate(dist) - deallocate(depz) - deallocate(scxf,sczf) - deallocate(rcxf,rczf) - deallocate(wavetype,igrt,nrc1) - deallocate(nsrc1,knum1,periods) - deallocate(rw) - deallocate(iw,col) - deallocate(cbst,wt,dtres,datweight) - deallocate(dv) - deallocate(norm) - deallocate(vsf) - deallocate(vsftrue) - if(kmaxRc.gt.0) then - deallocate(tRc) - endif - if(kmaxRg.gt.0) then - deallocate(tRg) - endif - if(kmaxLc.gt.0) then - deallocate(tLc) - endif - if(kmaxLg.gt.0) then - deallocate(tLg) - endif - - end program diff --git a/srcsmooth/surfdisp96.f b/srcsmooth/surfdisp96.f deleted file mode 100644 index 1e61103..0000000 --- a/srcsmooth/surfdisp96.f +++ /dev/null @@ -1,1062 +0,0 @@ -c----------------------------------------------------------------------c -c c -c COMPUTER PROGRAMS IN SEISMOLOGY c -c VOLUME IV c -c c -c PROGRAM: SRFDIS c -c c -c COPYRIGHT 1986, 1991 c -c D. R. Russell, R. B. Herrmann c -c Department of Earth and Atmospheric Sciences c -c Saint Louis University c -c 221 North Grand Boulevard c -c St. Louis, Missouri 63103 c -c U. S. A. c -c c -c----------------------------------------------------------------------c -c This is a combination of program 'surface80' which search the poles -c on C-T domain, and the program 'surface81' which search in the F-K -c domain. The input data is slightly different with its precessors. -c -Wang 06/06/83. -c -c The program calculates the dispersion values for any -c layered model, any frequency, and any mode. -c -c This program will accept one liquid layer at the surface. -c In such case ellipticity of rayleigh wave is that at the -c top of solid array. Love wave communications ignore -c liquid layer. -c -c Program developed by Robert B Herrmann Saint Louis -c univ. Nov 1971, and revised by C. Y. Wang on Oct 1981. -c Modified for use in surface wave inversion, and -c addition of spherical earth flattening transformation, by -c David R. Russell, St. Louis University, Jan. 1984. -c -c Changes -c 28 JAN 2003 - fixed minor but for sphericity correction by -c saving one parameter in subroutine sphere -c 20 JUL 2004 - removed extraneous line at line 550 -c since dc not defined -c if(dabs(c1-c2) .le. dmin1(1.d-6*c1,0.005d+0*dc) )go to 1000 -c 28 DEC 2007 - changed the Earth flattening to now use layer -c midpoint and the Biswas (1972: PAGEOPH 96, 61-74, 1972) -c density mapping for P-SV - note a true comparison -c requires the ability to handle a fluid core for SH and SV -c Also permit one layer with fluid is base of the velocity is 0.001 km/sec -c----- -c 13 JAN 2010 - modified by Huajian Yao at MIT for calculation of -c group or phase velocities -c----- - - subroutine surfdisp96(thkm,vpm,vsm,rhom,nlayer,iflsph,iwave, - & mode,igr,kmax,t,cg) - - parameter(LER=0,LIN=5,LOT=66) - integer NL, NL2, NLAY - parameter(NL=200,NLAY=200,NL2=NL+NL) - integer NP - parameter (NP=60) - -c----- -c LIN - unit for FORTRAN read from terminal -c LOT - unit for FORTRAN write to terminal -c LER - unit for FORTRAN error output to terminal -c NL - layers in model -c NP - number of unique periods -c----- -c----- parameters -c thkm, vpm, vsm, rhom: model for dispersion calculation -c nlayer - I4: number of layers in the model -c iflsph - I4: 0 flat earth model, 1 spherical earth model -c iwave - I4: 1 Love wave, 2 Rayleigh wave -c mode - I4: ith mode of surface wave, 1 fundamental, 2 first higher, .... -c igr - I4: 0 phase velocity, > 0 group velocity -c kmax - I4: number of periods (t) for dispersion calculation -c t - period vector (t(NP)) -c cg - output phase or group velocities (vector,cg(NP)) -c----- - real*4 thkm(NLAY),vpm(NLAY),vsm(NLAY),rhom(NLAY) - integer nlayer,iflsph,iwave,mode,igr,kmax - double precision twopi,one,onea - double precision cc,c1,clow,cm,dc,t1 - double precision t(NP),c(NP),cb(NP),cg(NP) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi - integer*4 iverb(2) - integer*4 llw - integer*4 nsph, ifunc, idispl, idispr, is, ie - real*4 sone0, ddc0, h0, sone, ddc, h - -c maximum number of layers in the model - mmax = nlayer -c is the model flat (nsph = 0) or sphere (nsph = 1) - nsph = iflsph - -c----- -c save current values - do 39 i=1,mmax - b(i) = vsm(i) - a(i) = vpm(i) - d(i) = thkm(i) - rho(i) = rhom(i) -c print *,d(i), b(i) - 39 continue - - if(iwave.eq.1)then - idispl = kmax - idispr = 0 - elseif(iwave.eq.2)then - idispl = 0 - idispr = kmax - endif - - iverb(1) = 0 - iverb(2) = 0 -c ---- constant value - sone0 = 1.500 -c ---- phase velocity increment for searching root - ddc0 = 0.005 -c ---- frequency increment (%) for calculating group vel. using g = dw/dk = dw/d(w/c) - h0 = 0.005 -c ---- period range is:ie for calculation of dispersion - -c----- -c check for water layer -c----- - llw=1 - if(b(1).le.0.0) llw=2 - twopi=2.d0*3.141592653589793d0 - one=1.0d-2 - if(nsph.eq.1) call sphere(0,0,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - JMN = 1 - betmx=-1.e20 - betmn=1.e20 -c----- -c find the extremal velocities to assist in starting search -c----- - do 20 i=1,mmax - if(b(i).gt.0.01 .and. b(i).lt.betmn)then - betmn = b(i) - jmn = i - jsol = 1 - elseif(b(i).le.0.01 .and. a(i).lt.betmn)then - betmn = a(i) - jmn = i - jsol = 0 - endif - if(b(i).gt.betmx) betmx=b(i) - 20 continue -cc WRITE(6,*)'betmn, betmx:',betmn, betmx -c if(idispl.gt.0)then -cc open(1,file='tmpsrfi.06',form='unformatted', -cc 1 access='sequential') -cc rewind 1 -c read(*,*) lovdispfile -c open(1, file = lovdispfile); -c endif -c if(idispr.gt.0)then -cc open(2,file='tmpsrfi.07',form='unformatted', -cc 1 access='sequential') -cc rewind 2 -c read(*,*) raydispfile -c open(2, file = raydispfile); -c endif - do 2000 ifunc=1,2 - if(ifunc.eq.1.and.idispl.le.0) go to 2000 - if(ifunc.eq.2.and.idispr.le.0) go to 2000 - if(nsph.eq.1) call sphere(ifunc,1,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - ddc = ddc0 - sone = sone0 - h = h0 -c read(*,*) kmax,mode,ddc,sone,igr,h -c write(*,*) kmax,mode,ddc,sone,igr,h -c read(*,*) (t(i),i=1,kmax) -c write(*,*) (t(i),i=1,kmax) -cc write(ifunc,*) mmax,nsph -cc write(ifunc,*) (btp(i),i=1,mmax) -cc write(ifunc,*) (dtp(i),i=1,mmax) -cc do 420 i=1,mmax -cc write(ifunc,*) d(i),a(i),b(i),rho(i) -cc 420 continue -c write(ifunc,*) kmax,igr,h - if(sone.lt. 0.01) sone=2.0 - onea=dble(sone) -c----- -c get starting value for phase velocity, -c which will correspond to the -c VP/VS ratio -c----- - if(jsol.eq.0)then -c----- -c water layer -c----- - cc1 = betmn - else -c----- -c solid layer solve halfspace period equation -c----- - call gtsolh(a(jmn),b(jmn),cc1) - endif -c----- -c back off a bit to get a starting value at a lower phase velocity -c----- - cc1=.95*cc1 - CC1=.90*CC1 - cc=dble(cc1) - dc=dble(ddc) - dc = dabs(dc) - c1=cc - cm=cc - do 450 i=1,kmax - cb(i)=0.0d0 - c(i)=0.0d0 - 450 continue - ift=999 - do 1800 iq=1,mode - is = 1 - ie = kmax -c read(*,*) is,ie -c write(*,*) 'is =', is, ', ie = ', ie - itst=ifunc - do 1600 k=is,ie - if(k.ge.ift) go to 1700 - t1=dble(t(k)) - if(igr.gt.0)then - t1a=t1/(1.+h) - t1b=t1/(1.-h) - t1=dble(t1a) - else - t1a=sngl(t1) - tlb=0.0 - endif -c----- -c get initial phase velocity estimate to begin search -c -c in the notation here, c() is an array of phase velocities -c c(k-1) is the velocity estimate of the present mode -c at the k-1 period, while c(k) is the phase velocity of the -c previous mode at the k period. Since there must be no mode -c crossing, we make use of these values. The only complexity -c is that the dispersion may be reversed. -c -c The subroutine getsol determines the zero crossing and refines -c the root. -c----- - if(k.eq.is .and. iq.eq.1)then - c1 = cc - clow = cc - ifirst = 1 - elseif(k.eq.is .and. iq.gt.1)then - c1 = c(is) + one*dc - clow = c1 - ifirst = 1 - elseif(k.gt.is .and. iq.gt.1)then - ifirst = 0 -c clow = c(k) + one*dc -c c1 = c(k-1) -onea*dc - clow = c(k) + one*dc - c1 = c(k-1) - if(c1 .lt. clow)c1 = clow - elseif(k.gt.is .and. iq.eq.1)then - ifirst = 0 - c1 = c(k-1) - onea*dc - clow = cm - endif -c----- -c bracket root and refine it -c----- - call getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) - if(iret.eq.-1)goto 1700 - c(k) = c1 -c----- -c for group velocities compute near above solution -c----- - if(igr.gt.0) then - t1=dble(t1b) - ifirst = 0 - clow = cb(k) + one*dc - c1 = c1 -onea*dc - call getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) -c----- -c test if root not found at slightly larger period -c----- - if(iret.eq.-1)then - c1 = c(k) - endif - cb(k)=c1 - else - c1 = 0.0d+00 - endif - cc0 = sngl(c(k)) - cc1 = sngl(c1) - if(igr.eq.0) then -c ----- output only phase velocity -c write(ifunc,*) itst,iq,t(k),cc0,0.0 - cg(k) = cc0 - else -c ----- calculate group velocity and output phase and group velocities - gvel = (1/t1a-1/t1b)/(1/(t1a*cc0)-1/(t1b*cc1)) - cg(k) = gvel -c write(ifunc,*) itst,iq,t(k),(cc0+cc1)/2,gvel -c ----- print *, itst,iq,t(k),t1a,t1b,cc0,cc1,gvel - endif - 1600 continue - go to 1800 - 1700 if(iq.gt.1) go to 1750 - if(iverb(ifunc).eq.0)then - iverb(ifunc) = 1 - write(LOT,*)'improper initial value in disper - no zero found' - write(*,*)'WARNING:improper initial value in disper - no zero found' - write(LOT,*)'in fundamental mode ' - write(LOT,*)'This may be due to low velocity zone ' - write(LOT,*)'causing reverse phase velocity dispersion, ' - write(LOT,*)'and mode jumping.' - write(LOT,*)'due to looking for Love waves in a halfspace' - write(LOT,*)'which is OK if there are Rayleigh data.' - write(LOT,*)'If reverse dispersion is the problem,' - write(LOT,*)'Get present model using OPTION 28, edit sobs.d,' - write(LOT,*)'Rerun with onel large than 2' - write(LOT,*)'which is the default ' -c----- -c if we have higher mode data and the model does not find that -c mode, just indicate (itst=0) that it has not been found, but -c fill out file with dummy results to maintain format - note -c eigenfunctions will not be found for these values. The subroutine -c 'amat' in 'surf' will worry about this in building up the -c input file for 'surfinv' -c----- - write(LOT,*)'ifunc = ',ifunc ,' (1=L, 2=R)' - write(LOT,*)'mode = ',iq-1 - write(LOT,*)'period= ',t(k), ' for k,is,ie=',k,is,ie - write(LOT,*)'cc,cm = ',cc,cm - write(LOT,*)'c1 = ',c1 - write(LOT,*)'d,a,b,rho (d(mmax)=control ignore)' - write(LOT,'(4f15.5)')(d(i),a(i),b(i),rho(i),i=1,mmax) - write(LOT,*)' c(i),i=1,k (NOTE may be part)' - write(LOT,*)(c(i),i=1,k) - endif -c if(k.gt.0)goto 1750 -c go to 2000 - 1750 ift=k - itst=0 - do 1770 i=k,ie - t1a=t(i) -c write(ifunc,*) itst,iq,t1a,0.0,0.0 - cg(i) = 0.0 - 1770 continue - 1800 continue -c close(ifunc,status='keep') - 2000 continue -c close(3,status='keep') - - end - - - - - - - subroutine gtsolh(a,b,c) -c----- -c starting solution -c----- - real*4 kappa, k2, gk2 - c = 0.95*b - do 100 i=1,5 - gamma = b/a - kappa = c/b - k2 = kappa**2 - gk2 = (gamma*kappa)**2 - fac1 = sqrt(1.0 - gk2) - fac2 = sqrt(1.0 - k2) - fr = (2.0 - k2)**2 - 4.0*fac1*fac2 - frp = -4.0*(2.0-k2) *kappa - 1 +4.0*fac2*gamma*gamma*kappa/fac1 - 2 +4.0*fac1*kappa/fac2 - frp = frp/b - c = c - fr/frp - 100 continue - return - end - - subroutine getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) -c----- -c subroutine to bracket dispersion curve -c and then refine it -c----- -c t1 - period -c c1 - initial guess on low side of mode -c clow - lowest possible value for present mode in a -c reversed direction search -c dc - phase velocity search increment -c cm - minimum possible solution -c betmx - maximum shear velocity -c iret - 1 = successful -c - -1= unsuccessful -c ifunc - 1 - Love -c - 2 - Rayleigh -c ifirst - 1 this is first period for a particular mode -c - 0 this is not the first period -c (this is to define period equation sign -c for mode jumping test) -c----- - parameter (NL=200) - real*8 wvno, omega, twopi - real*8 c1, c2, cn, cm, dc, t1, clow - real*8 dltar, del1, del2, del1st, plmn - save del1st - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - integer llw,mmax -c----- -c to avoid problems in mode jumping with reversed dispersion -c we note what the polarity of period equation is for phase -c velocities just beneath the zero crossing at the -c first period computed. -c----- -c bracket solution -c----- - twopi=2.d0*3.141592653589793d0 - omega=twopi/t1 - wvno=omega/c1 - del1 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - if(ifirst.eq.1)del1st = del1 - plmn = dsign(1.0d+00,del1st)*dsign(1.0d+00,del1) - if(ifirst.eq.1)then - idir = +1 - elseif(ifirst.ne.1 .and. plmn.ge.0.0d+00)then - idir = +1 - elseif(ifirst.ne.1 .and. plmn.lt.0.0d+00)then - idir = -1 - endif -c----- -c idir indicates the direction of the search for the -c true phase velocity from the initial estimate. -c Usually phase velocity increases with period and -c we always underestimate, so phase velocity should increase -c (idir = +1). For reversed dispersion, we should look -c downward from the present estimate. However, we never -c go below the floor of clow, when the direction is reversed -c----- - 1000 continue - if(idir.gt.0)then - c2 = c1 + dc - else - c2 = c1 - dc - endif - if(c2.le.clow)then - idir = +1 - c1 = clow - endif - if(c2.le.clow)goto 1000 - omega=twopi/t1 - wvno=omega/c2 - del2 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - if (dsign(1.0d+00,del1).ne.dsign(1.0d+00,del2)) then - go to 1300 - endif - c1=c2 - del1=del2 -c check that c1 is in region of solutions - if(c1.lt.cm) go to 1700 - if(c1.ge.(betmx+dc)) go to 1700 - go to 1000 -c----- -c root bracketed, refine it -c----- - 1300 call nevill(t1,c1,c2,del1,del2,ifunc,cn,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - c1 = cn - if(c1.gt.(betmx)) go to 1700 - iret = 1 - return - 1700 continue - iret = -1 - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - subroutine sphere(ifunc,iflag,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c----- -c Transform spherical earth to flat earth -c -c Schwab, F. A., and L. Knopoff (1972). Fast surface wave and free -c mode computations, in Methods in Computational Physics, -c Volume 11, -c Seismology: Surface Waves and Earth Oscillations, -c B. A. Bolt (ed), -c Academic Press, New York -c -c Love Wave Equations 44, 45 , 41 pp 112-113 -c Rayleigh Wave Equations 102, 108, 109 pp 142, 144 -c -c Revised 28 DEC 2007 to use mid-point, assume linear variation in -c slowness instead of using average velocity for the layer -c Use the Biswas (1972:PAGEOPH 96, 61-74, 1972) density mapping -c -c ifunc I*4 1 - Love Wave -c 2 - Rayleigh Wave -c iflag I*4 0 - Initialize -c 1 - Make model for Love or Rayleigh Wave -c----- - parameter(NL=200,NP=60) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - integer mmax,llw -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi - double precision z0,z1,r0,r1,dr,ar,tmp,twopi - save dhalf - ar=6370.0d0 - dr=0.0d0 - r0=ar - d(mmax)=1.0 - if(iflag.eq.0) then - do 5 i=1,mmax - dtp(i)=d(i) - rtp(i)=rho(i) - 5 continue - do 10 i=1,mmax - dr=dr+dble(d(i)) - r1=ar-dr - z0=ar*dlog(ar/r0) - z1=ar*dlog(ar/r1) - d(i)=z1-z0 -c----- -c use layer midpoint -c----- - TMP=(ar+ar)/(r0+r1) - a(i)=a(i)*tmp - b(i)=b(i)*tmp - btp(i)=tmp - r0=r1 - 10 continue - dhalf = d(mmax) - else - d(mmax) = dhalf - do 30 i=1,mmax - if(ifunc.eq.1)then - rho(i)=rtp(i)*btp(i)**(-5) - else if(ifunc.eq.2)then - rho(i)=rtp(i)*btp(i)**(-2.275) - endif - 30 continue - endif - d(mmax)=0.0 - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - subroutine nevill(t,c1,c2,del1,del2,ifunc,cc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c----- -c hybrid method for refining root once it has been bracketted -c between c1 and c2. interval halving is used where other schemes -c would be inefficient. once suitable region is found neville s -c iteration method is used to find root. -c the procedure alternates between the interval halving and neville -c techniques using whichever is most efficient -c----- -c the control integer nev means the following: -c -c nev = 0 force interval halving -c nev = 1 permit neville iteration if conditions are proper -c nev = 2 neville iteration is being used -c----- - parameter (NL=200,NP=60) - implicit double precision (a-h,o-z) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - dimension x(20),y(20) - integer llw,mmax -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi -c----- -c initial guess -c----- - omega = twopi/t - call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - nev = 1 - nctrl=1 - 100 continue - nctrl=nctrl+1 - if(nctrl.ge.100) go to 1000 -c----- -c make sure new estimate is inside the previous values. If not -c perform interval halving -c----- - if(c3 .lt. dmin1(c1,c2) .or. c3. gt.dmax1(c1,c2))then - nev = 0 - call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - endif - s13 = del1 - del3 - s32 = del3 - del2 -c----- -c define new bounds according to the sign of the period equation -c----- - if(dsign(1.d+00,del3)*dsign(1.d+00,del1) .lt.0.0d+00)then - c2 = c3 - del2 = del3 - else - c1 = c3 - del1 = del3 - endif -c----- -c check for convergence. A relative error criteria is used -c----- - if(dabs(c1-c2).le.1.d-6*c1) go to 1000 -c----- -c if the slopes are not the same between c1, c3 and c3 -c do not use neville iteration -c----- - if(dsign (1.0d+00,s13).ne.dsign (1.0d+00,s32)) nev = 0 -c----- -c if the period equation differs by more than a factor of 10 -c use interval halving to avoid poor behavior of polynomial fit -c----- - ss1=dabs(del1) - s1=0.01*ss1 - ss2=dabs(del2) - s2=0.01*ss2 - if(s1.gt.ss2.or.s2.gt.ss1 .or. nev.eq.0) then - call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - nev = 1 - m = 1 - else - if(nev.eq.2)then - x(m+1) = c3 - y(m+1) = del3 - else - x(1) = c1 - y(1) = del1 - x(2) = c2 - y(2) = del2 - m = 1 - endif -c----- -c perform Neville iteration. Note instead of generating y(x) -c we interchange the x and y of formula to solve for x(y) when -c y = 0 -c----- - do 900 kk = 1,m - j = m-kk+1 - denom = y(m+1) - y(j) - if(dabs(denom).lt.1.0d-10*abs(y(m+1)))goto 950 - x(j)=(-y(j)*x(j+1)+y(m+1)*x(j))/denom - 900 continue - c3 = x(1) - wvno = omega/c3 - del3 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - nev = 2 - m = m + 1 - if(m.gt.10)m = 10 - goto 951 - 950 continue - call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - nev = 1 - m = 1 - 951 continue - endif - goto 100 - 1000 continue - cc = c3 - return - end - - subroutine half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - implicit double precision (a-h,o-z) - parameter(NL=200) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - c3 = 0.5*(c1 + c2) - wvno=omega/c3 - del3 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - function dltar(wvno,omega,kk,d,a,b,rho,rtp,dtp,btp,mmax,llw,twop) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) -c control the way to P-SV or SH. -c - implicit double precision (a-h,o-z) - parameter(NL=200) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) -c - if(kk.eq.1)then -c love wave period equation - dltar = dltar1(wvno,omega,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - elseif(kk.eq.2)then -c rayleigh wave period equation - dltar = dltar4(wvno,omega,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - endif - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - function dltar1(wvno,omega,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c find SH dispersion values. -c - parameter (NL=200,NP=60) - implicit double precision (a-h,o-z) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - integer llw,mmax -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi -c -c Haskell-Thompson love wave formulation from halfspace -c to surface. -c - beta1=dble(b(mmax)) - rho1=dble(rho(mmax)) - xkb=omega/beta1 - wvnop=wvno+xkb - wvnom=dabs(wvno-xkb) - rb=dsqrt(wvnop*wvnom) - e1=rho1*rb - e2=1.d+00/(beta1*beta1) - mmm1 = mmax - 1 - do 600 m=mmm1,llw,-1 - beta1=dble(b(m)) - rho1=dble(rho(m)) - xmu=rho1*beta1*beta1 - xkb=omega/beta1 - wvnop=wvno+xkb - wvnom=dabs(wvno-xkb) - rb=dsqrt(wvnop*wvnom) - q = dble(d(m))*rb - if(wvno.lt.xkb)then - sinq = dsin(q) - y = sinq/rb - z = -rb*sinq - cosq = dcos(q) - elseif(wvno.eq.xkb)then - cosq=1.0d+00 - y=dble(d(m)) - z=0.0d+00 - else - fac = 0.0d+00 - if(q.lt.16)fac = dexp(-2.0d+0*q) - cosq = ( 1.0d+00 + fac ) * 0.5d+00 - sinq = ( 1.0d+00 - fac ) * 0.5d+00 - y = sinq/rb - z = rb*sinq - endif - e10=e1*cosq+e2*xmu*z - e20=e1*y/xmu+e2*cosq - xnor=dabs(e10) - ynor=dabs(e20) - if(ynor.gt.xnor) xnor=ynor - if(xnor.lt.1.d-40) xnor=1.0d+00 - e1=e10/xnor - e2=e20/xnor - 600 continue - dltar1=e1 - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - function dltar4(wvno,omga,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) -c find P-SV dispersion values. -c - parameter (NL=200,NP=60) - implicit double precision (a-h,o-z) - dimension e(5),ee(5),ca(5,5) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi -c common/ovrflw/ a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz -c - omega=omga - if(omega.lt.1.0d-4) omega=1.0d-4 - wvno2=wvno*wvno - xka=omega/dble(a(mmax)) - xkb=omega/dble(b(mmax)) - wvnop=wvno+xka - wvnom=dabs(wvno-xka) - ra=dsqrt(wvnop*wvnom) - wvnop=wvno+xkb - wvnom=dabs(wvno-xkb) - rb=dsqrt(wvnop*wvnom) - t = dble(b(mmax))/omega -c----- -c E matrix for the bottom half-space. -c----- - gammk = 2.d+00*t*t - gam = gammk*wvno2 - gamm1 = gam - 1.d+00 - rho1=dble(rho(mmax)) - e(1)=rho1*rho1*(gamm1*gamm1-gam*gammk*ra*rb) - e(2)=-rho1*ra - e(3)=rho1*(gamm1-gammk*ra*rb) - e(4)=rho1*rb - e(5)=wvno2-ra*rb -c----- -c matrix multiplication from bottom layer upward -c----- - mmm1 = mmax-1 - do 500 m = mmm1,llw,-1 - xka = omega/dble(a(m)) - xkb = omega/dble(b(m)) - t = dble(b(m))/omega - gammk = 2.d+00*t*t - gam = gammk*wvno2 - wvnop=wvno+xka - wvnom=dabs(wvno-xka) - ra=dsqrt(wvnop*wvnom) - wvnop=wvno+xkb - wvnom=dabs(wvno-xkb) - rb=dsqrt(wvnop*wvnom) - dpth=dble(d(m)) - rho1=dble(rho(m)) - p=ra*dpth - q=rb*dpth - beta=dble(b(m)) -c----- -c evaluate cosP, cosQ,.... in var. -c evaluate Dunkin's matrix in dnka. -c----- - call var(p,q,ra,rb,wvno,xka,xkb,dpth,w,cosp,exa, - & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - call dnka(ca,wvno2,gam,gammk,rho1, - & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - do 200 i=1,5 - cr=0.0d+00 - do 100 j=1,5 - cr=cr+e(j)*ca(j,i) - 100 continue - ee(i)=cr - 200 continue - call normc(ee,exa) - do 300 i = 1,5 - e(i)=ee(i) - 300 continue - 500 continue - if(llw.ne.1) then -c----- -c include water layer. -c----- - xka = omega/dble(a(1)) - wvnop=wvno+xka - wvnom=dabs(wvno-xka) - ra=dsqrt(wvnop*wvnom) - dpth=dble(d(1)) - rho1=dble(rho(1)) - p = ra*dpth - beta = dble(b(1)) - znul = 1.0d-05 - call var(p,znul,ra,znul,wvno,xka,znul,dpth,w,cosp,exa, - & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - w0=-rho1*w - dltar4 = cosp*e(1) + w0*e(2) - else - dltar4 = e(1) - endif - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine var(p,q,ra,rb,wvno,xka,xkb,dpth,w,cosp,exa,a0,cpcq, - & cpy,cpz,cqw,cqx,xy,xz,wy,wz) -c----- -c find variables cosP, cosQ, sinP, sinQ, etc. -c as well as cross products required for compound matrix -c----- -c To handle the hyperbolic functions correctly for large -c arguments, we use an extended precision procedure, -c keeping in mind that the maximum precision in double -c precision is on the order of 16 decimal places. -c -c So cosp = 0.5 ( exp(+p) + exp(-p)) -c = exp(p) * 0.5 * ( 1.0 + exp(-2p) ) -c becomes -c cosp = 0.5 * (1.0 + exp(-2p) ) with an exponent p -c In performing matrix multiplication, we multiply the modified -c cosp terms and add the exponents. At the last step -c when it is necessary to obtain a true amplitude, -c we then form exp(p). For normalized amplitudes at any depth, -c we carry an exponent for the numerator and the denominator, and -c scale the resulting ratio by exp(NUMexp - DENexp) -c -c The propagator matrices have three basic terms -c -c HSKA cosp cosq -c DUNKIN cosp*cosq 1.0 -c -c When the extended floating point is used, we use the -c largest exponent for each, which is the following: -c -c Let pex = p exponent > 0 for evanescent waves = 0 otherwise -c Let sex = s exponent > 0 for evanescent waves = 0 otherwise -c Let exa = pex + sex -c -c Then the modified matrix elements are as follow: -c -c Haskell: cosp -> 0.5 ( 1 + exp(-2p) ) exponent = pex -c cosq -> 0.5 ( 1 + exp(-2q) ) * exp(q-p) -c exponent = pex -c (this is because we are normalizing all elements in the -c Haskell matrix ) -c Compound: -c cosp * cosq -> normalized cosp * cosq exponent = pex + qex -c 1.0 -> exp(-exa) -c----- - implicit double precision (a-h,o-z) -c common/ovrflw/ a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz - exa=0.0d+00 - a0=1.0d+00 -c----- -c examine P-wave eigenfunctions -c checking whether c> vp c=vp or c < vp -c----- - pex = 0.0d+00 - sex = 0.0d+00 - if(wvno.lt.xka)then - sinp = dsin(p) - w=sinp/ra - x=-ra*sinp - cosp=dcos(p) - elseif(wvno.eq.xka)then - cosp = 1.0d+00 - w = dpth - x = 0.0d+00 - elseif(wvno.gt.xka)then - pex = p - fac = 0.0d+00 - if(p.lt.16)fac = dexp(-2.0d+00*p) - cosp = ( 1.0d+00 + fac) * 0.5d+00 - sinp = ( 1.0d+00 - fac) * 0.5d+00 - w=sinp/ra - x=ra*sinp - endif -c----- -c examine S-wave eigenfunctions -c checking whether c > vs, c = vs, c < vs -c----- - if(wvno.lt.xkb)then - sinq=dsin(q) - y=sinq/rb - z=-rb*sinq - cosq=dcos(q) - elseif(wvno.eq.xkb)then - cosq=1.0d+00 - y=dpth - z=0.0d+00 - elseif(wvno.gt.xkb)then - sex = q - fac = 0.0d+00 - if(q.lt.16)fac = dexp(-2.0d+0*q) - cosq = ( 1.0d+00 + fac ) * 0.5d+00 - sinq = ( 1.0d+00 - fac ) * 0.5d+00 - y = sinq/rb - z = rb*sinq - endif -c----- -c form eigenfunction products for use with compound matrices -c----- - exa = pex + sex - a0=0.0d+00 - if(exa.lt.60.0d+00) a0=dexp(-exa) - cpcq=cosp*cosq - cpy=cosp*y - cpz=cosp*z - cqw=cosq*w - cqx=cosq*x - xy=x*y - xz=x*z - wy=w*y - wz=w*z - qmp = sex - pex - fac = 0.0d+00 - if(qmp.gt.-40.0d+00)fac = dexp(qmp) - cosq = cosq*fac - y=fac*y - z=fac*z - return - end -c -c -c - subroutine normc(ee,ex) -c This routine is an important step to control over- or -c underflow. -c The Haskell or Dunkin vectors are normalized before -c the layer matrix stacking. -c Note that some precision will be lost during normalization. -c - implicit double precision (a-h,o-z) - dimension ee(5) - ex = 0.0d+00 - t1 = 0.0d+00 - do 10 i = 1,5 - if(dabs(ee(i)).gt.t1) t1 = dabs(ee(i)) - 10 continue - if(t1.lt.1.d-40) t1=1.d+00 - do 20 i =1,5 - t2=ee(i) - t2=t2/t1 - ee(i)=t2 - 20 continue -c----- -c store the normalization factor in exponential form. -c----- - ex=dlog(t1) - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - subroutine dnka(ca,wvno2,gam,gammk,rho, - & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) -c Dunkin's matrix. -c - implicit double precision (a-h,o-z) - dimension ca(5,5) -c common/ ovrflw / a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz - data one,two/1.d+00,2.d+00/ - gamm1 = gam-one - twgm1=gam+gamm1 - gmgmk=gam*gammk - gmgm1=gam*gamm1 - gm1sq=gamm1*gamm1 - rho2=rho*rho - a0pq=a0-cpcq - ca(1,1)=cpcq-two*gmgm1*a0pq-gmgmk*xz-wvno2*gm1sq*wy - ca(1,2)=(wvno2*cpy-cqx)/rho - ca(1,3)=-(twgm1*a0pq+gammk*xz+wvno2*gamm1*wy)/rho - ca(1,4)=(cpz-wvno2*cqw)/rho - ca(1,5)=-(two*wvno2*a0pq+xz+wvno2*wvno2*wy)/rho2 - ca(2,1)=(gmgmk*cpz-gm1sq*cqw)*rho - ca(2,2)=cpcq - ca(2,3)=gammk*cpz-gamm1*cqw - ca(2,4)=-wz - ca(2,5)=ca(1,4) - ca(4,1)=(gm1sq*cpy-gmgmk*cqx)*rho - ca(4,2)=-xy - ca(4,3)=gamm1*cpy-gammk*cqx - ca(4,4)=ca(2,2) - ca(4,5)=ca(1,2) - ca(5,1)=-(two*gmgmk*gm1sq*a0pq+gmgmk*gmgmk*xz+ - * gm1sq*gm1sq*wy)*rho2 - ca(5,2)=ca(4,1) - ca(5,3)=-(gammk*gamm1*twgm1*a0pq+gam*gammk*gammk*xz+ - * gamm1*gm1sq*wy)*rho - ca(5,4)=ca(2,1) - ca(5,5)=ca(1,1) - t=-two*wvno2 - ca(3,1)=t*ca(5,3) - ca(3,2)=t*ca(4,3) - ca(3,3)=a0+two*(cpcq-ca(1,1)) - ca(3,4)=t*ca(2,3) - ca(3,5)=t*ca(1,3) - return - end diff --git a/srcsparsity/CalSurfG.f90 b/srcsparsity/CalSurfG.f90 deleted file mode 100644 index 166c368..0000000 --- a/srcsparsity/CalSurfG.f90 +++ /dev/null @@ -1,2841 +0,0 @@ - subroutine depthkernel(nx,ny,nz,vel,pvRc,sen_vsRc,sen_vpRc,sen_rhoRc, & - iwave,igr,kmaxRc,tRc,depz,minthk) - use omp_lib - implicit none - - integer nx,ny,nz - real vel(nx,ny,nz) - real*8 sen_vpRc(ny*nx,kmaxRc,nz),sen_vsRc(ny*nx,kmaxRc,nz),sen_rhoRc(ny*nx,kmaxRc,nz) - - integer iwave,igr - real minthk - real depz(nz) - integer kmaxRc - real*8 tRc(kmaxRc) - real*8 pvRc(nx*ny,kmaxRc) - - - - real vpz(nz),vsz(nz),rhoz(nz) - real*8 dlncg_dlnvs(kmaxRc,nz),dlncg_dlnvp(kmaxRc,nz),dlncg_dlnrho(kmaxRc,nz) - integer mmax,iflsph,mode,rmax - integer ii,jj,k,i,nn,kk - integer,parameter::NL=200 - integer,parameter::NP=60 - real*8 cg1(NP),cg2(NP),cga,cgRc(NP) - real rdep(NL),rvp(NL),rvs(NL),rrho(NL),rthk(NL) - real depm(NL),vpm(NL),vsm(NL),rhom(NL),thkm(NL) - real dlnVs,dlnVp,dlnrho - - - mmax=nz - iflsph=1 - mode=1 - dlnVs=0.01 - dlnVp=0.01 - dlnrho=0.01 - - !print*,'depth kernel begin...' -!$omp parallel & -!$omp default(private) & -!$omp shared(depz,nx,ny,nz,minthk,dlnvs,dlnvp,dlnrho,kmaxRc,mmax,vel) & -!$omp shared(sen_vpRc,sen_vsRc,sen_rhoRc,tRc,pvRc,iflsph,iwave,mode,igr) -!$omp do - do jj=1,ny - do ii=1,nx - vsz(1:nz)=vel(ii,jj,1:nz) - ! some other emperical relationship maybe better, - do k=1,nz - vpz(k)=0.9409 + 2.0947*vsz(k) - 0.8206*vsz(k)**2+ & - 0.2683*vsz(k)**3 - 0.0251*vsz(k)**4 - rhoz(k)=1.6612*vpz(k) - 0.4721*vpz(k)**2 + & - 0.0671*vpz(k)**3 - 0.0043*vpz(k)**4 + & - 0.000106*vpz(k)**5 - enddo - - call refineGrid2LayerMdl(minthk,mmax,depz,vpz,vsz,rhoz,rmax,rdep,& - rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,igr,kmaxRc,& - tRc,cgRc) - pvRc((jj-1)*nx+ii,1:kmaxRc)=cgRc(1:kmaxRc) - !print*,cgRc(1:kmaxRc) - do kk=1,mmax-1 - depm(kk)=depz(kk) - vsm(kk) = vsz(kk) - vpm(kk) = vpz(kk) - thkm(kk) = depz(kk+1)-depz(kk) - rhom(kk) = rhoz(kk) - enddo - !!half space - depm(mmax)=depz(mmax) - vsm(mmax) = vsz(mmax) - vpm(mmax) = vpz(mmax) - rhom(mmax) = rhoz(mmax) - thkm(mmax) = 0.0 - !! calculate sensitivity kernel - do i = 1, mmax - vsm(i) = vsz(i) - 0.5*dlnVs*vsz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg1) - - vsm(i) = vsz(i) + 0.5*dlnVs*vsz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg2) - vsm(i) = vsz(i) - - do nn = 1,kmaxRc - cga = 0.5*(cg1(nn)+cg2(nn)) - dlncg_dlnvs(nn,i) = (cg2(nn)-cg1(nn))/cga/dlnVs - enddo - - - vpm(i) = vpz(i) - 0.5*dlnVp*vpz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg1) - - vpm(i) = vpz(i) + 0.5*dlnVp*vpz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg2) - vpm(i) = vpz(i) - - do nn = 1,kmaxRc - cga = 0.5*(cg1(nn)+cg2(nn)) - dlncg_dlnvp(nn,i) = (cg2(nn)-cg1(nn))/cga/dlnVp - enddo - rhom(i) = rhoz(i) - 0.5*dlnrho*rhoz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg1) - - rhom(i) = rhoz(i) + 0.5*dlnrho*rhoz(i) - call refineGrid2LayerMdl(minthk,mmax,depm,vpm,vsm,rhom,& - rmax,rdep,rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,& - igr,kmaxRc,tRc,cg2) - rhom(i) = rhoz(i) - - do nn = 1,kmaxRc - cga = 0.5*(cg1(nn)+cg2(nn)) - dlncg_dlnrho(nn,i) = (cg2(nn)-cg1(nn))/cga/dlnrho - enddo - enddo - sen_vsRc((jj-1)*nx+ii,1:kmaxRc,1:mmax)=dlncg_dlnvs(1:kmaxRc,1:mmax) - sen_vpRc((jj-1)*nx+ii,1:kmaxRc,1:mmax)=dlncg_dlnvp(1:kmaxRc,1:mmax) - sen_rhoRc((jj-1)*nx+ii,1:kmaxRc,1:mmax)=dlncg_dlnrho(1:kmaxRc,1:mmax) - ! print*,dlncg_dlnvp(1:kmaxRc,5) - enddo - enddo -!$omp end do -!$omp end parallel - end subroutine depthkernel - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: MODULE -! CODE: FORTRAN 90 -! This module declares variable for global use, that is, for -! USE in any subroutine or function or other module. -! Variables whose values are SAVEd can have their most -! recent values reused in any routine. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MODULE globalp -IMPLICIT NONE -INTEGER, PARAMETER :: i10=SELECTED_REAL_KIND(6) -INTEGER :: checkstat -INTEGER, SAVE :: nvx,nvz,nnx,nnz,fom,gdx,gdz -INTEGER, SAVE :: vnl,vnr,vnt,vnb,nrnx,nrnz,sgdl,rbint -INTEGER, SAVE :: nnxr,nnzr,asgr -INTEGER, DIMENSION (:,:), ALLOCATABLE :: nsts,nstsr,srs -REAL(KIND=i10), SAVE :: gox,goz,dnx,dnz,dvx,dvz,snb,earth -REAL(KIND=i10), SAVE :: goxd,gozd,dvxd,dvzd,dnxd,dnzd -REAL(KIND=i10), SAVE :: drnx,drnz,gorx,gorz -REAL(KIND=i10), SAVE :: dnxr,dnzr,goxr,gozr -REAL(KIND=i10), DIMENSION (:,:), ALLOCATABLE, SAVE :: velv,veln,velnb -REAL(KIND=i10), DIMENSION (:,:), ALLOCATABLE, SAVE :: ttn,ttnr -!REAL(KIND=i10), DIMENSION (:), ALLOCATABLE, SAVE :: rcx,rcz -REAL(KIND=i10), PARAMETER :: pi=3.1415926535898 -!!!-------------------------------------------------------------- -!! modified by Hongjian Fang @ USTC -! real,dimension(:),allocatable,save::rw -! integer,dimension(:),allocatable,save::iw,col -! real,dimension(:,:,:),allocatable::vpf,vsf -! real,dimension(:),allocatable,save::obst,cbst,wt,dtres -!! integer,dimension(:),allocatable,save::cbst_stat -! real,dimension(:,:,:),allocatable,save::sen_vs,sen_vp,sen_rho -!!! real,dimension(:,:,:),allocatable,save::sen_vsRc,sen_vpRc,sen_rhoRc -!!! real,dimension(:,:,:),allocatable,save::sen_vsRg,sen_vpRg,sen_rhoRg -!!! real,dimension(:,:,:),allocatable,save::sen_vsLc,sen_vpLc,sen_rhoLc -!!! real,dimension(:,:,:),allocatable,save::sen_vsLg,sen_vpLg,sen_rhoLg -!!! integer,save:: count1,count2 -! integer*8,save:: nar -! integer,save:: iter,maxiter -!!!-------------------------------------------------------------- -! -! nvx,nvz = B-spline vertex values -! dvx,dvz = B-spline vertex separation -! velv(i,j) = velocity values at control points -! nnx,nnz = Number of nodes of grid in x and z -! nnxr,nnzr = Number of nodes of refined grid in x and z -! gox,goz = Origin of grid (theta,phi) -! goxr, gozr = Origin of refined grid (theta,phi) -! dnx,dnz = Node separation of grid in x and z -! dnxr,dnzr = Node separation of refined grid in x and z -! veln(i,j) = velocity values on a refined grid of nodes -! velnb(i,j) = Backup of veln required for source grid refinement -! ttn(i,j) = traveltime field on the refined grid of nodes -! ttnr(i,j) = ttn for refined grid -! nsts(i,j) = node status (-1=far,0=alive,>0=close) -! nstsr(i,j) = nsts for refined grid -! checkstat = check status of memory allocation -! fom = use first-order(0) or mixed-order(1) scheme -! snb = Maximum size of narrow band as fraction of nnx*nnz -! nrc = number of receivers -! rcx(i),rcz(i) = (x,z) coordinates of receivers -! earth = radius of Earth (in km) -! goxd,gozd = gox,goz in degrees -! dvxd,dvzd = dvx,dvz in degrees -! dnzd,dnzd = dnx,dnz in degrees -! gdx,gdz = grid dicing in x and z -! vnl,vnr,vnb,vnt = Bounds of refined grid -! nrnx,nrnz = Number of nodes in x and z for refined grid -! gorx,gorz = Grid origin of refined grid -! sgdl = Source grid dicing level -! rbint = Ray-boundary intersection (0=no, 1=yes). -! asgr = Apply source grid refinement (0=no,1=yes) -! srs = Source-receiver status (0=no path, 1=path exists) -! -END MODULE globalp - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: MODULE -! CODE: FORTRAN 90 -! This module contains all the subroutines used to calculate -! the first-arrival traveltime field through the grid. -! Subroutines are: -! (1) travel -! (2) fouds1 -! (3) fouds2 -! (4) addtree -! (5) downtree -! (6) updtree -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MODULE traveltime -USE globalp -IMPLICIT NONE -INTEGER ntr -TYPE backpointer - INTEGER(KIND=2) :: px,pz -END TYPE backpointer -TYPE(backpointer), DIMENSION (:), ALLOCATABLE :: btg -! -! btg = backpointer to relate grid nodes to binary tree entries -! px = grid-point in x -! pz = grid-point in z -! ntr = number of entries in binary tree -! - -CONTAINS - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine is passed the location of a source, and from -! this point the first-arrival traveltime field through the -! velocity grid is determined. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE travel(scx,scz,urg) -IMPLICIT NONE -INTEGER :: isx,isz,sw,i,j,ix,iz,urg,swrg -REAL(KIND=i10) :: scx,scz,vsrc,dsx,dsz,ds -REAL(KIND=i10), DIMENSION (2,2) :: vss -! isx,isz = grid cell indices (i,j,k) which contains source -! scx,scz = (r,x,y) location of source -! sw = a switch (0=off,1=on) -! ix,iz = j,k position of "close" point with minimum traveltime -! maxbt = maximum size of narrow band binary tree -! rd2,rd3 = substitution variables -! vsrc = velocity at source -! vss = velocity at nodes surrounding source -! dsx, dsz = distance from source to cell boundary in x and z -! ds = distance from source to nearby node -! urg = use refined grid (0=no,1=yes,2=previously used) -! swrg = switch to end refined source grid computation -! -! The first step is to find out where the source resides -! in the grid of nodes. The cell in which it resides is -! identified by the "north-west" node of the cell. If the -! source lies on the edge or corner (a node) of the cell, then -! this scheme still applies. -! -isx=INT((scx-gox)/dnx)+1 -isz=INT((scz-goz)/dnz)+1 -sw=0 -IF(isx.lt.1.or.isx.gt.nnx)sw=1 -IF(isz.lt.1.or.isz.gt.nnz)sw=1 -IF(sw.eq.1)then - isx=90.0-isx*180.0/pi - isz=isz*180.0/pi - WRITE(6,*)"Source lies outside bounds of model (lat,long)= ",isx,isz - WRITE(6,*)"TERMINATING PROGRAM!!!" - STOP -ENDIF -IF(isx.eq.nnx)isx=isx-1 -IF(isz.eq.nnz)isz=isz-1 -! -! Set all values of nsts to -1 if beginning from a source -! point. -! -IF(urg.NE.2)nsts=-1 -! -! set initial size of binary tree to zero -! -ntr=0 -IF(urg.EQ.2)THEN -! -! In this case, source grid refinement has been applied, so -! the initial narrow band will come from resampling the -! refined grid. -! - DO i=1,nnx - DO j=1,nnz - IF(nsts(j,i).GT.0)THEN - CALL addtree(j,i) - ENDIF - ENDDO - ENDDO -ELSE -! -! In general, the source point need not lie on a grid point. -! Bi-linear interpolation is used to find velocity at the -! source point. -! - nsts=-1 - DO i=1,2 - DO j=1,2 - vss(i,j)=veln(isz-1+j,isx-1+i) - ENDDO - ENDDO - dsx=(scx-gox)-(isx-1)*dnx - dsz=(scz-goz)-(isz-1)*dnz - CALL bilinear(vss,dsx,dsz,vsrc) -! -! Now find the traveltime at the four surrounding grid points. This -! is calculated approximately by assuming the traveltime from the -! source point to each node is equal to the the distance between -! the two points divided by the average velocity of the points -! - DO i=1,2 - DO j=1,2 - ds=SQRT((dsx-(i-1)*dnx)**2+(dsz-(j-1)*dnz)**2) - ttn(isz-1+j,isx-1+i)=2.0*ds/(vss(i,j)+vsrc) - CALL addtree(isz-1+j,isx-1+i) - ENDDO - ENDDO -ENDIF -! -! Now calculate the first-arrival traveltimes at the -! remaining grid points. This is done via a loop which -! repeats the procedure of finding the first-arrival -! of all "close" points, adding it to the set of "alive" -! points and updating the points surrounding the new "alive" -! point. The process ceases when the binary tree is empty, -! in which case all grid points are "alive". -! -DO WHILE(ntr.gt.0) -! -! First, check whether source grid refinement is -! being applied; if so, then there is a special -! exit condition. -! -IF(urg.EQ.1)THEN - ix=btg(1)%px - iz=btg(1)%pz - swrg=0 - IF(ix.EQ.1)THEN - IF(vnl.NE.1)swrg=1 - ENDIF - IF(ix.EQ.nnx)THEN - IF(vnr.NE.nnx)swrg=1 - ENDIF - IF(iz.EQ.1)THEN - IF(vnt.NE.1)swrg=1 - ENDIF - IF(iz.EQ.nnz)THEN - IF(vnb.NE.nnz)swrg=1 - ENDIF - IF(swrg.EQ.1)THEN - nsts(iz,ix)=0 - EXIT - ENDIF -ENDIF -! -! Set the "close" point with minimum traveltime -! to "alive" -! - ix=btg(1)%px - iz=btg(1)%pz - nsts(iz,ix)=0 -! -! Update the binary tree by removing the root and -! sweeping down the tree. -! - CALL downtree -! -! Now update or find values of up to four grid points -! that surround the new "alive" point. -! -! Test points that vary in x -! - DO i=ix-1,ix+1,2 - IF(i.ge.1.and.i.le.nnx)THEN - IF(nsts(iz,i).eq.-1)THEN -! -! This option occurs when a far point is added to the list -! of "close" points -! - IF(fom.eq.0)THEN - CALL fouds1(iz,i) - ELSE - CALL fouds2(iz,i) - ENDIF - CALL addtree(iz,i) - ELSE IF(nsts(iz,i).gt.0)THEN -! -! This happens when a "close" point is updated -! - IF(fom.eq.0)THEN - CALL fouds1(iz,i) - ELSE - CALL fouds2(iz,i) - ENDIF - CALL updtree(iz,i) - ENDIF - ENDIF - ENDDO -! -! Test points that vary in z -! - DO i=iz-1,iz+1,2 - IF(i.ge.1.and.i.le.nnz)THEN - IF(nsts(i,ix).eq.-1)THEN -! -! This option occurs when a far point is added to the list -! of "close" points -! - IF(fom.eq.0)THEN - CALL fouds1(i,ix) - ELSE - CALL fouds2(i,ix) - ENDIF - CALL addtree(i,ix) - ELSE IF(nsts(i,ix).gt.0)THEN -! -! This happens when a "close" point is updated -! - IF(fom.eq.0)THEN - CALL fouds1(i,ix) - ELSE - CALL fouds2(i,ix) - ENDIF - CALL updtree(i,ix) - ENDIF - ENDIF - ENDDO -ENDDO -END SUBROUTINE travel - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine calculates a trial first-arrival traveltime -! at a given node from surrounding nodes using the -! First-Order Upwind Difference Scheme (FOUDS) of -! Sethian and Popovici (1999). -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE fouds1(iz,ix) -IMPLICIT NONE -INTEGER :: j,k,ix,iz,tsw1,swsol -REAL(KIND=i10) :: trav,travm,slown,tdsh,tref -REAL(KIND=i10) :: a,b,c,u,v,em,ri,risti -REAL(KIND=i10) :: rd1 -! -! ix = NS position of node coordinate for determination -! iz = EW vertical position of node coordinate for determination -! trav = traveltime calculated for trial node -! travm = minimum traveltime calculated for trial node -! slown = slowness at (iz,ix) -! tsw1 = traveltime switch (0=first time,1=previously) -! a,b,c,u,v,em = Convenience variables for solving quadratic -! tdsh = local traveltime from neighbouring node -! tref = reference traveltime at neighbouring node -! ri = Radial distance -! risti = ri*sin(theta) at point (iz,ix) -! rd1 = dummy variable -! swsol = switch for solution (0=no solution, 1=solution) -! -! Inspect each of the four quadrants for the minimum time -! solution. -! -tsw1=0 -slown=1.0/veln(iz,ix) -ri=earth -risti=ri*sin(gox+(ix-1)*dnx) -DO j=ix-1,ix+1,2 - DO k=iz-1,iz+1,2 - IF(j.GE.1.AND.j.LE.nnx)THEN - IF(k.GE.1.AND.k.LE.nnz)THEN -! -! There are seven solution options in -! each quadrant. -! - swsol=0 - IF(nsts(iz,j).EQ.0)THEN - swsol=1 - IF(nsts(k,ix).EQ.0)THEN - u=ri*dnx - v=risti*dnz - em=ttn(k,ix)-ttn(iz,j) - a=u**2+v**2 - b=-2.0*u**2*em - c=u**2*(em**2-v**2*slown**2) - tref=ttn(iz,j) - ELSE - a=1.0 - b=0.0 - c=-slown**2*ri**2*dnx**2 - tref=ttn(iz,j) - ENDIF - ELSE IF(nsts(k,ix).EQ.0)THEN - swsol=1 - a=1.0 - b=0.0 - c=-(slown*risti*dnz)**2 - tref=ttn(k,ix) - ENDIF -! -! Now find the solution of the quadratic equation -! - IF(swsol.EQ.1)THEN - rd1=b**2-4.0*a*c - IF(rd1.LT.0.0)rd1=0.0 - tdsh=(-b+sqrt(rd1))/(2.0*a) - trav=tref+tdsh - IF(tsw1.EQ.1)THEN - travm=MIN(trav,travm) - ELSE - travm=trav - tsw1=1 - ENDIF - ENDIF - ENDIF - ENDIF - ENDDO -ENDDO -ttn(iz,ix)=travm -END SUBROUTINE fouds1 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine calculates a trial first-arrival traveltime -! at a given node from surrounding nodes using the -! Mixed-Order (2nd) Upwind Difference Scheme (FOUDS) of -! Popovici and Sethian (2002). -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE fouds2(iz,ix) -IMPLICIT NONE -INTEGER :: j,k,j2,k2,ix,iz,tsw1 -INTEGER :: swj,swk,swsol -REAL(KIND=i10) :: trav,travm,slown,tdsh,tref,tdiv -REAL(KIND=i10) :: a,b,c,u,v,em,ri,risti,rd1 -! -! ix = NS position of node coordinate for determination -! iz = EW vertical position of node coordinate for determination -! trav = traveltime calculated for trial node -! travm = minimum traveltime calculated for trial node -! slown = slowness at (iz,ix) -! tsw1 = traveltime switch (0=first time,1=previously) -! a,b,c,u,v,em = Convenience variables for solving quadratic -! tdsh = local traveltime from neighbouring node -! tref = reference traveltime at neighbouring node -! ri = Radial distance -! risti = ri*sin(theta) at point (iz,ix) -! swj,swk = switches for second order operators -! tdiv = term to divide tref by depending on operator order -! swsol = switch for solution (0=no solution, 1=solution) -! -! Inspect each of the four quadrants for the minimum time -! solution. -! -tsw1=0 -slown=1.0/veln(iz,ix) -ri=earth -risti=ri*sin(gox+(ix-1)*dnx) -DO j=ix-1,ix+1,2 - IF(j.GE.1.AND.j.LE.nnx)THEN - swj=-1 - IF(j.eq.ix-1)THEN - j2=j-1 - IF(j2.GE.1)THEN - IF(nsts(iz,j2).EQ.0)swj=0 - ENDIF - ELSE - j2=j+1 - IF(j2.LE.nnx)THEN - IF(nsts(iz,j2).EQ.0)swj=0 - ENDIF - ENDIF - IF(nsts(iz,j).EQ.0.AND.swj.EQ.0)THEN - swj=-1 - IF(ttn(iz,j).GT.ttn(iz,j2))THEN - swj=0 - ENDIF - ELSE - swj=-1 - ENDIF - DO k=iz-1,iz+1,2 - IF(k.GE.1.AND.k.LE.nnz)THEN - swk=-1 - IF(k.eq.iz-1)THEN - k2=k-1 - IF(k2.GE.1)THEN - IF(nsts(k2,ix).EQ.0)swk=0 - ENDIF - ELSE - k2=k+1 - IF(k2.LE.nnz)THEN - IF(nsts(k2,ix).EQ.0)swk=0 - ENDIF - ENDIF - IF(nsts(k,ix).EQ.0.AND.swk.EQ.0)THEN - swk=-1 - IF(ttn(k,ix).GT.ttn(k2,ix))THEN - swk=0 - ENDIF - ELSE - swk=-1 - ENDIF -! -! There are 8 solution options in -! each quadrant. -! - swsol=0 - IF(swj.EQ.0)THEN - swsol=1 - IF(swk.EQ.0)THEN - u=2.0*ri*dnx - v=2.0*risti*dnz - em=4.0*ttn(iz,j)-ttn(iz,j2)-4.0*ttn(k,ix) - em=em+ttn(k2,ix) - a=v**2+u**2 - b=2.0*em*u**2 - c=u**2*(em**2-slown**2*v**2) - tref=4.0*ttn(iz,j)-ttn(iz,j2) - tdiv=3.0 - ELSE IF(nsts(k,ix).EQ.0)THEN - u=risti*dnz - v=2.0*ri*dnx - em=3.0*ttn(k,ix)-4.0*ttn(iz,j)+ttn(iz,j2) - a=v**2+9.0*u**2 - b=6.0*em*u**2 - c=u**2*(em**2-slown**2*v**2) - tref=ttn(k,ix) - tdiv=1.0 - ELSE - u=2.0*ri*dnx - a=1.0 - b=0.0 - c=-u**2*slown**2 - tref=4.0*ttn(iz,j)-ttn(iz,j2) - tdiv=3.0 - ENDIF - ELSE IF(nsts(iz,j).EQ.0)THEN - swsol=1 - IF(swk.EQ.0)THEN - u=ri*dnx - v=2.0*risti*dnz - em=3.0*ttn(iz,j)-4.0*ttn(k,ix)+ttn(k2,ix) - a=v**2+9.0*u**2 - b=6.0*em*u**2 - c=u**2*(em**2-v**2*slown**2) - tref=ttn(iz,j) - tdiv=1.0 - ELSE IF(nsts(k,ix).EQ.0)THEN - u=ri*dnx - v=risti*dnz - em=ttn(k,ix)-ttn(iz,j) - a=u**2+v**2 - b=-2.0*u**2*em - c=u**2*(em**2-v**2*slown**2) - tref=ttn(iz,j) - tdiv=1.0 - ELSE - a=1.0 - b=0.0 - c=-slown**2*ri**2*dnx**2 - tref=ttn(iz,j) - tdiv=1.0 - ENDIF - ELSE - IF(swk.EQ.0)THEN - swsol=1 - u=2.0*risti*dnz - a=1.0 - b=0.0 - c=-u**2*slown**2 - tref=4.0*ttn(k,ix)-ttn(k2,ix) - tdiv=3.0 - ELSE IF(nsts(k,ix).EQ.0)THEN - swsol=1 - a=1.0 - b=0.0 - c=-slown**2*risti**2*dnz**2 - tref=ttn(k,ix) - tdiv=1.0 - ENDIF - ENDIF -! -! Now find the solution of the quadratic equation -! - IF(swsol.EQ.1)THEN - rd1=b**2-4.0*a*c - IF(rd1.LT.0.0)rd1=0.0 - tdsh=(-b+sqrt(rd1))/(2.0*a) - trav=(tref+tdsh)/tdiv - IF(tsw1.EQ.1)THEN - travm=MIN(trav,travm) - ELSE - travm=trav - tsw1=1 - ENDIF - ENDIF - ENDIF - ENDDO - ENDIF -ENDDO -ttn(iz,ix)=travm -END SUBROUTINE fouds2 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine adds a value to the binary tree by -! placing a value at the bottom and pushing it up -! to its correct position. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE addtree(iz,ix) -IMPLICIT NONE -INTEGER :: ix,iz,tpp,tpc -TYPE(backpointer) :: exch -! -! ix,iz = grid position of new addition to tree -! tpp = tree position of parent -! tpc = tree position of child -! exch = dummy to exchange btg values -! -! First, increase the size of the tree by one. -! -ntr=ntr+1 -! -! Put new value at base of tree -! -nsts(iz,ix)=ntr -btg(ntr)%px=ix -btg(ntr)%pz=iz -! -! Now filter the new value up to its correct position -! -tpc=ntr -tpp=tpc/2 -DO WHILE(tpp.gt.0) - IF(ttn(iz,ix).lt.ttn(btg(tpp)%pz,btg(tpp)%px))THEN - nsts(iz,ix)=tpp - nsts(btg(tpp)%pz,btg(tpp)%px)=tpc - exch=btg(tpc) - btg(tpc)=btg(tpp) - btg(tpp)=exch - tpc=tpp - tpp=tpc/2 - ELSE - tpp=0 - ENDIF -ENDDO -END SUBROUTINE addtree - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine updates the binary tree after the root -! value has been used. The root is replaced by the value -! at the bottom of the tree, which is then filtered down -! to its correct position. This ensures that the tree remains -! balanced. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE downtree -IMPLICIT NONE -INTEGER :: tpp,tpc -REAL(KIND=i10) :: rd1,rd2 -TYPE(backpointer) :: exch -! -! tpp = tree position of parent -! tpc = tree position of child -! exch = dummy to exchange btg values -! rd1,rd2 = substitution variables -! -! Replace root of tree with its last value -! -IF(ntr.EQ.1)THEN - ntr=ntr-1 - RETURN -ENDIF -nsts(btg(ntr)%pz,btg(ntr)%px)=1 -btg(1)=btg(ntr) -! -! Reduce size of tree by one -! -ntr=ntr-1 -! -! Now filter new root down to its correct position -! -tpp=1 -tpc=2*tpp -DO WHILE(tpc.lt.ntr) -! -! Check which of the two children is smallest - use the smallest -! - rd1=ttn(btg(tpc)%pz,btg(tpc)%px) - rd2=ttn(btg(tpc+1)%pz,btg(tpc+1)%px) - IF(rd1.gt.rd2)THEN - tpc=tpc+1 - ENDIF -! -! Check whether the child is smaller than the parent; if so, then swap, -! if not, then we are done -! - rd1=ttn(btg(tpc)%pz,btg(tpc)%px) - rd2=ttn(btg(tpp)%pz,btg(tpp)%px) - IF(rd1.lt.rd2)THEN - nsts(btg(tpp)%pz,btg(tpp)%px)=tpc - nsts(btg(tpc)%pz,btg(tpc)%px)=tpp - exch=btg(tpc) - btg(tpc)=btg(tpp) - btg(tpp)=exch - tpp=tpc - tpc=2*tpp - ELSE - tpc=ntr+1 - ENDIF -ENDDO -! -! If ntr is an even number, then we still have one more test to do -! -IF(tpc.eq.ntr)THEN - rd1=ttn(btg(tpc)%pz,btg(tpc)%px) - rd2=ttn(btg(tpp)%pz,btg(tpp)%px) - IF(rd1.lt.rd2)THEN - nsts(btg(tpp)%pz,btg(tpp)%px)=tpc - nsts(btg(tpc)%pz,btg(tpc)%px)=tpp - exch=btg(tpc) - btg(tpc)=btg(tpp) - btg(tpp)=exch - ENDIF -ENDIF -END SUBROUTINE downtree - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine updates a value on the binary tree. The FMM -! should only produce updated values that are less than their -! prior values. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE updtree(iz,ix) -IMPLICIT NONE -INTEGER :: ix,iz,tpp,tpc -TYPE(backpointer) :: exch -! -! ix,iz = grid position of new addition to tree -! tpp = tree position of parent -! tpc = tree position of child -! exch = dummy to exchange btg values -! -! Filter the updated value to its correct position -! -tpc=nsts(iz,ix) -tpp=tpc/2 -DO WHILE(tpp.gt.0) - IF(ttn(iz,ix).lt.ttn(btg(tpp)%pz,btg(tpp)%px))THEN - nsts(iz,ix)=tpp - nsts(btg(tpp)%pz,btg(tpp)%px)=tpc - exch=btg(tpc) - btg(tpc)=btg(tpp) - btg(tpp)=exch - tpc=tpp - tpp=tpc/2 - ELSE - tpp=0 - ENDIF -ENDDO -END SUBROUTINE updtree - -END MODULE traveltime - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! MAIN PROGRAM -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: PROGRAM -! CODE: FORTRAN 90 -! This program is designed to implement the Fast Marching -! Method (FMM) for calculating first-arrival traveltimes -! through a 2-D continuous velocity medium in spherical shell -! coordinates (x=theta or latitude, z=phi or longitude). -! It is written in Fortran 90, although it is probably more -! accurately described as Fortran 77 with some of the Fortran 90 -! extensions. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!PROGRAM tomo_surf -subroutine CalSurfG(nx,ny,nz,nparpi,vels,iw,rw,col,dsurf, & - goxdf,gozdf,dvxdf,dvzdf,kmaxRc,kmaxRg,kmaxLc,kmaxLg, & - tRc,tRg,tLc,tLg,wavetype,igrt,periods,depz,minthk, & - scxf,sczf,rcxf,rczf,nrc1,nsrcsurf1,knum1,kmax,nsrcsurf,nrcf, & - nar,domain,maxlevel,maxleveld,HorizonType,VerticalType,writepath) -USE globalp -USE traveltime -IMPLICIT NONE -!CHARACTER (LEN=30) ::grid,frechet -!CHARACTER (LEN=40) :: sources,receivers,otimes -!CHARACTER (LEN=30) :: travelt,rtravel,wrays,cdum -INTEGER :: i,j,k,l,nsrc,tnr,urg -INTEGER :: sgs,isx,isz,sw,idm1,idm2,nnxb,nnzb -INTEGER :: ogx,ogz,grdfx,grdfz,maxbt -REAL(KIND=i10) :: x,z,goxb,gozb,dnxb,dnzb -!REAL(KIND=i10), DIMENSION (:,:), ALLOCATABLE :: scxf,sczf -!REAL(KIND=i10), DIMENSION (:,:,:), ALLOCATABLE :: rcxf,rczf -! -! sources = File containing source locations -! receivers = File containing receiver locations -! grid = File containing grid of velocity vertices for -! resampling on a finer grid with cubic B-splines -! frechet = output file containing matrix of frechet derivatives -! travelt = File name for storage of traveltime field -! wttf = Write traveltimes to file? (0=no,>0=source id) -! fom = Use first-order(0) or mixed-order(1) scheme -! nsrc = number of sources -! scx,scz = source location in r,x,z -! scx,scz = source location in r,x,z -! x,z = temporary variables for source location -! fsrt = find source-receiver traveltimes? (0=no,1=yes) -! rtravel = output file for source-receiver traveltimes -! cdum = dummy character variable ! wrgf = write ray geometries to file? (<0=all,0=no,>0=source id.) -! wrays = file containing raypath geometries -! cfd = calculate Frechet derivatives? (0=no, 1=yes) -! tnr = total number of receivers -! sgs = Extent of refined source grid -! isx,isz = cell containing source -! nnxb,nnzb = Backup for nnz,nnx -! goxb,gozb = Backup for gox,goz -! dnxb,dnzb = Backup for dnx,dnz -! ogx,ogz = Location of refined grid origin -! gridfx,grdfz = Number of refined nodes per cell -! urg = use refined grid (0=no,1=yes,2=previously used) -! maxbt = maximum size of narrow band binary tree -! otimes = file containing source-receiver association information -!c----------------------------------------------------------------- -! variables defined by Hongjian Fang - integer nx,ny,nz - integer kmax,nsrcsurf,nrcf - real vels(nx,ny,nz) - real rw(*) - integer iw(*),col(*) - real dsurf(*) - real goxdf,gozdf,dvxdf,dvzdf - integer kmaxRc,kmaxRg,kmaxLc,kmaxLg - real*8 tRc(*),tRg(*),tLc(*),tLg(*) - integer wavetype(nsrcsurf,kmax) - integer periods(nsrcsurf,kmax),nrc1(nsrcsurf,kmax),nsrcsurf1(kmax) - integer knum1(kmax),igrt(nsrcsurf,kmax) - real scxf(nsrcsurf,kmax),sczf(nsrcsurf,kmax),rcxf(nrcf,nsrcsurf,kmax),rczf(nrcf,nsrcsurf,kmax) - integer nar - real minthk - integer nparpi - - - real vpz(nz),vsz(nz),rhoz(nz),depz(nz) - real*8 pvRc(nx*ny,kmaxRc),pvRg(nx*ny,kmaxRg),pvLc(nx*ny,kmaxLc),pvLg(nx*ny,kmaxLg) - real*8 sen_vsRc(nx*ny,kmaxRc,nz),sen_vpRc(nx*ny,kmaxRc,nz) - real*8 sen_rhoRc(nx*ny,kmaxRc,nz) - real*8 sen_vsRg(nx*ny,kmaxRg,nz),sen_vpRg(nx*ny,kmaxRg,nz) - real*8 sen_rhoRg(nx*ny,kmaxRg,nz) - real*8 sen_vsLc(nx*ny,kmaxLc,nz),sen_vpLc(nx*ny,kmaxLc,nz) - real*8 sen_rhoLc(nx*ny,kmaxLc,nz) - real*8 sen_vsLg(nx*ny,kmaxLg,nz),sen_vpLg(nx*ny,kmaxLg,nz) - real*8 sen_rhoLg(nx*ny,kmaxLg,nz) - real*8 sen_vs(nx*ny,kmax,nz),sen_vp(nx*ny,kmax,nz) - real*8 sen_rho(nx*ny,kmax,nz) - real coe_rho(nz-1),coe_a(nz-1) - real*8 velf(ny*nx) - integer kmax1,kmax2,kmax3,count1 - integer igr - integer iwave - integer knumi,srcnum - real,dimension(:,:),allocatable:: fdm - real row(nparpi) - real vpft(nz-1) - real cbst1 - integer ii,jj,kk,nn,istep - integer level,maxlevel,maxleveld,HorizonType,VerticalType,PorS - real,parameter::ftol=1e-4 - integer writepath,domain -gdx=5 -gdz=5 -asgr=1 -sgdl=8 -sgs=8 -earth=6371.0 -fom=1 -snb=0.5 -goxd=goxdf -gozd=gozdf -dvxd=dvxdf -dvzd=dvzdf -nvx=nx-2 -nvz=ny-2 -ALLOCATE(velv(0:nvz+1,0:nvx+1), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE gridder: REAL velv' -ENDIF -! -! Convert from degrees to radians -! -dvx=dvxd*pi/180.0 -dvz=dvzd*pi/180.0 -gox=(90.0-goxd)*pi/180.0 -goz=gozd*pi/180.0 -! -! Compute corresponding values for propagation grid. -! -nnx=(nvx-1)*gdx+1 -nnz=(nvz-1)*gdz+1 -dnx=dvx/gdx -dnz=dvz/gdz -dnxd=dvxd/gdx -dnzd=dvzd/gdz -ALLOCATE(veln(nnz,nnx), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE gridder: REAL veln' -ENDIF - -! -! Call a subroutine which reads in the velocity grid -! -!CALL gridder(grid) -! -! Read in all source coordinates. -! -! -! Now work out, source by source, the first-arrival traveltime -! field plus source-receiver traveltimes -! and ray paths if required. First, allocate memory to the -! traveltime field array -! -ALLOCATE(ttn(nnz,nnx), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: PROGRAM fmmin2d: REAL ttn' -ENDIF - rbint=0 -! -! Allocate memory for node status and binary trees -! -ALLOCATE(nsts(nnz,nnx)) -maxbt=NINT(snb*nnx*nnz) -ALLOCATE(btg(maxbt)) - -allocate(fdm(0:nvz+1,0:nvx+1)) - - if(kmaxRc.gt.0) then - iwave=2 - igr=0 - call depthkernel(nx,ny,nz,vels,pvRc,sen_vsRc,sen_vpRc, & - sen_rhoRc,iwave,igr,kmaxRc,tRc,depz,minthk) - endif - - if(kmaxRg.gt.0) then - iwave=2 - igr=1 - call depthkernel(nx,ny,nz,vels,pvRg,sen_vsRg,sen_vpRg, & - sen_rhoRg,iwave,igr,kmaxRg,tRg,depz,minthk) - endif - - if(kmaxLc.gt.0) then - iwave=1 - igr=0 - call depthkernel(nx,ny,nz,vels,pvLc,sen_vsLc,sen_vpLc, & - sen_rhoLc,iwave,igr,kmaxLc,tLc,depz,minthk) - endif - - if(kmaxLg.gt.0) then - iwave=1 - igr=1 - call depthkernel(nx,ny,nz,vels,pvLg,sen_vsLg,sen_vpLg, & - sen_rhoLg,iwave,igr,kmaxLg,tLg,depz,minthk) - endif - -nar=0 -count1=0 - -sen_vs=0 -sen_vp=0 -sen_rho=0 -kmax1=kmaxRc -kmax2=kmaxRc+kmaxRg -kmax3=kmaxRc+kmaxRg+kmaxLc -do knumi=1,kmax -do srcnum=1,nsrcsurf1(knum1(knumi)) - if(wavetype(srcnum,knum1(knumi))==2.and.igrt(srcnum,knum1(knumi))==0) then - velf(1:nx*ny)=pvRc(1:nx*ny,periods(srcnum,knum1(knumi))) - sen_vs(:,1:kmax1,:)=sen_vsRc(:,1:kmaxRc,:)!(:,nt(istep),:) - sen_vp(:,1:kmax1,:)=sen_vpRc(:,1:kmaxRc,:)!(:,nt(istep),:) - sen_rho(:,1:kmax1,:)=sen_rhoRc(:,1:kmaxRc,:)!(:,nt(istep),:) - endif - if(wavetype(srcnum,knum1(knumi))==2.and.igrt(srcnum,knum1(knumi))==1) then - velf(1:nx*ny)=pvRg(1:nx*ny,periods(srcnum,knum1(knumi))) - sen_vs(:,kmax1+1:kmax2,:)=sen_vsRg(:,1:kmaxRg,:)!(:,nt,:) - sen_vp(:,kmax1+1:kmax2,:)=sen_vpRg(:,1:kmaxRg,:)!(:,nt,:) - sen_rho(:,kmax1+1:kmax2,:)=sen_rhoRg(:,1:kmaxRg,:)!(:,nt,:) - endif - if(wavetype(srcnum,knum1(knumi))==1.and.igrt(srcnum,knum1(knumi))==0) then - velf(1:nx*ny)=pvLc(1:nx*ny,periods(srcnum,knum1(knumi))) - sen_vs(:,kmax2+1:kmax3,:)=sen_vsLc(:,1:kmaxLc,:)!(:,nt,:) - sen_vp(:,kmax2+1:kmax3,:)=sen_vpLc(:,1:kmaxLc,:)!(:,nt,:) - sen_rho(:,kmax2+1:kmax3,:)=sen_rhoLc(:,1:kmaxLc,:)!(:,nt,:) - endif - if(wavetype(srcnum,knum1(knumi))==1.and.igrt(srcnum,knum1(knumi))==1) then - velf(1:nx*ny)=pvLg(1:nx*ny,periods(srcnum,knum1(knumi))) - sen_vs(:,kmax3+1:kmax,:)=sen_vsLg(:,1:kmaxLg,:)!(:,nt,:) - sen_vp(:,kmax3+1:kmax,:)=sen_vpLg(:,1:kmaxLg,:)!(:,nt,:) - sen_rho(:,kmax3+1:kmax,:)=sen_rhoLg(:,1:kmaxLg,:)!(:,nt,:) - endif - -call gridder(velf) - x=scxf(srcnum,knum1(knumi)) - z=sczf(srcnum,knum1(knumi)) -! -! Begin by computing refined source grid if required -! - urg=0 - IF(asgr.EQ.1)THEN -! -! Back up coarse velocity grid to a holding matrix -! - ALLOCATE(velnb(nnz,nnx)) - ! MODIFIEDY BY HONGJIAN FANG @ USTC 2014/04/17 - velnb(1:nnz,1:nnx)=veln(1:nnz,1:nnx) - nnxb=nnx - nnzb=nnz - dnxb=dnx - dnzb=dnz - goxb=gox - gozb=goz -! -! Identify nearest neighbouring node to source -! - isx=INT((x-gox)/dnx)+1 - isz=INT((z-goz)/dnz)+1 - sw=0 - IF(isx.lt.1.or.isx.gt.nnx)sw=1 - IF(isz.lt.1.or.isz.gt.nnz)sw=1 - IF(sw.eq.1)then - isx=90.0-isx*180.0/pi - isz=isz*180.0/pi - WRITE(6,*)"Source lies outside bounds of model (lat,long)= ",isx,isz - WRITE(6,*)"TERMINATING PROGRAM!!!" - STOP - ENDIF - IF(isx.eq.nnx)isx=isx-1 - IF(isz.eq.nnz)isz=isz-1 -! -! Now find rectangular box that extends outward from the nearest source node -! to "sgs" nodes away. -! - vnl=isx-sgs - IF(vnl.lt.1)vnl=1 - vnr=isx+sgs - IF(vnr.gt.nnx)vnr=nnx - vnt=isz-sgs - IF(vnt.lt.1)vnt=1 - vnb=isz+sgs - IF(vnb.gt.nnz)vnb=nnz - nrnx=(vnr-vnl)*sgdl+1 - nrnz=(vnb-vnt)*sgdl+1 - drnx=dvx/REAL(gdx*sgdl) - drnz=dvz/REAL(gdz*sgdl) - gorx=gox+dnx*(vnl-1) - gorz=goz+dnz*(vnt-1) - nnx=nrnx - nnz=nrnz - dnx=drnx - dnz=drnz - gox=gorx - goz=gorz -! -! Reallocate velocity and traveltime arrays if nnx>nnxb or -! nnz 0)THEN - WRITE(6,*)'Error with DEALLOCATE: PROGRAM fmmin2d: velnb' - ENDIF -ENDIF -enddo -enddo -deallocate(fdm) -deallocate(velv,veln,ttn,nsts,btg) -END subroutine -SUBROUTINE gridder(pv) -!subroutine gridder(pv) -!subroutine gridder() -USE globalp -IMPLICIT NONE -INTEGER :: i,j,l,m,i1,j1,conx,conz,stx,stz -REAL(KIND=i10) :: u,sumi,sumj -REAL(KIND=i10), DIMENSION(:,:), ALLOCATABLE :: ui,vi -!CHARACTER (LEN=30) :: grid -! -! u = independent parameter for b-spline -! ui,vi = bspline basis functions -! conx,conz = variables for edge of B-spline grid -! stx,stz = counters for veln grid points -! sumi,sumj = summation variables for computing b-spline -! -!C--------------------------------------------------------------- -double precision pv(*) -!integer count1 -!C--------------------------------------------------------------- -! Open the grid file and read in the velocity grid. -! -!OPEN(UNIT=10,FILE=grid,STATUS='old') -!READ(10,*)nvx,nvz -!READ(10,*)goxd,gozd -!READ(10,*)dvxd,dvzd -!count1=0 -DO i=0,nvz+1 - DO j=0,nvx+1 -! count1=count1+1 -! READ(10,*)velv(i,j) -! velv(i,j)=real(pv(count1)) - velv(i,j)=real(pv(i*(nvx+2)+j+1)) - ENDDO -ENDDO -!CLOSE(10) -! -! Convert from degrees to radians -! -! -! Now dice up the grid -! -ALLOCATE(ui(gdx+1,4), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: Subroutine gridder: REAL ui' -ENDIF -DO i=1,gdx+1 - u=gdx - u=(i-1)/u - ui(i,1)=(1.0-u)**3/6.0 - ui(i,2)=(4.0-6.0*u**2+3.0*u**3)/6.0 - ui(i,3)=(1.0+3.0*u+3.0*u**2-3.0*u**3)/6.0 - ui(i,4)=u**3/6.0 -ENDDO -ALLOCATE(vi(gdz+1,4), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: Subroutine gridder: REAL vi' -ENDIF -DO i=1,gdz+1 - u=gdz - u=(i-1)/u - vi(i,1)=(1.0-u)**3/6.0 - vi(i,2)=(4.0-6.0*u**2+3.0*u**3)/6.0 - vi(i,3)=(1.0+3.0*u+3.0*u**2-3.0*u**3)/6.0 - vi(i,4)=u**3/6.0 -ENDDO -DO i=1,nvz-1 - conz=gdz - IF(i==nvz-1)conz=gdz+1 - DO j=1,nvx-1 - conx=gdx - IF(j==nvx-1)conx=gdx+1 - DO l=1,conz - stz=gdz*(i-1)+l - DO m=1,conx - stx=gdx*(j-1)+m - sumi=0.0 - DO i1=1,4 - sumj=0.0 - DO j1=1,4 - sumj=sumj+ui(m,j1)*velv(i-2+i1,j-2+j1) - ENDDO - sumi=sumi+vi(l,i1)*sumj - ENDDO - veln(stz,stx)=sumi - ENDDO - ENDDO - ENDDO -ENDDO -DEALLOCATE(ui,vi, STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with DEALLOCATE: SUBROUTINE gridder: REAL ui,vi' -ENDIF -END SUBROUTINE gridder - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine is similar to bsplreg except that it has been -! modified to deal with source grid refinement -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE bsplrefine -USE globalp -INTEGER :: i,j,k,l,i1,j1,st1,st2,nrzr,nrxr -INTEGER :: origx,origz,conx,conz,idm1,idm2 -REAL(KIND=i10) :: u,v -REAL(KIND=i10), DIMENSION (4) :: sum -REAL(KIND=i10), DIMENSION(gdx*sgdl+1,gdz*sgdl+1,4) :: ui,vi -! -! nrxr,nrzr = grid refinement level for source grid in x,z -! origx,origz = local origin of refined source grid -! -! Begin by calculating the values of the basis functions -! -nrxr=gdx*sgdl -nrzr=gdz*sgdl -DO i=1,nrzr+1 - v=nrzr - v=(i-1)/v - DO j=1,nrxr+1 - u=nrxr - u=(j-1)/u - ui(j,i,1)=(1.0-u)**3/6.0 - ui(j,i,2)=(4.0-6.0*u**2+3.0*u**3)/6.0 - ui(j,i,3)=(1.0+3.0*u+3.0*u**2-3.0*u**3)/6.0 - ui(j,i,4)=u**3/6.0 - vi(j,i,1)=(1.0-v)**3/6.0 - vi(j,i,2)=(4.0-6.0*v**2+3.0*v**3)/6.0 - vi(j,i,3)=(1.0+3.0*v+3.0*v**2-3.0*v**3)/6.0 - vi(j,i,4)=v**3/6.0 - ENDDO -ENDDO -! -! Calculate the velocity values. -! -origx=(vnl-1)*sgdl+1 -origz=(vnt-1)*sgdl+1 -DO i=1,nvz-1 - conz=nrzr - IF(i==nvz-1)conz=nrzr+1 - DO j=1,nvx-1 - conx=nrxr - IF(j==nvx-1)conx=nrxr+1 - DO k=1,conz - st1=gdz*(i-1)+(k-1)/sgdl+1 - IF(st1.LT.vnt.OR.st1.GT.vnb)CYCLE - st1=nrzr*(i-1)+k - DO l=1,conx - st2=gdx*(j-1)+(l-1)/sgdl+1 - IF(st2.LT.vnl.OR.st2.GT.vnr)CYCLE - st2=nrxr*(j-1)+l - DO i1=1,4 - sum(i1)=0.0 - DO j1=1,4 - sum(i1)=sum(i1)+ui(l,k,j1)*velv(i-2+i1,j-2+j1) - ENDDO - sum(i1)=vi(l,k,i1)*sum(i1) - ENDDO - idm1=st1-origz+1 - idm2=st2-origx+1 - IF(idm1.LT.1.OR.idm1.GT.nnz)CYCLE - IF(idm2.LT.1.OR.idm2.GT.nnx)CYCLE - veln(idm1,idm2)=sum(1)+sum(2)+sum(3)+sum(4) - ENDDO - ENDDO - ENDDO -ENDDO -END SUBROUTINE bsplrefine -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine calculates all receiver traveltimes for -! a given source and writes the results to file. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!SUBROUTINE srtimes(scx,scz,rcx1,rcz1,cbst1) -SUBROUTINE srtimes(scx,scz,rcx1,rcz1,cbst1) -USE globalp -IMPLICIT NONE -INTEGER :: i,k,l,irx,irz,sw,isx,isz,csid -INTEGER, PARAMETER :: noray=0,yesray=1 -INTEGER, PARAMETER :: i5=SELECTED_REAL_KIND(6) -REAL(KIND=i5) :: trr -REAL(KIND=i5), PARAMETER :: norayt=0.0 -REAL(KIND=i10) :: drx,drz,produ,scx,scz -REAL(KIND=i10) :: rcx1,rcz1,cbst1 -REAL(KIND=i10) :: sred,dpl,rd1,vels,velr -REAL(KIND=i10), DIMENSION (2,2) :: vss -!!------------------------------------------------------ -! modified by Hongjian Fang @ USTC - integer no_p,nsrc - real dist -! real cbst(*) !note that the type difference(kind=i5 vs real) -! integer cbst_stat(*) -!!------------------------------------------------------ -! -! irx,irz = Coordinates of cell containing receiver -! trr = traveltime value at receiver -! produ = dummy multiplier -! drx,drz = receiver distance from (i,j,k) grid node -! scx,scz = source coordinates -! isx,isz = source cell location -! sred = Distance from source to receiver -! dpl = Minimum path length in source neighbourhood. -! vels,velr = velocity at source and receiver -! vss = velocity at four grid points about source or receiver. -! csid = current source ID -! noray = switch to indicate no ray present -! norayt = default value given to null ray -! yesray = switch to indicate that ray is present -! -! Determine source-receiver traveltimes one at a time. -! -!0605DO i=1,nrc -!0605 IF(srs(i,csid).EQ.0)THEN -!0605! WRITE(10,*)noray,norayt -!0605 CYCLE -!0605 ENDIF -! -! The first step is to locate the receiver in the grid. -! - irx=INT((rcx1-gox)/dnx)+1 - irz=INT((rcz1-goz)/dnz)+1 - sw=0 - IF(irx.lt.1.or.irx.gt.nnx)sw=1 - IF(irz.lt.1.or.irz.gt.nnz)sw=1 - IF(sw.eq.1)then - irx=90.0-irx*180.0/pi - irz=irz*180.0/pi - WRITE(6,*)"srtimes Receiver lies outside model (lat,long)= ",irx,irz - WRITE(6,*)"TERMINATING PROGRAM!!!!" - STOP - ENDIF - IF(irx.eq.nnx)irx=irx-1 - IF(irz.eq.nnz)irz=irz-1 -! -! Location of receiver successfully found within the grid. Now approximate -! traveltime at receiver using bilinear interpolation from four -! surrounding grid points. Note that bilinear interpolation is a poor -! approximation when traveltime gradient varies significantly across a cell, -! particularly near the source. Thus, we use an improved approximation in this -! case. First, locate current source cell. -! - isx=INT((scx-gox)/dnx)+1 - isz=INT((scz-goz)/dnz)+1 - dpl=dnx*earth - rd1=dnz*earth*SIN(gox) - IF(rd1.LT.dpl)dpl=rd1 - rd1=dnz*earth*SIN(gox+(nnx-1)*dnx) - IF(rd1.LT.dpl)dpl=rd1 - sred=((scx-rcx1)*earth)**2 - sred=sred+((scz-rcz1)*earth*SIN(rcx1))**2 - sred=SQRT(sred) - IF(sred.LT.dpl)sw=1 - IF(isx.EQ.irx)THEN - IF(isz.EQ.irz)sw=1 - ENDIF - IF(sw.EQ.1)THEN -! -! Compute velocity at source and receiver -! - DO k=1,2 - DO l=1,2 - vss(k,l)=veln(isz-1+l,isx-1+k) - ENDDO - ENDDO - drx=(scx-gox)-(isx-1)*dnx - drz=(scz-goz)-(isz-1)*dnz - CALL bilinear(vss,drx,drz,vels) - DO k=1,2 - DO l=1,2 - vss(k,l)=veln(irz-1+l,irx-1+k) - ENDDO - ENDDO - drx=(rcx1-gox)-(irx-1)*dnx - drz=(rcz1-goz)-(irz-1)*dnz - CALL bilinear(vss,drx,drz,velr) - trr=2.0*sred/(vels+velr) - ELSE - drx=(rcx1-gox)-(irx-1)*dnx - drz=(rcz1-goz)-(irz-1)*dnz - trr=0.0 - DO k=1,2 - DO l=1,2 - produ=(1.0-ABS(((l-1)*dnz-drz)/dnz))*(1.0-ABS(((k-1)*dnx-drx)/dnx)) - trr=trr+ttn(irz-1+l,irx-1+k)*produ - ENDDO - ENDDO - ENDIF -! WRITE(10,*)yesray,trr -!!----------------------------------------------------------------- -! modified bu Hongjian Fang @ USTC -! count2=count2+1 -! cbst((no_p-1)*nsrc*nrc+(csid-1)*nrc+i)=trr - cbst1=trr -! call delsph(scx,scz,rcx(i),rcz(i),dist) -! travel_path(count2)=dist -!cbst_stat((no_p-1)*nsrc*nrc+(csid-1)*nrc+i)=yesray -!0605ENDDO -END SUBROUTINE srtimes - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine calculates ray path geometries for each -! source-receiver combination. It will also compute -! Frechet derivatives using these ray paths if required. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!SUBROUTINE rpaths(wrgf,csid,cfd,scx,scz) -!SUBROUTINE rpaths() -SUBROUTINE rpaths(scx,scz,fdm,surfrcx,surfrcz,writepath) -USE globalp -IMPLICIT NONE -INTEGER, PARAMETER :: i5=SELECTED_REAL_KIND(5,10) -INTEGER, PARAMETER :: nopath=0 -INTEGER :: i,j,k,l,m,n,ipx,ipz,ipxr,ipzr,nrp,sw -!fang!INTEGER :: wrgf,cfd,csid,ipxo,ipzo,isx,isz -INTEGER :: ipxo,ipzo,isx,isz -INTEGER :: ivx,ivz,ivxo,ivzo,nhp,maxrp -INTEGER :: ivxt,ivzt,ipxt,ipzt,isum,igref -INTEGER, DIMENSION (4) :: chp -REAL(KIND=i5) :: rayx,rayz -REAL(KIND=i10) :: dpl,rd1,rd2,xi,zi,vel,velo -REAL(KIND=i10) :: v,w,rigz,rigx,dinc,scx,scz -REAL(KIND=i10) :: dtx,dtz,drx,drz,produ,sred -REAL(KIND=i10), DIMENSION (:), ALLOCATABLE :: rgx,rgz -!fang!REAL(KIND=i5), DIMENSION (:,:), ALLOCATABLE :: fdm -REAL(KIND=i10), DIMENSION (4) :: vrat,vi,wi,vio,wio -!fang!------------------------------------------------ -real fdm(0:nvz+1,0:nvx+1) -REAL(KIND=i10) surfrcx,surfrcz -integer writepath -!fang!------------------------------------------------ -! -! ipx,ipz = Coordinates of cell containing current point -! ipxr,ipzr = Same as ipx,apz except for refined grid -! ipxo,ipzo = Coordinates of previous point -! rgx,rgz = (x,z) coordinates of ray geometry -! ivx,ivz = Coordinates of B-spline vertex containing current point -! ivxo,ivzo = Coordinates of previous point -! maxrp = maximum number of ray points -! nrp = number of points to describe ray -! dpl = incremental path length of ray -! xi,zi = edge of model coordinates -! dtx,dtz = components of gradT -! wrgf = Write out raypaths? (<0=all,0=no,>0=souce id) -! cfd = calculate Frechet derivatives? (0=no,1=yes) -! csid = current source id -! fdm = Frechet derivative matrix -! nhp = Number of ray segment-B-spline cell hit points -! vrat = length ratio of ray sub-segment -! chp = pointer to incremental change in x or z cell -! drx,drz = distance from reference node of cell -! produ = variable for trilinear interpolation -! vel = velocity at current point -! velo = velocity at previous point -! v,w = local variables of x,z -! vi,wi = B-spline basis functions at current point -! vio,wio = vi,wi for previous point -! ivxt,ivzt = temporary ivr,ivx,ivz values -! rigx,rigz = end point of sub-segment of ray path -! ipxt,ipzt = temporary ipx,ipz values -! dinc = path length of ray sub-segment -! rayr,rayx,rayz = ray path coordinates in single precision -! isx,isz = current source cell location -! scx,scz = current source coordinates -! sred = source to ray endpoint distance -! igref = ray endpoint lies in refined grid? (0=no,1=yes) -! nopath = switch to indicate that no path is present -! -! Allocate memory to arrays for storing ray path geometry -! -maxrp=nnx*nnz -ALLOCATE(rgx(maxrp+1), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE rpaths: REAL rgx' -ENDIF -ALLOCATE(rgz(maxrp+1), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE rpaths: REAL rgz' -ENDIF -! -! Allocate memory to partial derivative array -! -!fang!IF(cfd.EQ.1)THEN -!fang! ALLOCATE(fdm(0:nvz+1,0:nvx+1), STAT=checkstat) -!fang! IF(checkstat > 0)THEN -!fang! WRITE(6,*)'Error with ALLOCATE: SUBROUTINE rpaths: REAL fdm' -!fang! ENDIF -!fang!ENDIF -! -! Locate current source cell -! -IF(asgr.EQ.1)THEN - isx=INT((scx-goxr)/dnxr)+1 - isz=INT((scz-gozr)/dnzr)+1 -ELSE - isx=INT((scx-gox)/dnx)+1 - isz=INT((scz-goz)/dnz)+1 -ENDIF -! -! Set ray incremental path length equal to half width -! of cell -! - dpl=dnx*earth - rd1=dnz*earth*SIN(gox) - IF(rd1.LT.dpl)dpl=rd1 - rd1=dnz*earth*SIN(gox+(nnx-1)*dnx) - IF(rd1.LT.dpl)dpl=rd1 - dpl=0.5*dpl -! -! Loop through all the receivers -! -!fang!DO i=1,nrc -! -! If path does not exist, then cycle the loop -! -fdm=0 -!fang! IF(cfd.EQ.1)THEN -!fang! fdm=0.0 -!fang! ENDIF -!fang! IF(srs(i,csid).EQ.0)THEN -!fang! IF(wrgf.EQ.csid.OR.wrgf.LT.0)THEN -!fang! WRITE(40)nopath -!fang! ENDIF -!fang! IF(cfd.EQ.1)THEN -!fang! WRITE(50)nopath -!fang! ENDIF -!fang! CYCLE -!fang! ENDIF -! -! The first step is to locate the receiver in the grid. -! - ipx=INT((surfrcx-gox)/dnx)+1 - ipz=INT((surfrcz-goz)/dnz)+1 - sw=0 - IF(ipx.lt.1.or.ipx.ge.nnx)sw=1 - IF(ipz.lt.1.or.ipz.ge.nnz)sw=1 - IF(sw.eq.1)then - ipx=90.0-ipx*180.0/pi - ipz=ipz*180.0/pi - WRITE(6,*)"rpath Receiver lies outside model (lat,long)= ",ipx,ipz - WRITE(6,*)"TERMINATING PROGRAM!!!" - STOP - ENDIF - IF(ipx.eq.nnx)ipx=ipx-1 - IF(ipz.eq.nnz)ipz=ipz-1 -! -! First point of the ray path is the receiver -! - rgx(1)=surfrcx - rgz(1)=surfrcz -! -! Test to see if receiver is in source neighbourhood -! - sred=((scx-rgx(1))*earth)**2 - sred=sred+((scz-rgz(1))*earth*SIN(rgx(1)))**2 - sred=SQRT(sred) - IF(sred.LT.2.0*dpl)THEN - rgx(2)=scx - rgz(2)=scz - nrp=2 - sw=1 - ENDIF -! -! If required, see if receiver lies within refined grid -! - IF(asgr.EQ.1)THEN - ipxr=INT((surfrcx-goxr)/dnxr)+1 - ipzr=INT((surfrcz-gozr)/dnzr)+1 - igref=1 - IF(ipxr.LT.1.OR.ipxr.GE.nnxr)igref=0 - IF(ipzr.LT.1.OR.ipzr.GE.nnzr)igref=0 - IF(igref.EQ.1)THEN - IF(nstsr(ipzr,ipxr).NE.0.OR.nstsr(ipzr+1,ipxr).NE.0)igref=0 - IF(nstsr(ipzr,ipxr+1).NE.0.OR.nstsr(ipzr+1,ipxr+1).NE.0)igref=0 - ENDIF - ELSE - igref=0 - ENDIF -! -! Due to the method for calculating traveltime gradient, if the -! the ray end point lies in the source cell, then we are also done. -! - IF(sw.EQ.0)THEN - IF(asgr.EQ.1)THEN - IF(igref.EQ.1)THEN - IF(ipxr.EQ.isx)THEN - IF(ipzr.EQ.isz)THEN - rgx(2)=scx - rgz(2)=scz - nrp=2 - sw=1 - ENDIF - ENDIF - ENDIF - ELSE - IF(ipx.EQ.isx)THEN - IF(ipz.EQ.isz)THEN - rgx(2)=scx - rgz(2)=scz - nrp=2 - sw=1 - ENDIF - ENDIF - ENDIF - ENDIF -! -! Now trace ray from receiver to "source" -! - DO j=1,maxrp - IF(sw.EQ.1)EXIT -! -! Calculate traveltime gradient vector for current cell using -! a first-order or second-order scheme. -! - IF(igref.EQ.1)THEN -! -! In this case, we are in the refined grid. -! -! First order scheme applied here. -! - dtx=ttnr(ipzr,ipxr+1)-ttnr(ipzr,ipxr) - dtx=dtx+ttnr(ipzr+1,ipxr+1)-ttnr(ipzr+1,ipxr) - dtx=dtx/(2.0*earth*dnxr) - dtz=ttnr(ipzr+1,ipxr)-ttnr(ipzr,ipxr) - dtz=dtz+ttnr(ipzr+1,ipxr+1)-ttnr(ipzr,ipxr+1) - dtz=dtz/(2.0*earth*SIN(rgx(j))*dnzr) - ELSE -! -! Here, we are in the coarse grid. -! -! First order scheme applied here. -! - dtx=ttn(ipz,ipx+1)-ttn(ipz,ipx) - dtx=dtx+ttn(ipz+1,ipx+1)-ttn(ipz+1,ipx) - dtx=dtx/(2.0*earth*dnx) - dtz=ttn(ipz+1,ipx)-ttn(ipz,ipx) - dtz=dtz+ttn(ipz+1,ipx+1)-ttn(ipz,ipx+1) - dtz=dtz/(2.0*earth*SIN(rgx(j))*dnz) - ENDIF -! -! Calculate the next ray path point -! - rd1=SQRT(dtx**2+dtz**2) - rgx(j+1)=rgx(j)-dpl*dtx/(earth*rd1) - rgz(j+1)=rgz(j)-dpl*dtz/(earth*SIN(rgx(j))*rd1) -! -! Determine which cell the new ray endpoint -! lies in. -! - ipxo=ipx - ipzo=ipz - IF(asgr.EQ.1)THEN -! -! Here, we test to see whether the ray endpoint lies -! within a cell of the refined grid -! - ipxr=INT((rgx(j+1)-goxr)/dnxr)+1 - ipzr=INT((rgz(j+1)-gozr)/dnzr)+1 - igref=1 - IF(ipxr.LT.1.OR.ipxr.GE.nnxr)igref=0 - IF(ipzr.LT.1.OR.ipzr.GE.nnzr)igref=0 - IF(igref.EQ.1)THEN - IF(nstsr(ipzr,ipxr).NE.0.OR.nstsr(ipzr+1,ipxr).NE.0)igref=0 - IF(nstsr(ipzr,ipxr+1).NE.0.OR.nstsr(ipzr+1,ipxr+1).NE.0)igref=0 - ENDIF - ipx=INT((rgx(j+1)-gox)/dnx)+1 - ipz=INT((rgz(j+1)-goz)/dnz)+1 - ELSE - ipx=INT((rgx(j+1)-gox)/dnx)+1 - ipz=INT((rgz(j+1)-goz)/dnz)+1 - igref=0 - ENDIF -! -! Test the proximity of the source to the ray end point. -! If it is less than dpl then we are done -! - sred=((scx-rgx(j+1))*earth)**2 - sred=sred+((scz-rgz(j+1))*earth*SIN(rgx(j+1)))**2 - sred=SQRT(sred) - sw=0 - IF(sred.LT.2.0*dpl)THEN - rgx(j+2)=scx - rgz(j+2)=scz - nrp=j+2 - sw=1 -!fang! IF(cfd.NE.1)EXIT - ENDIF -! -! Due to the method for calculating traveltime gradient, if the -! the ray end point lies in the source cell, then we are also done. -! - IF(sw.EQ.0)THEN - IF(asgr.EQ.1)THEN - IF(igref.EQ.1)THEN - IF(ipxr.EQ.isx)THEN - IF(ipzr.EQ.isz)THEN - rgx(j+2)=scx - rgz(j+2)=scz - nrp=j+2 - sw=1 - !fang! IF(cfd.NE.1)EXIT - ENDIF - ENDIF - ENDIF - ELSE - IF(ipx.EQ.isx)THEN - IF(ipz.EQ.isz)THEN - rgx(j+2)=scx - rgz(j+2)=scz - nrp=j+2 - sw=1 - !fang! IF(cfd.NE.1)EXIT - ENDIF - ENDIF - ENDIF - ENDIF -! -! Test whether ray path segment extends beyond -! box boundaries -! - IF(ipx.LT.1)THEN - rgx(j+1)=gox - ipx=1 - rbint=1 - ENDIF - IF(ipx.GE.nnx)THEN - rgx(j+1)=gox+(nnx-1)*dnx - ipx=nnx-1 - rbint=1 - ENDIF - IF(ipz.LT.1)THEN - rgz(j+1)=goz - ipz=1 - rbint=1 - ENDIF - IF(ipz.GE.nnz)THEN - rgz(j+1)=goz+(nnz-1)*dnz - ipz=nnz-1 - rbint=1 - ENDIF -! -! Calculate the Frechet derivatives if required. -! - !fang! IF(cfd.EQ.1)THEN -! -! First determine which B-spline cell the refined cells -! containing the ray path segment lies in. If they lie -! in more than one, then we need to divide the problem -! into separate parts (up to three). -! - ivx=INT((ipx-1)/gdx)+1 - ivz=INT((ipz-1)/gdz)+1 - ivxo=INT((ipxo-1)/gdx)+1 - ivzo=INT((ipzo-1)/gdz)+1 -! -! Calculate up to two hit points between straight -! ray segment and cell faces. -! - nhp=0 - IF(ivx.NE.ivxo)THEN - nhp=nhp+1 - IF(ivx.GT.ivxo)THEN - xi=gox+(ivx-1)*dvx - ELSE - xi=gox+ivx*dvx - ENDIF - vrat(nhp)=(xi-rgx(j))/(rgx(j+1)-rgx(j)) - chp(nhp)=1 - ENDIF - IF(ivz.NE.ivzo)THEN - nhp=nhp+1 - IF(ivz.GT.ivzo)THEN - zi=goz+(ivz-1)*dvz - ELSE - zi=goz+ivz*dvz - ENDIF - rd1=(zi-rgz(j))/(rgz(j+1)-rgz(j)) - IF(nhp.EQ.1)THEN - vrat(nhp)=rd1 - chp(nhp)=2 - ELSE - IF(rd1.GE.vrat(nhp-1))THEN - vrat(nhp)=rd1 - chp(nhp)=2 - ELSE - vrat(nhp)=vrat(nhp-1) - chp(nhp)=chp(nhp-1) - vrat(nhp-1)=rd1 - chp(nhp-1)=2 - ENDIF - ENDIF - ENDIF - nhp=nhp+1 - vrat(nhp)=1.0 - chp(nhp)=0 -! -! Calculate the velocity, v and w values of the -! first point -! - drx=(rgx(j)-gox)-(ipxo-1)*dnx - drz=(rgz(j)-goz)-(ipzo-1)*dnz - vel=0.0 - DO l=1,2 - DO m=1,2 - produ=(1.0-ABS(((m-1)*dnz-drz)/dnz)) - produ=produ*(1.0-ABS(((l-1)*dnx-drx)/dnx)) - IF(ipzo-1+m.LE.nnz.AND.ipxo-1+l.LE.nnx)THEN - vel=vel+veln(ipzo-1+m,ipxo-1+l)*produ - ENDIF - ENDDO - ENDDO - drx=(rgx(j)-gox)-(ivxo-1)*dvx - drz=(rgz(j)-goz)-(ivzo-1)*dvz - v=drx/dvx - w=drz/dvz -! -! Calculate the 12 basis values at the point -! - vi(1)=(1.0-v)**3/6.0 - vi(2)=(4.0-6.0*v**2+3.0*v**3)/6.0 - vi(3)=(1.0+3.0*v+3.0*v**2-3.0*v**3)/6.0 - vi(4)=v**3/6.0 - wi(1)=(1.0-w)**3/6.0 - wi(2)=(4.0-6.0*w**2+3.0*w**3)/6.0 - wi(3)=(1.0+3.0*w+3.0*w**2-3.0*w**3)/6.0 - wi(4)=w**3/6.0 - ivxt=ivxo - ivzt=ivzo -! -! Now loop through the one or more sub-segments of the -! ray path segment and calculate partial derivatives -! - DO k=1,nhp - velo=vel - vio=vi - wio=wi - IF(k.GT.1)THEN - IF(chp(k-1).EQ.1)THEN - ivxt=ivx - ELSE IF(chp(k-1).EQ.2)THEN - ivzt=ivz - ENDIF - ENDIF -! -! Calculate the velocity, v and w values of the -! new point -! - rigz=rgz(j)+vrat(k)*(rgz(j+1)-rgz(j)) - rigx=rgx(j)+vrat(k)*(rgx(j+1)-rgx(j)) - ipxt=INT((rigx-gox)/dnx)+1 - ipzt=INT((rigz-goz)/dnz)+1 - drx=(rigx-gox)-(ipxt-1)*dnx - drz=(rigz-goz)-(ipzt-1)*dnz - vel=0.0 - DO m=1,2 - DO n=1,2 - produ=(1.0-ABS(((n-1)*dnz-drz)/dnz)) - produ=produ*(1.0-ABS(((m-1)*dnx-drx)/dnx)) - IF(ipzt-1+n.LE.nnz.AND.ipxt-1+m.LE.nnx)THEN - vel=vel+veln(ipzt-1+n,ipxt-1+m)*produ - ENDIF - ENDDO - ENDDO - drx=(rigx-gox)-(ivxt-1)*dvx - drz=(rigz-goz)-(ivzt-1)*dvz - v=drx/dvx - w=drz/dvz -! -! Calculate the 8 basis values at the new point -! - vi(1)=(1.0-v)**3/6.0 - vi(2)=(4.0-6.0*v**2+3.0*v**3)/6.0 - vi(3)=(1.0+3.0*v+3.0*v**2-3.0*v**3)/6.0 - vi(4)=v**3/6.0 - wi(1)=(1.0-w)**3/6.0 - wi(2)=(4.0-6.0*w**2+3.0*w**3)/6.0 - wi(3)=(1.0+3.0*w+3.0*w**2-3.0*w**3)/6.0 - wi(4)=w**3/6.0 -! -! Calculate the incremental path length -! - IF(k.EQ.1)THEN - dinc=vrat(k)*dpl - ELSE - dinc=(vrat(k)-vrat(k-1))*dpl - ENDIF -! -! Now compute the 16 contributions to the partial -! derivatives. -! - DO l=1,4 - DO m=1,4 - rd1=vi(m)*wi(l)/vel**2 - rd2=vio(m)*wio(l)/velo**2 - rd1=-(rd1+rd2)*dinc/2.0 - !fang! rd1=vi(m)*wi(l) - !fang! rd2=vio(m)*wio(l) - !fang! rd1=(rd1+rd2)*dinc/2.0 - rd2=fdm(ivzt-2+l,ivxt-2+m) - fdm(ivzt-2+l,ivxt-2+m)=rd1+rd2 - ENDDO - ENDDO - ENDDO - !fang! ENDIF -!fang! IF(j.EQ.maxrp.AND.sw.EQ.0)THEN -!fang! WRITE(6,*)'Error with ray path detected!!!' -!fang! WRITE(6,*)'Source id: ',csid -!fang! WRITE(6,*)'Receiver id: ',i -!fang! ENDIF - ENDDO -! -! Write ray paths to output file -! -!fang! IF(wrgf.EQ.csid.OR.wrgf.LT.0)THEN - if(writepath == 1) then - WRITE(40,*)'#',nrp - DO j=1,nrp - rayx=(pi/2-rgx(j))*180.0/pi - rayz=rgz(j)*180.0/pi - WRITE(40,*)rayx,rayz - ENDDO - endif -!fang! ENDIF -! -! Write partial derivatives to output file -! -!fang! IF(cfd.EQ.1)THEN -!fang!! -!fang!! Determine the number of non-zero elements. -!fang!! -!fang! isum=0 -!fang! DO j=0,nvz+1 -!fang! DO k=0,nvx+1 -!fang! IF(ABS(fdm(j,k)).GE.ftol)isum=isum+1 -!fang! ENDDO -!fang! ENDDO -!fang! WRITE(50)isum -!fang! isum=0 -!fang! DO j=0,nvz+1 -!fang! DO k=0,nvx+1 -!fang! isum=isum+1 -!fang! IF(ABS(fdm(j,k)).GE.ftol)WRITE(50)isum,fdm(j,k) -!fang! ENDDO -!fang! ENDDO -!fang! ENDIF -!fang!ENDDO -!fang!IF(cfd.EQ.1)THEN -!fang! DEALLOCATE(fdm, STAT=checkstat) -!fang! IF(checkstat > 0)THEN -!fang! WRITE(6,*)'Error with DEALLOCATE: SUBROUTINE rpaths: fdm' -!fang! ENDIF -!fang!ENDIF -DEALLOCATE(rgx,rgz, STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with DEALLOCATE: SUBROUTINE rpaths: rgx,rgz' -ENDIF -END SUBROUTINE rpaths - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TYPE: SUBROUTINE -! CODE: FORTRAN 90 -! This subroutine is passed four node values which lie on -! the corners of a rectangle and the coordinates of a point -! lying within the rectangle. It calculates the value at -! the internal point by using bilinear interpolation. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE bilinear(nv,dsx,dsz,biv) -USE globalp -IMPLICIT NONE -INTEGER :: i,j -REAL(KIND=i10) :: dsx,dsz,biv -REAL(KIND=i10), DIMENSION(2,2) :: nv -REAL(KIND=i10) :: produ -! -! nv = four node vertex values -! dsx,dsz = distance between internal point and top left node -! dnx,dnz = width and height of node rectangle -! biv = value at internal point calculated by bilinear interpolation -! produ = product variable -! -biv=0.0 -DO i=1,2 - DO j=1,2 - produ=(1.0-ABS(((i-1)*dnx-dsx)/dnx))*(1.0-ABS(((j-1)*dnz-dsz)/dnz)) - biv=biv+nv(i,j)*produ - ENDDO -ENDDO -END SUBROUTINE bilinear - - - subroutine refineGrid2LayerMdl(minthk0,mmax,dep,vp,vs,rho,& - rmax,rdep,rvp,rvs,rrho,rthk) -!!--------------------------------------------------------------------c -!!refine grid based model to layerd based model -!!INPUT: minthk: is the minimum thickness of the refined layered model -!! mmax: number of depth grid points in the model -!! dep, vp, vs, rho: the depth-grid model parameters -!! rmax: number of layers in the fined layered model -!! rdep, rvp, rvs, rrho, rthk: the refined layered velocity model -!! - implicit none - integer NL - parameter (NL=200) - integer mmax,rmax - real minthk - real minthk0 - real dep(*),vp(*),vs(*),rho(*) - real rdep(NL),rvp(NL),rvs(NL),rrho(NL),rthk(NL) - integer nsublay(NL) - real thk,newthk,initdep - integer i,j,k,ngrid - - k = 0 - initdep = 0.0 - do i = 1, mmax-1 - thk = dep(i+1)-dep(i) - minthk = thk/minthk0 - nsublay(i) = int((thk+1.0e-4)/minthk) + 1 - ngrid = nsublay(i)+1 - newthk = thk/nsublay(i) - do j = 1, nsublay(i) - k = k + 1 - rthk(k) = newthk - rdep(k) = initdep + rthk(k) - initdep = rdep(k) - rvp(k) = vp(i)+(2*j-1)*(vp(i+1)-vp(i))/(2*nsublay(i)) - rvs(k) = vs(i)+(2*j-1)*(vs(i+1)-vs(i))/(2*nsublay(i)) - rrho(k) = rho(i)+(2*j-1)*(rho(i+1)-rho(i))/(2*nsublay(i)) - enddo - enddo -!! half space model - k = k + 1 - rthk(k) = 0.0 - rvp(k) = vp(mmax) - rvs(k) = vs(mmax) - rrho(k) = rho(mmax) - - rmax = k - -!! do i = 1, mmax -!! write(*,*) dep(i),vp(i),vs(i),rho(i) -!! enddo -!! print *, '---------------------------------' -!! do i = 1, rmax -!! write(*,*) rdep(i),rthk(i),rvp(i),rvs(i),rrho(i) -!! enddo - - return - end -subroutine synthetic(nx,ny,nz,nparpi,vels,obst, & - goxdf,gozdf,dvxdf,dvzdf,kmaxRc,kmaxRg,kmaxLc,kmaxLg, & - tRc,tRg,tLc,tLg,wavetype,igrt,periods,depz,minthk, & - scxf,sczf,rcxf,rczf,nrc1,nsrcsurf1,knum1,kmax,nsrcsurf,nrcf,noiselevel) - -USE globalp -USE traveltime -IMPLICIT NONE -!CHARACTER (LEN=30) ::grid,frechet -!CHARACTER (LEN=40) :: sources,receivers,otimes -!CHARACTER (LEN=30) :: travelt,rtravel,wrays,cdum -INTEGER :: i,j,k,l,nsrc,tnr,urg -INTEGER :: sgs,isx,isz,sw,idm1,idm2,nnxb,nnzb -INTEGER :: ogx,ogz,grdfx,grdfz,maxbt -REAL(KIND=i10) :: x,z,goxb,gozb,dnxb,dnzb -!REAL(KIND=i10), DIMENSION (:,:), ALLOCATABLE :: scxf,sczf -!REAL(KIND=i10), DIMENSION (:,:,:), ALLOCATABLE :: rcxf,rczf -! -! sources = File containing source locations -! receivers = File containing receiver locations -! grid = File containing grid of velocity vertices for -! resampling on a finer grid with cubic B-splines -! frechet = output file containing matrix of frechet derivatives -! travelt = File name for storage of traveltime field -! wttf = Write traveltimes to file? (0=no,>0=source id) -! fom = Use first-order(0) or mixed-order(1) scheme -! nsrc = number of sources -! scx,scz = source location in r,x,z -! scx,scz = source location in r,x,z -! x,z = temporary variables for source location -! fsrt = find source-receiver traveltimes? (0=no,1=yes) -! rtravel = output file for source-receiver traveltimes -! cdum = dummy character variable ! wrgf = write ray geometries to file? (<0=all,0=no,>0=source id.) -! wrays = file containing raypath geometries -! cfd = calculate Frechet derivatives? (0=no, 1=yes) -! tnr = total number of receivers -! sgs = Extent of refined source grid -! isx,isz = cell containing source -! nnxb,nnzb = Backup for nnz,nnx -! goxb,gozb = Backup for gox,goz -! dnxb,dnzb = Backup for dnx,dnz -! ogx,ogz = Location of refined grid origin -! gridfx,grdfz = Number of refined nodes per cell -! urg = use refined grid (0=no,1=yes,2=previously used) -! maxbt = maximum size of narrow band binary tree -! otimes = file containing source-receiver association information -!c----------------------------------------------------------------- -! variables defined by Hongjian Fang - integer nx,ny,nz - integer kmax,nsrcsurf,nrcf - real vels(nx,ny,nz) - real obst(*) - real goxdf,gozdf,dvxdf,dvzdf - integer kmaxRc,kmaxRg,kmaxLc,kmaxLg - real*8 tRc(*),tRg(*),tLc(*),tLg(*) - integer wavetype(nsrcsurf,kmax) - integer periods(nsrcsurf,kmax),nrc1(nsrcsurf,kmax),nsrcsurf1(kmax) - integer knum1(kmax),igrt(nsrcsurf,kmax) - real scxf(nsrcsurf,kmax),sczf(nsrcsurf,kmax),rcxf(nrcf,nsrcsurf,kmax),rczf(nrcf,nsrcsurf,kmax) - real minthk - integer nparpi - - - real vpz(nz),vsz(nz),rhoz(nz),depz(nz) - real*8 pvRc(nx*ny,kmaxRc),pvRg(nx*ny,kmaxRg),pvLc(nx*ny,kmaxLc),pvLg(nx*ny,kmaxLg) - real*8 velf(ny*nx) - integer kmax1,kmax2,kmax3,count1 - integer igr - integer iwave - integer knumi,srcnum - real cbst1 - real noiselevel - real gaussian - external gaussian - integer ii,jj,kk,nn,istep -gdx=5 -gdz=5 -asgr=1 -sgdl=8 -sgs=8 -earth=6371.0 -fom=1 -snb=0.5 -goxd=goxdf -gozd=gozdf -dvxd=dvxdf -dvzd=dvzdf -nvx=nx-2 -nvz=ny-2 -ALLOCATE(velv(0:nvz+1,0:nvx+1), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE gridder: REAL velv' -ENDIF -! -! Convert from degrees to radians -! -dvx=dvxd*pi/180.0 -dvz=dvzd*pi/180.0 -gox=(90.0-goxd)*pi/180.0 -goz=gozd*pi/180.0 -! -! Compute corresponding values for propagation grid. -! -nnx=(nvx-1)*gdx+1 -nnz=(nvz-1)*gdz+1 -dnx=dvx/gdx -dnz=dvz/gdz -dnxd=dvxd/gdx -dnzd=dvzd/gdz -ALLOCATE(veln(nnz,nnx), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: SUBROUTINE gridder: REAL veln' -ENDIF - -! -! Call a subroutine which reads in the velocity grid -! -!CALL gridder(grid) -! -! Read in all source coordinates. -! -! -! Now work out, source by source, the first-arrival traveltime -! field plus source-receiver traveltimes -! and ray paths if required. First, allocate memory to the -! traveltime field array -! -ALLOCATE(ttn(nnz,nnx), STAT=checkstat) -IF(checkstat > 0)THEN - WRITE(6,*)'Error with ALLOCATE: PROGRAM fmmin2d: REAL ttn' -ENDIF - rbint=0 -! -! Allocate memory for node status and binary trees -! -ALLOCATE(nsts(nnz,nnx)) -maxbt=NINT(snb*nnx*nnz) -ALLOCATE(btg(maxbt)) - -!allocate(fdm(0:nvz+1,0:nvx+1)) - - if(kmaxRc.gt.0) then - iwave=2 - igr=0 - call caldespersion(nx,ny,nz,vels,pvRc, & - iwave,igr,kmaxRc,tRc,depz,minthk) - endif - - if(kmaxRg.gt.0) then - iwave=2 - igr=1 - call caldespersion(nx,ny,nz,vels,pvRg, & - iwave,igr,kmaxRg,tRg,depz,minthk) - endif - - if(kmaxLc.gt.0) then - iwave=1 - igr=0 - call caldespersion(nx,ny,nz,vels,pvLc, & - iwave,igr,kmaxLc,tLc,depz,minthk) - endif - - if(kmaxLg.gt.0) then - iwave=1 - igr=1 - call caldespersion(nx,ny,nz,vels,pvLg, & - iwave,igr,kmaxLg,tLg,depz,minthk) - endif - -!nar=0 -count1=0 - -!sen_vs=0 -!sen_vp=0 -!sen_rho=0 -kmax1=kmaxRc -kmax2=kmaxRc+kmaxRg -kmax3=kmaxRc+kmaxRg+kmaxLc -do knumi=1,kmax -do srcnum=1,nsrcsurf1(knum1(knumi)) - if(wavetype(srcnum,knum1(knumi))==2.and.igrt(srcnum,knum1(knumi))==0) then - velf(1:nx*ny)=pvRc(1:nx*ny,periods(srcnum,knum1(knumi))) -! sen_vs(:,1:kmax1,:)=sen_vsRc(:,1:kmaxRc,:)!(:,nt(istep),:) -! sen_vp(:,1:kmax1,:)=sen_vpRc(:,1:kmaxRc,:)!(:,nt(istep),:) -! sen_rho(:,1:kmax1,:)=sen_rhoRc(:,1:kmaxRc,:)!(:,nt(istep),:) - endif - if(wavetype(srcnum,knum1(knumi))==2.and.igrt(srcnum,knum1(knumi))==1) then - velf(1:nx*ny)=pvRg(1:nx*ny,periods(srcnum,knum1(knumi))) -! sen_vs(:,kmax1+1:kmax2,:)=sen_vsRg(:,1:kmaxRg,:)!(:,nt,:) -! sen_vp(:,kmax1+1:kmax2,:)=sen_vpRg(:,1:kmaxRg,:)!(:,nt,:) -! sen_rho(:,kmax1+1:kmax2,:)=sen_rhoRg(:,1:kmaxRg,:)!(:,nt,:) - endif - if(wavetype(srcnum,knum1(knumi))==1.and.igrt(srcnum,knum1(knumi))==0) then - velf(1:nx*ny)=pvLc(1:nx*ny,periods(srcnum,knum1(knumi))) -! sen_vs(:,kmax2+1:kmax3,:)=sen_vsLc(:,1:kmaxLc,:)!(:,nt,:) -! sen_vp(:,kmax2+1:kmax3,:)=sen_vpLc(:,1:kmaxLc,:)!(:,nt,:) -! sen_rho(:,kmax2+1:kmax3,:)=sen_rhoLc(:,1:kmaxLc,:)!(:,nt,:) - endif - if(wavetype(srcnum,knum1(knumi))==1.and.igrt(srcnum,knum1(knumi))==1) then - velf(1:nx*ny)=pvLg(1:nx*ny,periods(srcnum,knum1(knumi))) -! sen_vs(:,kmax3+1:kmax,:)=sen_vsLg(:,1:kmaxLg,:)!(:,nt,:) -! sen_vp(:,kmax3+1:kmax,:)=sen_vpLg(:,1:kmaxLg,:)!(:,nt,:) -! sen_rho(:,kmax3+1:kmax,:)=sen_rhoLg(:,1:kmaxLg,:)!(:,nt,:) - endif - -call gridder(velf) - x=scxf(srcnum,knum1(knumi)) - z=sczf(srcnum,knum1(knumi)) -! -! Begin by computing refined source grid if required -! - urg=0 - IF(asgr.EQ.1)THEN -! -! Back up coarse velocity grid to a holding matrix -! - ALLOCATE(velnb(nnz,nnx)) -! MODIFIEDY BY HONGJIAN FANG @ USTC 2014/04/17 - velnb(1:nnz,1:nnx)=veln(1:nnz,1:nnx) - nnxb=nnx - nnzb=nnz - dnxb=dnx - dnzb=dnz - goxb=gox - gozb=goz -! -! Identify nearest neighbouring node to source -! - isx=INT((x-gox)/dnx)+1 - isz=INT((z-goz)/dnz)+1 - sw=0 - IF(isx.lt.1.or.isx.gt.nnx)sw=1 - IF(isz.lt.1.or.isz.gt.nnz)sw=1 - IF(sw.eq.1)then - isx=90.0-isx*180.0/pi - isz=isz*180.0/pi - WRITE(6,*)"Source lies outside bounds of model (lat,long)= ",isx,isz - WRITE(6,*)"TERMINATING PROGRAM!!!" - STOP - ENDIF - IF(isx.eq.nnx)isx=isx-1 - IF(isz.eq.nnz)isz=isz-1 -! -! Now find rectangular box that extends outward from the nearest source node -! to "sgs" nodes away. -! - vnl=isx-sgs - IF(vnl.lt.1)vnl=1 - vnr=isx+sgs - IF(vnr.gt.nnx)vnr=nnx - vnt=isz-sgs - IF(vnt.lt.1)vnt=1 - vnb=isz+sgs - IF(vnb.gt.nnz)vnb=nnz - nrnx=(vnr-vnl)*sgdl+1 - nrnz=(vnb-vnt)*sgdl+1 - drnx=dvx/REAL(gdx*sgdl) - drnz=dvz/REAL(gdz*sgdl) - gorx=gox+dnx*(vnl-1) - gorz=goz+dnz*(vnt-1) - nnx=nrnx - nnz=nrnz - dnx=drnx - dnz=drnz - gox=gorx - goz=gorz -! -! Reallocate velocity and traveltime arrays if nnx>nnxb or -! nnz 0)THEN - WRITE(6,*)'Error with DEALLOCATE: PROGRAM fmmin2d: velnb' - ENDIF -ENDIF -enddo -enddo -!deallocate(fdm) -deallocate(velv,veln,ttn,nsts,btg) -END subroutine -subroutine caldespersion(nx,ny,nz,vel,pvRc, & - iwave,igr,kmaxRc,tRc,depz,minthk) - use omp_lib - implicit none - - integer nx,ny,nz - real vel(nx,ny,nz) - - integer iwave,igr - real minthk - real depz(nz) - integer kmaxRc - real*8 tRc(kmaxRc) - real*8 pvRc(nx*ny,kmaxRc) - - - - real vpz(nz),vsz(nz),rhoz(nz) - integer mmax,iflsph,mode,rmax - integer ii,jj,k,i,nn,kk - integer,parameter::NL=200 - integer,parameter::NP=60 - real*8 cg1(NP),cg2(NP),cga,cgRc(NP) - real rdep(NL),rvp(NL),rvs(NL),rrho(NL),rthk(NL) - real depm(NL),vpm(NL),vsm(NL),rhom(NL),thkm(NL) - real dlnVs,dlnVp,dlnrho - - - mmax=nz - iflsph=1 - mode=1 - dlnVs=0.01 - dlnVp=0.01 - dlnrho=0.01 - -!$omp parallel & -!$omp default(private) & -!$omp shared(depz,nx,ny,nz,minthk,kmaxRc,mmax,vel) & -!$omp shared(tRc,pvRc,iflsph,iwave,mode,igr) -!$omp do - do jj=1,ny - do ii=1,nx - vsz(1:nz)=vel(ii,jj,1:nz) - ! some other emperical relationship maybe better, - do k=1,nz - vpz(k)=0.9409 + 2.0947*vsz(k) - 0.8206*vsz(k)**2+ & - 0.2683*vsz(k)**3 - 0.0251*vsz(k)**4 - rhoz(k)=1.6612*vpz(k) - 0.4721*vpz(k)**2 + & - 0.0671*vpz(k)**3 - 0.0043*vpz(k)**4 + & - 0.000106*vpz(k)**5 - enddo - - call refineGrid2LayerMdl(minthk,mmax,depz,vpz,vsz,rhoz,rmax,rdep,& - rvp,rvs,rrho,rthk) - call surfdisp96(rthk,rvp,rvs,rrho,rmax,iflsph,iwave,mode,igr,kmaxRc,& - tRc,cgRc) - pvRc((jj-1)*nx+ii,1:kmaxRc)=cgRc(1:kmaxRc) - enddo - enddo -!$omp end do -!$omp end parallel - end subroutine - - diff --git a/srcsparsity/Makefile b/srcsparsity/Makefile deleted file mode 100644 index 8485d66..0000000 --- a/srcsparsity/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -CMD = DSurfTomo -FC = gfortran -FFLAGS = -O3 -ffixed-line-length-none -ffloat-store\ - -W -fbounds-check -m64 -mcmodel=medium -F90SRCS = lsmrDataModule.f90 lsmrblasInterface.f90 \ - lsmrblas.f90 lsmrModule.f90 delsph.f90\ - forwardstep.f90 forwardtrans.f90 split.f90 merge1.f90\ - invtrans3d.f90 inversetrans.f90 aprod.f90\ - haar.f90 waveletD8.f90 inversestep.f90\ - gaussian.f90 main.f90 -FSRCS = surfdisp96.f -OBJS = $(F90SRCS:%.f90=%.o) $(FSRCS:%.f=%.o) CalSurfG.o wavelettrans3domp.o -all:$(CMD) -$(CMD):$(OBJS) - $(FC) -fopenmp $^ -o $@ -CalSurfG.o:CalSurfG.f90 - $(FC) -fopenmp $(FFLAGS) -c $< -o $@ -wavelettrans3domp.o: wavelettrans3domp.f90 - $(FC) -fopenmp $(FFLAGS) -c $< -o $@ -%.o: %.f90 - $(FC) $(FFLAGS) -c $(@F:.o=.f90) -o $@ -%.o: %.f - $(FC) $(FFLAGS) -c $(@F:.o=.f) -o $@ -clean: - rm *.o *.mod $(CMD) diff --git a/srcsparsity/aprod.f90 b/srcsparsity/aprod.f90 deleted file mode 100644 index 5e17045..0000000 --- a/srcsparsity/aprod.f90 +++ /dev/null @@ -1,60 +0,0 @@ -!c--- This file is from hypoDD by Felix Waldhauser --------- -!c-------------------------Modified by Haijiang Zhang------- -!c Multiply a matrix by a vector -!c Version for use with sparse matrix specified by -!c output of subroutine sparse for use with LSQR - - subroutine aprod(mode, m, n, x, y, leniw, lenrw, iw, rw) - - implicit none - -!c Parameters: - integer mode ! ==1: Compute y = y + a*x - ! y is altered without changing x - ! ==2: Compute x = x + a(transpose)*y - ! x is altered without changing y - integer m, n ! Row and column dimensions of a - real x(n), y(m) ! Input vectors - integer :: leniw - integer lenrw - integer iw(leniw) ! Integer work vector containing: - ! iw[1] Number of non-zero elements in a - ! iw[2:iw[1]+1] Row indices of non-zero elements - ! iw[iw[1]+2:2*iw[1]+1] Column indices - real rw(lenrw) ! [1..iw[1]] Non-zero elements of a - -!c Local variables: - integer i1 - integer j1 - integer k - integer kk - -!c set the ranges the indices in vector iw - - kk=iw(1) - i1=1 - j1=kk+1 - -!c main iteration loop - - do k = 1,kk - - if (mode.eq.1) then - -!c compute y = y + a*x - - y(iw(i1+k)) = y(iw(i1+k)) + rw(k)*x(iw(j1+k)) - - else - -!c compute x = x + a(transpose)*y - - x(iw(j1+k)) = x(iw(j1+k)) + rw(k)*y(iw(i1+k)) - - endif - enddo - -! 100 continue - - return - end diff --git a/srcsparsity/delsph.f90 b/srcsparsity/delsph.f90 deleted file mode 100644 index c9f7170..0000000 --- a/srcsparsity/delsph.f90 +++ /dev/null @@ -1,28 +0,0 @@ -subroutine delsph(flat1,flon1,flat2,flon2,del) -implicit none -real,parameter:: R=6371.0 -REAL,parameter:: pi=3.1415926535898 -real flat1,flat2 -real flon1,flon2 -real del - -real dlat -real dlon -real lat1 -real lat2 -real a -real c - - -!dlat=(flat2-flat1)*pi/180 -!dlon=(flon2-flon1)*pi/180 -!lat1=flat1*pi/180 -!lat2=flat2*pi/180 -dlat=flat2-flat1 -dlon=flon2-flon1 -lat1=pi/2-flat1 -lat2=pi/2-flat2 -a=sin(dlat/2)*sin(dlat/2)+sin(dlon/2)*sin(dlon/2)*cos(lat1)*cos(lat2) -c=2*atan2(sqrt(a),sqrt(1-a)) -del=R*c -end subroutine diff --git a/srcsparsity/forwardstep.f90 b/srcsparsity/forwardstep.f90 deleted file mode 100644 index 7dafa01..0000000 --- a/srcsparsity/forwardstep.f90 +++ /dev/null @@ -1,26 +0,0 @@ - subroutine forwardstep(vec,n) - implicit none - integer n - real vec(n) - - integer half, k, j - half=n/2!changed to more than one - do k=1,half - vec(k)=vec(k)+sqrt(3.0)*vec(half+k) - end do - vec(half+1)=vec(half+1)-sqrt(3.0)/4.0*vec(1)- & - (sqrt(3.0)-2)/4.0*vec(half) - do k=1,half-1 - vec(half+k+1)=vec(half+k+1)-sqrt(3.0)/4.0*vec(k+1)- & - (sqrt(3.0)-2)/4.0*vec(k) - end do - do k=1,half-1 - vec(k)=vec(k)-vec(half+k+1) - end do - vec(half)=vec(half)-vec(half+1) - - do k=1,half - vec(k)=(sqrt(3.0)-1)/sqrt(2.0)*vec(k) - vec(half+k)=(sqrt(3.0)+1)/sqrt(2.0)*vec(half+k) - end do - end subroutine diff --git a/srcsparsity/forwardtrans.f90 b/srcsparsity/forwardtrans.f90 deleted file mode 100644 index 2779994..0000000 --- a/srcsparsity/forwardtrans.f90 +++ /dev/null @@ -1,47 +0,0 @@ - subroutine forwardtrans(vec,n,mxl,tp) - implicit none - integer n,mxl,tp - real vec(n) - integer i,j - integer forward - i=n - if (tp == 1) then - forward=0 - do while(i.ge.n/(2**mxl)) - call split(vec,i) - call predict(vec,i,forward) - call update(vec,i,forward) - call normalizationf(vec,i) - i=i/2 - enddo - endif - - if (tp == 2) then - do while(i.ge.n/(2**mxl)) - call split(vec,i) - call forwardstep(vec,i) - i=i/2 - enddo - endif - - if (tp == 3) then - do while(i.ge.n/(2**mxl)) - call transformD8(vec,i) - i=i/2 - enddo - endif - end subroutine - - subroutine normalizationf(x,n) - implicit none - real x(*) - integer n - - integer k - do k=1,n/2 - x(k)=x(k)*sqrt(2.0) - enddo - do k=n/2+1,n - x(k)=x(k)*sqrt(2.0)/2 - enddo - end diff --git a/srcsparsity/gaussian.f90 b/srcsparsity/gaussian.f90 deleted file mode 100644 index 4cb5775..0000000 --- a/srcsparsity/gaussian.f90 +++ /dev/null @@ -1,31 +0,0 @@ - real function gaussian() - implicit none -! real rd - - real x1,x2,w,y1 - real y2 - real n1,n2 - integer use_last - integer ii,jj - - use_last=0 - y2=0 - w=2.0 - if(use_last.ne.0) then - y1=y2 - use_last=0 - else - do while (w.ge.1.0) - call random_number(n1) - call random_number(n2) - x1=2.0*n1-1.0 - x2=2.0*n2-1.0 - w = x1 * x1 + x2 * x2 - enddo - w=((-2.0*log(w))/w)**0.5 - y1=x1*w - y2=x2*w - use_last=1 - endif - gaussian=y1 - end function diff --git a/srcsparsity/haar.f90 b/srcsparsity/haar.f90 deleted file mode 100644 index fbe0c30..0000000 --- a/srcsparsity/haar.f90 +++ /dev/null @@ -1,49 +0,0 @@ - subroutine predict(vec, N, direction ) - implicit none - real vec(*) - integer N !must be power of 2 - integer direction !0:forward 1:inverse - !local variables - integer half - integer cnt,i,j - real predictVal - half = N/2 - cnt = 0 - - do i=1,half - predictVal = vec(i) - j = i + half - if(direction == 0) then - vec(j) = vec(j) - predictVal - else if (direction == 1) then - vec(j) = vec(j) + predictVal - else - print*,"haar::predict: bad direction value" - stop - endif - enddo - end subroutine - - subroutine update( vec, N, direction ) - implicit none - real vec(*) - integer N !must be power of 2 - integer direction !0:forward 1:inverse - !local variables - integer half - integer cnt,i,j - real updateVal - half = N/2 - do i=1,half - j = i + half - updateVal = vec(j) / 2.0 - if (direction == 0) then - vec(i) = vec(i) + updateVal; - else if (direction ==1) then - vec(i) = vec(i) - updateVal - else - print*,"update: bad direction value" - stop - endif - enddo - end subroutine diff --git a/srcsparsity/inversestep.f90 b/srcsparsity/inversestep.f90 deleted file mode 100644 index 82b379c..0000000 --- a/srcsparsity/inversestep.f90 +++ /dev/null @@ -1,25 +0,0 @@ - subroutine inversestep(vec,n) - implicit none - integer n - real vec(n) - - integer half, k - half=int(n/2.0) - do k=1,half,1 - vec(k)=(sqrt(3.0)+1.0)/sqrt(2.0) * vec(k) - vec(k+half)=(sqrt(3.0)-1.0)/sqrt(2.0) * vec(k+half) - enddo - do k=1,half-1,1 - vec(k)=vec(k)+vec(half+k+1) - enddo - vec(half)=vec(half)+vec(half+1) - vec(half+1)=vec(half+1)+sqrt(3.0)/4.0*vec(1)+ & - (sqrt(3.0)-2)/4.0*vec(half) - do k=2,half,1 - vec(half+k)=vec(half+k)+sqrt(3.0)/4.0*vec(k)+ & - (sqrt(3.0)-2)/4.0*vec(k-1) - enddo - do k=1,half,1 - vec(k)=vec(k)-sqrt(3.0)*vec(half+k) - enddo - end subroutine diff --git a/srcsparsity/inversetrans.f90 b/srcsparsity/inversetrans.f90 deleted file mode 100644 index d056281..0000000 --- a/srcsparsity/inversetrans.f90 +++ /dev/null @@ -1,47 +0,0 @@ - subroutine inversetrans(vec,n,mxl,tp) - implicit none - integer n - real vec(n) - integer i - integer mxl,tp - integer inverse - i=n/(2**mxl) !n-->n/2 - if (tp == 1) then - inverse=1 - do while (i.le.n) - call normalizationi(vec,i) - call update(vec,i,inverse) - call predict(vec,i,inverse) - call merge1(vec,i) - i=i*2 - enddo - endif - if (tp == 2) then - do while (i.le.n) - call inversestep(vec,i) - call merge1(vec,i) - i=i*2 - enddo - endif - if (tp == 3) then - do while (i.le.n) - call invTransformD8(vec,i) - i=i*2 - enddo - endif - end subroutine - - - subroutine normalizationi(x,i) - implicit none - real x(*) - integer i - - integer k - do k=1,i/2 - x(k)=x(k)/sqrt(2.0) - enddo - do k=i/2+1,i - x(k)=x(k)*sqrt(2.0) - enddo - end diff --git a/srcsparsity/invtrans3d.f90 b/srcsparsity/invtrans3d.f90 deleted file mode 100644 index 841889d..0000000 --- a/srcsparsity/invtrans3d.f90 +++ /dev/null @@ -1,32 +0,0 @@ - subroutine invwavetrans(nx,ny,nz,x,mxl,mxld,HorizonType,VerticalType) - implicit none - integer mxl,mxld,HorizonType,VerticalType - integer nx,ny,nz - real x(*) - real fxs(nx),fys(ny),fzs(nz) - integer k,j,i -!c local variables - do k=1,ny - do j=1,nx - fzs=x(j+(k-1)*nx:j+(k-1)*nx+(nz-1)*nx*ny:nx*ny) - call inversetrans(fzs,nz,mxld,VerticalType) - x(j+(k-1)*nx:j+(k-1)*nx+(nz-1)*nx*ny:nx*ny)=fzs - enddo - enddo - - do k=1,nz - do j=1,nx - fys=x(j+(k-1)*nx*ny:j+(ny-1)*nx+(k-1)*nx*ny:nx) - call inversetrans(fys,ny,mxl,HorizonType) - x(j+(k-1)*nx*ny:j+(ny-1)*nx+(k-1)*nx*ny:nx)=fys - enddo - enddo - - do k=1,nz - do j=1,ny - fxs=x(1+(j-1)*nx+(k-1)*nx*ny:nx+(j-1)*nx+(k-1)*nx*ny) - call inversetrans(fxs,nx,mxl,HorizonType) - x(1+(j-1)*nx+(k-1)*nx*ny:nx+(j-1)*nx+(k-1)*nx*ny)=fxs - enddo - enddo - end subroutine diff --git a/srcsparsity/lsmrDataModule.f90 b/srcsparsity/lsmrDataModule.f90 deleted file mode 100644 index fb94f29..0000000 --- a/srcsparsity/lsmrDataModule.f90 +++ /dev/null @@ -1,24 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File lsmrDataModule.f90 -! -! Defines real(dp) and a few constants for use in other modules. -! -! 24 Oct 2007: Allows floating-point precision dp to be defined -! in exactly one place (here). Note that we need -! use lsmrDataModule -! at the beginning of modules AND inside interfaces. -! zero and one are not currently used by LSMR, -! but this shows how they should be declared -! by a user routine that does need them. -! 16 Jul 2010: LSMR version derived from LSQR equivalent. -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module lsmrDataModule - - implicit none - - intrinsic :: selected_real_kind - integer, parameter, public :: dp = selected_real_kind(4) - real(dp), parameter, public :: zero = 0.0_dp, one = 1.0_dp - -end module lsmrDataModule diff --git a/srcsparsity/lsmrModule.f90 b/srcsparsity/lsmrModule.f90 deleted file mode 100644 index 395ef00..0000000 --- a/srcsparsity/lsmrModule.f90 +++ /dev/null @@ -1,754 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File lsmrModule.f90 -! -! LSMR -! -! LSMR solves Ax = b or min ||Ax - b|| with or without damping, -! using the iterative algorithm of David Fong and Michael Saunders: -! http://www.stanford.edu/group/SOL/software/lsmr.html -! -! Maintained by -! David Fong -! Michael Saunders -! Systems Optimization Laboratory (SOL) -! Stanford University -! Stanford, CA 94305-4026, USA -! -! 17 Jul 2010: F90 LSMR derived from F90 LSQR and lsqr.m. -! 07 Sep 2010: Local reorthogonalization now works (localSize > 0). -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module lsmrModule - - use lsmrDataModule, only : dp - use lsmrblasInterface, only : dnrm2, dscal - implicit none - private - public :: LSMR - -contains - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! subroutine LSMR ( m, n, Aprod1, Aprod2, b, damp, & -! atol, btol, conlim, itnlim, localSize, nout, & -! x, istop, itn, normA, condA, normr, normAr, normx ) - subroutine LSMR ( m, n, leniw, lenrw,iw,rw, b, damp, & - atol, btol, conlim, itnlim, localSize, nout, & - x, istop, itn, normA, condA, normr, normAr, normx ) - - integer, intent(in) :: leniw - integer, intent(in) :: lenrw - integer, intent(in) :: iw(leniw) - real, intent(in) :: rw(lenrw) - - integer, intent(in) :: m, n, itnlim, localSize, nout - integer, intent(out) :: istop, itn - real(dp), intent(in) :: b(m) - real(dp), intent(out) :: x(n) - real(dp), intent(in) :: atol, btol, conlim, damp - real(dp), intent(out) :: normA, condA, normr, normAr, normx - - interface - subroutine aprod(mode,m,n,x,y,leniw,lenrw,iw,rw) ! y := y + A*x - use lsmrDataModule, only : dp - integer, intent(in) :: mode,lenrw - integer, intent(in) :: leniw - real, intent(in) :: rw(lenrw) - integer, intent(in) :: iw(leniw) - integer, intent(in) :: m,n - real(dp), intent(inout) :: x(n) - real(dp), intent(inout) :: y(m) - end subroutine aprod -! subroutine Aprod1(m,n,x,y) ! y := y + A*x -! use lsmrDataModule, only : dp -! integer, intent(in) :: m,n -! real(dp), intent(in) :: x(n) -! real(dp), intent(inout) :: y(m) -! end subroutine Aprod1 -! -! subroutine Aprod2(m,n,x,y) ! x := x + A'*y -! use lsmrDataModule, only : dp -! integer, intent(in) :: m,n -! real(dp), intent(inout) :: x(n) -! real(dp), intent(in) :: y(m) -! end subroutine Aprod2 - end interface - - !------------------------------------------------------------------- - ! LSMR finds a solution x to the following problems: - ! - ! 1. Unsymmetric equations: Solve A*x = b - ! - ! 2. Linear least squares: Solve A*x = b - ! in the least-squares sense - ! - ! 3. Damped least squares: Solve ( A )*x = ( b ) - ! ( damp*I ) ( 0 ) - ! in the least-squares sense - ! - ! where A is a matrix with m rows and n columns, b is an m-vector, - ! and damp is a scalar. (All quantities are real.) - ! The matrix A is treated as a linear operator. It is accessed - ! by means of subroutine calls with the following purpose: - ! - ! call Aprod1(m,n,x,y) must compute y = y + A*x without altering x. - ! call Aprod2(m,n,x,y) must compute x = x + A'*y without altering y. - ! - ! LSMR uses an iterative method to approximate the solution. - ! The number of iterations required to reach a certain accuracy - ! depends strongly on the scaling of the problem. Poor scaling of - ! the rows or columns of A should therefore be avoided where - ! possible. - ! - ! For example, in problem 1 the solution is unaltered by - ! row-scaling. If a row of A is very small or large compared to - ! the other rows of A, the corresponding row of ( A b ) should be - ! scaled up or down. - ! - ! In problems 1 and 2, the solution x is easily recovered - ! following column-scaling. Unless better information is known, - ! the nonzero columns of A should be scaled so that they all have - ! the same Euclidean norm (e.g., 1.0). - ! - ! In problem 3, there is no freedom to re-scale if damp is - ! nonzero. However, the value of damp should be assigned only - ! after attention has been paid to the scaling of A. - ! - ! The parameter damp is intended to help regularize - ! ill-conditioned systems, by preventing the true solution from - ! being very large. Another aid to regularization is provided by - ! the parameter condA, which may be used to terminate iterations - ! before the computed solution becomes very large. - ! - ! Note that x is not an input parameter. - ! If some initial estimate x0 is known and if damp = 0, - ! one could proceed as follows: - ! - ! 1. Compute a residual vector r0 = b - A*x0. - ! 2. Use LSMR to solve the system A*dx = r0. - ! 3. Add the correction dx to obtain a final solution x = x0 + dx. - ! - ! This requires that x0 be available before and after the call - ! to LSMR. To judge the benefits, suppose LSMR takes k1 iterations - ! to solve A*x = b and k2 iterations to solve A*dx = r0. - ! If x0 is "good", norm(r0) will be smaller than norm(b). - ! If the same stopping tolerances atol and btol are used for each - ! system, k1 and k2 will be similar, but the final solution x0 + dx - ! should be more accurate. The only way to reduce the total work - ! is to use a larger stopping tolerance for the second system. - ! If some value btol is suitable for A*x = b, the larger value - ! btol*norm(b)/norm(r0) should be suitable for A*dx = r0. - ! - ! Preconditioning is another way to reduce the number of iterations. - ! If it is possible to solve a related system M*x = b efficiently, - ! where M approximates A in some helpful way - ! (e.g. M - A has low rank or its elements are small relative to - ! those of A), LSMR may converge more rapidly on the system - ! A*M(inverse)*z = b, - ! after which x can be recovered by solving M*x = z. - ! - ! NOTE: If A is symmetric, LSMR should not be used! - ! Alternatives are the symmetric conjugate-gradient method (CG) - ! and/or SYMMLQ. - ! SYMMLQ is an implementation of symmetric CG that applies to - ! any symmetric A and will converge more rapidly than LSMR. - ! If A is positive definite, there are other implementations of - ! symmetric CG that require slightly less work per iteration - ! than SYMMLQ (but will take the same number of iterations). - ! - ! - ! Notation - ! -------- - ! The following quantities are used in discussing the subroutine - ! parameters: - ! - ! Abar = ( A ), bbar = (b) - ! (damp*I) (0) - ! - ! r = b - A*x, rbar = bbar - Abar*x - ! - ! normr = sqrt( norm(r)**2 + damp**2 * norm(x)**2 ) - ! = norm( rbar ) - ! - ! eps = the relative precision of floating-point arithmetic. - ! On most machines, eps is about 1.0e-7 and 1.0e-16 - ! in single and double precision respectively. - ! We expect eps to be about 1e-16 always. - ! - ! LSMR minimizes the function normr with respect to x. - ! - ! - ! Parameters - ! ---------- - ! m input m, the number of rows in A. - ! - ! n input n, the number of columns in A. - ! - ! Aprod1, Aprod2 See above. - ! - ! damp input The damping parameter for problem 3 above. - ! (damp should be 0.0 for problems 1 and 2.) - ! If the system A*x = b is incompatible, values - ! of damp in the range 0 to sqrt(eps)*norm(A) - ! will probably have a negligible effect. - ! Larger values of damp will tend to decrease - ! the norm of x and reduce the number of - ! iterations required by LSMR. - ! - ! The work per iteration and the storage needed - ! by LSMR are the same for all values of damp. - ! - ! b(m) input The rhs vector b. - ! - ! x(n) output Returns the computed solution x. - ! - ! atol input An estimate of the relative error in the data - ! defining the matrix A. For example, if A is - ! accurate to about 6 digits, set atol = 1.0e-6. - ! - ! btol input An estimate of the relative error in the data - ! defining the rhs b. For example, if b is - ! accurate to about 6 digits, set btol = 1.0e-6. - ! - ! conlim input An upper limit on cond(Abar), the apparent - ! condition number of the matrix Abar. - ! Iterations will be terminated if a computed - ! estimate of cond(Abar) exceeds conlim. - ! This is intended to prevent certain small or - ! zero singular values of A or Abar from - ! coming into effect and causing unwanted growth - ! in the computed solution. - ! - ! conlim and damp may be used separately or - ! together to regularize ill-conditioned systems. - ! - ! Normally, conlim should be in the range - ! 1000 to 1/eps. - ! Suggested value: - ! conlim = 1/(100*eps) for compatible systems, - ! conlim = 1/(10*sqrt(eps)) for least squares. - ! - ! Note: Any or all of atol, btol, conlim may be set to zero. - ! The effect will be the same as the values eps, eps, 1/eps. - ! - ! itnlim input An upper limit on the number of iterations. - ! Suggested value: - ! itnlim = n/2 for well-conditioned systems - ! with clustered singular values, - ! itnlim = 4*n otherwise. - ! - ! localSize input No. of vectors for local reorthogonalization. - ! 0 No reorthogonalization is performed. - ! >0 This many n-vectors "v" (the most recent ones) - ! are saved for reorthogonalizing the next v. - ! localSize need not be more than min(m,n). - ! At most min(m,n) vectors will be allocated. - ! - ! nout input File number for printed output. If positive, - ! a summary will be printed on file nout. - ! - ! istop output An integer giving the reason for termination: - ! - ! 0 x = 0 is the exact solution. - ! No iterations were performed. - ! - ! 1 The equations A*x = b are probably compatible. - ! Norm(A*x - b) is sufficiently small, given the - ! values of atol and btol. - ! - ! 2 damp is zero. The system A*x = b is probably - ! not compatible. A least-squares solution has - ! been obtained that is sufficiently accurate, - ! given the value of atol. - ! - ! 3 damp is nonzero. A damped least-squares - ! solution has been obtained that is sufficiently - ! accurate, given the value of atol. - ! - ! 4 An estimate of cond(Abar) has exceeded conlim. - ! The system A*x = b appears to be ill-conditioned, - ! or there could be an error in Aprod1 or Aprod2. - ! - ! 5 The iteration limit itnlim was reached. - ! - ! itn output The number of iterations performed. - ! - ! normA output An estimate of the Frobenius norm of Abar. - ! This is the square-root of the sum of squares - ! of the elements of Abar. - ! If damp is small and the columns of A - ! have all been scaled to have length 1.0, - ! normA should increase to roughly sqrt(n). - ! A radically different value for normA may - ! indicate an error in Aprod1 or Aprod2. - ! - ! condA output An estimate of cond(Abar), the condition - ! number of Abar. A very high value of condA - ! may again indicate an error in Aprod1 or Aprod2. - ! - ! normr output An estimate of the final value of norm(rbar), - ! the function being minimized (see notation - ! above). This will be small if A*x = b has - ! a solution. - ! - ! normAr output An estimate of the final value of - ! norm( Abar'*rbar ), the norm of - ! the residual for the normal equations. - ! This should be small in all cases. (normAr - ! will often be smaller than the true value - ! computed from the output vector x.) - ! - ! normx output An estimate of norm(x) for the final solution x. - ! - ! Subroutines and functions used - ! ------------------------------ - ! BLAS dscal, dnrm2 - ! USER Aprod1, Aprod2 - ! - ! Precision - ! --------- - ! The number of iterations required by LSMR will decrease - ! if the computation is performed in higher precision. - ! At least 15-digit arithmetic should normally be used. - ! "real(dp)" declarations should normally be 8-byte words. - ! If this ever changes, the BLAS routines dnrm2, dscal - ! (Lawson, et al., 1979) will also need to be changed. - ! - ! - ! Reference - ! --------- - ! http://www.stanford.edu/group/SOL/software/lsmr.html - ! ------------------------------------------------------------------ - ! - ! LSMR development: - ! 21 Sep 2007: Fortran 90 version of LSQR implemented. - ! Aprod1, Aprod2 implemented via f90 interface. - ! 17 Jul 2010: LSMR derived from LSQR and lsmr.m. - ! 07 Sep 2010: Local reorthogonalization now working. - !------------------------------------------------------------------- - - intrinsic :: abs, dot_product, min, max, sqrt - - ! Local arrays and variables - real(dp) :: h(n), hbar(n), u(m), v(n), w(n), localV(n,min(localSize,m,n)) - logical :: damped, localOrtho, localVQueueFull, prnt, show - integer :: i, localOrthoCount, localOrthoLimit, localPointer, localVecs, & - pcount, pfreq - real(dp) :: alpha, alphabar, alphahat, & - beta, betaacute, betacheck, betad, betadd, betahat, & - normb, c, cbar, chat, ctildeold, ctol, & - d, maxrbar, minrbar, normA2, & - rho, rhobar, rhobarold, rhodold, rhoold, rhotemp, & - rhotildeold, rtol, s, sbar, shat, stildeold, & - t1, taud, tautildeold, test1, test2, test3, & - thetabar, thetanew, thetatilde, thetatildeold, & - zeta, zetabar, zetaold - - ! Local constants - real(dp), parameter :: zero = 0.0_dp, one = 1.0_dp - character(len=*), parameter :: enter = ' Enter LSMR. ' - character(len=*), parameter :: exitt = ' Exit LSMR. ' - character(len=*), parameter :: msg(0:7) = & - (/ 'The exact solution is x = 0 ', & - 'Ax - b is small enough, given atol, btol ', & - 'The least-squares solution is good enough, given atol', & - 'The estimate of cond(Abar) has exceeded conlim ', & - 'Ax - b is small enough for this machine ', & - 'The LS solution is good enough for this machine ', & - 'Cond(Abar) seems to be too large for this machine ', & - 'The iteration limit has been reached ' /) - !------------------------------------------------------------------- - - - ! Initialize. - - localVecs = min(localSize,m,n) - show = nout > 0 - if (show) then - write(nout, 1000) enter,m,n,damp,atol,conlim,btol,itnlim,localVecs - end if - - pfreq = 20 ! print frequency (for repeating the heading) - pcount = 0 ! print counter - damped = damp > zero ! - - !------------------------------------------------------------------- - ! Set up the first vectors u and v for the bidiagonalization. - ! These satisfy beta*u = b, alpha*v = A(transpose)*u. - !------------------------------------------------------------------- - u(1:m) = b(1:m) - v(1:n) = zero - x(1:n) = zero - - alpha = zero - beta = dnrm2 (m, u, 1) - - if (beta > zero) then - call dscal (m, (one/beta), u, 1) - ! call Aprod2(m, n, v, u) ! v = A'*u - call aprod(2,m,n,v,u,leniw,lenrw,iw,rw) - alpha = dnrm2 (n, v, 1) - end if - - if (alpha > zero) then - call dscal (n, (one/alpha), v, 1) - w = v - end if - - normAr = alpha*beta - if (normAr == zero) go to 800 - - ! Initialization for local reorthogonalization. - - localOrtho = .false. - if (localVecs > 0) then - localPointer = 1 - localOrtho = .true. - localVQueueFull = .false. - localV(:,1) = v - end if - - ! Initialize variables for 1st iteration. - - itn = 0 - zetabar = alpha*beta - alphabar = alpha - rho = 1 - rhobar = 1 - cbar = 1 - sbar = 0 - - h = v - hbar(1:n) = zero - x(1:n) = zero - - ! Initialize variables for estimation of ||r||. - - betadd = beta - betad = 0 - rhodold = 1 - tautildeold = 0 - thetatilde = 0 - zeta = 0 - d = 0 - - ! Initialize variables for estimation of ||A|| and cond(A). - - normA2 = alpha**2 - maxrbar = 0_dp - minrbar = 1e+30_dp - - ! Items for use in stopping rules. - normb = beta - istop = 0 - ctol = zero - if (conlim > zero) ctol = one/conlim - normr = beta - - ! Exit if b=0 or A'b = 0. - - normAr = alpha * beta - if (normAr == 0) then - if (show) then - write(nout,'(a)') msg(1) - end if - return - end if - - ! Heading for iteration log. - - if (show) then - if (damped) then - write(nout,1300) - else - write(nout,1200) - end if - test1 = one - test2 = alpha/beta - write(nout, 1500) itn,x(1),normr,normAr,test1,test2 - end if - - !=================================================================== - ! Main iteration loop. - !=================================================================== - do - itn = itn + 1 - - !---------------------------------------------------------------- - ! Perform the next step of the bidiagonalization to obtain the - ! next beta, u, alpha, v. These satisfy - ! beta*u = A*v - alpha*u, - ! alpha*v = A'*u - beta*v. - !---------------------------------------------------------------- - call dscal (m,(- alpha), u, 1) - ! call Aprod1(m, n, v, u) ! u = A*v - call aprod ( 1,m,n,v,u,leniw,lenrw,iw,rw ) - beta = dnrm2 (m, u, 1) - - if (beta > zero) then - call dscal (m, (one/beta), u, 1) - if (localOrtho) then ! Store v into the circular buffer localV. - call localVEnqueue ! Store old v for local reorthog'n of new v. - end if - call dscal (n, (- beta), v, 1) - - !call Aprod2(m, n, v, u) ! v = A'*u - call aprod ( 2,m,n,v,u,leniw,lenrw,iw,rw ) - if (localOrtho) then ! Perform local reorthogonalization of V. - call localVOrtho ! Local-reorthogonalization of new v. - end if - alpha = dnrm2 (n, v, 1) - if (alpha > zero) then - call dscal (n, (one/alpha), v, 1) - end if - end if - - ! At this point, beta = beta_{k+1}, alpha = alpha_{k+1}. - - !---------------------------------------------------------------- - ! Construct rotation Qhat_{k,2k+1}. - - alphahat = d2norm(alphabar, damp) - chat = alphabar/alphahat - shat = damp/alphahat - - ! Use a plane rotation (Q_i) to turn B_i to R_i. - - rhoold = rho - rho = d2norm(alphahat, beta) - c = alphahat/rho - s = beta/rho - thetanew = s*alpha - alphabar = c*alpha - - ! Use a plane rotation (Qbar_i) to turn R_i^T into R_i^bar. - - rhobarold = rhobar - zetaold = zeta - thetabar = sbar*rho - rhotemp = cbar*rho - rhobar = d2norm(cbar*rho, thetanew) - cbar = cbar*rho/rhobar - sbar = thetanew/rhobar - zeta = cbar*zetabar - zetabar = - sbar*zetabar - - ! Update h, h_hat, x. - - hbar = h - (thetabar*rho/(rhoold*rhobarold))*hbar - x = x + (zeta/(rho*rhobar))*hbar - h = v - (thetanew/rho)*h - - ! Estimate ||r||. - - ! Apply rotation Qhat_{k,2k+1}. - betaacute = chat* betadd - betacheck = - shat* betadd - - ! Apply rotation Q_{k,k+1}. - betahat = c*betaacute - betadd = - s*betaacute - - ! Apply rotation Qtilde_{k-1}. - ! betad = betad_{k-1} here. - - thetatildeold = thetatilde - rhotildeold = d2norm(rhodold, thetabar) - ctildeold = rhodold/rhotildeold - stildeold = thetabar/rhotildeold - thetatilde = stildeold* rhobar - rhodold = ctildeold* rhobar - betad = - stildeold*betad + ctildeold*betahat - - ! betad = betad_k here. - ! rhodold = rhod_k here. - - tautildeold = (zetaold - thetatildeold*tautildeold)/rhotildeold - taud = (zeta - thetatilde*tautildeold)/rhodold - d = d + betacheck**2 - normr = sqrt(d + (betad - taud)**2 + betadd**2) - - ! Estimate ||A||. - normA2 = normA2 + beta**2 - normA = sqrt(normA2) - normA2 = normA2 + alpha**2 - - ! Estimate cond(A). - maxrbar = max(maxrbar,rhobarold) - if (itn > 1) then - minrbar = min(minrbar,rhobarold) - end if - condA = max(maxrbar,rhotemp)/min(minrbar,rhotemp) - - !---------------------------------------------------------------- - ! Test for convergence. - !---------------------------------------------------------------- - - ! Compute norms for convergence testing. - normAr = abs(zetabar) - normx = dnrm2(n, x, 1) - - ! Now use these norms to estimate certain other quantities, - ! some of which will be small near a solution. - - test1 = normr /normb - test2 = normAr/(normA*normr) - test3 = one/condA - t1 = test1/(one + normA*normx/normb) - rtol = btol + atol*normA*normx/normb - - ! The following tests guard against extremely small values of - ! atol, btol or ctol. (The user may have set any or all of - ! the parameters atol, btol, conlim to 0.) - ! The effect is equivalent to the normAl tests using - ! atol = eps, btol = eps, conlim = 1/eps. - - if (itn >= itnlim) istop = 7 - if (one+test3 <= one) istop = 6 - if (one+test2 <= one) istop = 5 - if (one+t1 <= one) istop = 4 - - ! Allow for tolerances set by the user. - - if ( test3 <= ctol) istop = 3 - if ( test2 <= atol) istop = 2 - if ( test1 <= rtol) istop = 1 - - !---------------------------------------------------------------- - ! See if it is time to print something. - !---------------------------------------------------------------- - prnt = .false. - if (show) then - if (n <= 40) prnt = .true. - if (itn <= 10) prnt = .true. - if (itn >= itnlim-10) prnt = .true. - if (mod(itn,10) == 0) prnt = .true. - if (test3 <= 1.1*ctol) prnt = .true. - if (test2 <= 1.1*atol) prnt = .true. - if (test1 <= 1.1*rtol) prnt = .true. - if (istop /= 0) prnt = .true. - - if (prnt) then ! Print a line for this iteration - if (pcount >= pfreq) then ! Print a heading first - pcount = 0 - if (damped) then - write(nout,1300) - else - write(nout,1200) - end if - end if - pcount = pcount + 1 - write(nout,1500) itn,x(1),normr,normAr,test1,test2,normA,condA - end if - end if - - if (istop /= 0) exit - end do - !=================================================================== - ! End of iteration loop. - !=================================================================== - - ! Come here if normAr = 0, or if normal exit. - -800 if (damped .and. istop==2) istop=3 ! Decide if istop = 2 or 3. - if (show) then ! Print the stopping condition. - write(nout, 2000) & - exitt,istop,itn, & - exitt,normA,condA, & - exitt,normb, normx, & - exitt,normr,normAr - write(nout, 3000) & - exitt, msg(istop) - end if - - return - - 1000 format(// a, ' Least-squares solution of Ax = b' & - / ' The matrix A has', i7, ' rows and', i7, ' columns' & - / ' damp =', es22.14 & - / ' atol =', es10.2, 15x, 'conlim =', es10.2 & - / ' btol =', es10.2, 15x, 'itnlim =', i10 & - / ' localSize (no. of vectors for local reorthogonalization) =', i7) - 1200 format(/ " Itn x(1) norm r A'r ", & - ' Compatible LS norm A cond A') - 1300 format(/ " Itn x(1) norm rbar Abar'rbar", & - ' Compatible LS norm Abar cond Abar') - 1500 format(i6, 2es17.9, 5es10.2) - 2000 format(/ a, 5x, 'istop =', i2, 15x, 'itn =', i8 & - / a, 5x, 'normA =', es12.5, 5x, 'condA =', es12.5 & - / a, 5x, 'normb =', es12.5, 5x, 'normx =', es12.5 & - / a, 5x, 'normr =', es12.5, 5x, 'normAr =', es12.5) - 3000 format(a, 5x, a) - - contains - - function d2norm( a, b ) - - real(dp) :: d2norm - real(dp), intent(in) :: a, b - - !------------------------------------------------------------------- - ! d2norm returns sqrt( a**2 + b**2 ) - ! with precautions to avoid overflow. - ! - ! 21 Mar 1990: First version. - ! 17 Sep 2007: Fortran 90 version. - ! 24 Oct 2007: User real(dp) instead of compiler option -r8. - !------------------------------------------------------------------- - - intrinsic :: abs, sqrt - real(dp) :: scale - real(dp), parameter :: zero = 0.0_dp - - scale = abs(a) + abs(b) - if (scale == zero) then - d2norm = zero - else - d2norm = scale*sqrt((a/scale)**2 + (b/scale)**2) - end if - - end function d2norm - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - subroutine localVEnqueue - - ! Store v into the circular buffer localV. - - if (localPointer < localVecs) then - localPointer = localPointer + 1 - else - localPointer = 1 - localVQueueFull = .true. - end if - localV(:,localPointer) = v - - end subroutine localVEnqueue - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - subroutine localVOrtho - - ! Perform local reorthogonalization of current v. - - real(dp) :: d - - if (localVQueueFull) then - localOrthoLimit = localVecs - else - localOrthoLimit = localPointer - end if - - do localOrthoCount = 1, localOrthoLimit - d = dot_product(v,localV(:,localOrthoCount)) - v = v - d * localV(:,localOrthoCount) - end do - - end subroutine localVOrtho - - end subroutine LSMR - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -end module LSMRmodule diff --git a/srcsparsity/lsmrblas.f90 b/srcsparsity/lsmrblas.f90 deleted file mode 100644 index 31574e2..0000000 --- a/srcsparsity/lsmrblas.f90 +++ /dev/null @@ -1,360 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File lsmrblas.f90 (double precision) -! -! This file contains the following BLAS routines -! dcopy, ddot, dnrm2, dscal -! required by subroutines LSMR and Acheck. -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! -!! DCOPY copies a vector X to a vector Y. -! -! Discussion: -! This routine uses double precision real arithmetic. -! The routine uses unrolled loops for increments equal to one. -! -! Modified: -! 16 May 2005 -! -! Author: -! Jack Dongarra -! Fortran90 translation by John Burkardt. -! -! Reference: -! -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of elements in DX and DY. -! -! Input, real ( kind = 8 ) DX(*), the first vector. -! -! Input, integer INCX, the increment between successive entries of DX. -! -! Output, real ( kind = 8 ) DY(*), the second vector. -! -! Input, integer INCY, the increment between successive entries of DY. - - - subroutine dcopy(n,dx,incx,dy,incy) - - implicit none -! double precision dx(*),dy(*) - real(4) dx(*),dy(*) - integer i,incx,incy,ix,iy,m,n - - if ( n <= 0 ) then - return - end if - - if ( incx == 1 .and. incy == 1 ) then - - m = mod ( n, 7 ) - - if ( m /= 0 ) then - dy(1:m) = dx(1:m) - end if - - do i = m+1, n, 7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - end do - - else - - if ( 0 <= incx ) then - ix = 1 - else - ix = ( -n + 1 ) * incx + 1 - end if - - if ( 0 <= incy ) then - iy = 1 - else - iy = ( -n + 1 ) * incy + 1 - end if - - do i = 1, n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - end do - end if - return -end subroutine dcopy - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!! DDOT forms the dot product of two vectors. -! -! Discussion: -! This routine uses double precision real arithmetic. -! This routine uses unrolled loops for increments equal to one. -! -! Modified: -! 16 May 2005 -! -! Author: -! Jack Dongarra -! Fortran90 translation by John Burkardt. -! -! Reference: -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of entries in the vectors. -! -! Input, real ( kind = 8 ) DX(*), the first vector. -! -! Input, integer INCX, the increment between successive entries in DX. -! -! Input, real ( kind = 8 ) DY(*), the second vector. -! -! Input, integer INCY, the increment between successive entries in DY. -! -! Output, real ( kind = 8 ) DDOT, the sum of the product of the -! corresponding entries of DX and DY. - - - ! double precision function ddot(n,dx,incx,dy,incy) - real(4) function ddot(n,dx,incx,dy,incy) - - implicit none - ! double precision dx(*),dy(*),dtemp - real(4) dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,n - - ddot = 0.0d0 - dtemp = 0.0d0 - if ( n <= 0 ) then - return - end if - -! Code for unequal increments or equal increments -! not equal to 1. - - if ( incx /= 1 .or. incy /= 1 ) then - - if ( 0 <= incx ) then - ix = 1 - else - ix = ( - n + 1 ) * incx + 1 - end if - - if ( 0 <= incy ) then - iy = 1 - else - iy = ( - n + 1 ) * incy + 1 - end if - - do i = 1, n - dtemp = dtemp + dx(ix) * dy(iy) - ix = ix + incx - iy = iy + incy - end do - -! Code for both increments equal to 1. - - else - - m = mod ( n, 5 ) - - do i = 1, m - dtemp = dtemp + dx(i) * dy(i) - end do - - do i = m+1, n, 5 - dtemp = dtemp + dx(i)*dy(i) + dx(i+1)*dy(i+1) + dx(i+2)*dy(i+2) & - + dx(i+3)*dy(i+3) + dx(i+4)*dy(i+4) - end do - - end if - - ddot = dtemp - return -end function ddot - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!*****************************************************************************80 -! -!! DNRM2 returns the euclidean norm of a vector. -! -! Discussion: -! This routine uses double precision real arithmetic. -! DNRM2 ( X ) = sqrt ( X' * X ) -! -! Modified: -! 16 May 2005 -! -! Author: -! Sven Hammarling -! Fortran90 translation by John Burkardt. -! -! Reference: -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of entries in the vector. -! -! Input, real ( kind = 8 ) X(*), the vector whose norm is to be computed. -! -! Input, integer INCX, the increment between successive entries of X. -! -! Output, real ( kind = 8 ) DNRM2, the Euclidean norm of X. -! - - ! double precision function dnrm2 ( n, x, incx) - real(4) function dnrm2 ( n, x, incx) - implicit none - integer ix,n,incx - ! double precision x(*), ssq,absxi,norm,scale - real(4) x(*), ssq,absxi,norm,scale - - if ( n < 1 .or. incx < 1 ) then - norm = 0.d0 - else if ( n == 1 ) then - norm = abs ( x(1) ) - else - scale = 0.d0 - ssq = 1.d0 - - do ix = 1, 1 + ( n - 1 )*incx, incx - if ( x(ix) /= 0.d0 ) then - absxi = abs ( x(ix) ) - if ( scale < absxi ) then - ssq = 1.d0 + ssq * ( scale / absxi )**2 - scale = absxi - else - ssq = ssq + ( absxi / scale )**2 - end if - end if - end do - norm = scale * sqrt ( ssq ) - end if - - dnrm2 = norm - return -end function dnrm2 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! DSCAL scales a vector by a constant. -! -! Discussion: -! This routine uses double precision real arithmetic. -! -! Modified: -! 08 April 1999 -! -! Author: -! Jack Dongarra -! Fortran90 translation by John Burkardt. -! -! Reference: -! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, -! LINPACK User's Guide, -! SIAM, 1979, -! ISBN13: 978-0-898711-72-1, -! LC: QA214.L56. -! -! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, -! Algorithm 539, -! Basic Linear Algebra Subprograms for Fortran Usage, -! ACM Transactions on Mathematical Software, -! Volume 5, Number 3, September 1979, pages 308-323. -! -! Parameters: -! -! Input, integer N, the number of entries in the vector. -! -! Input, real ( kind = 8 ) SA, the multiplier. -! -! Input/output, real ( kind = 8 ) X(*), the vector to be scaled. -! -! Input, integer INCX, the increment between successive entries of X. -! - - subroutine dscal(n,sa,x,incx) - - implicit none - - integer i - integer incx - integer ix - integer m - integer n - !double precision sa - !double precision x(*) - - real(4) sa - real(4) x(*) - if ( n <= 0 ) then - return - else if ( incx == 1 ) then - m = mod ( n, 5 ) - x(1:m) = sa * x(1:m) - - do i = m+1, n, 5 - x(i) = sa * x(i) - x(i+1) = sa * x(i+1) - x(i+2) = sa * x(i+2) - x(i+3) = sa * x(i+3) - x(i+4) = sa * x(i+4) - end do - else - if ( 0 <= incx ) then - ix = 1 - else - ix = ( - n + 1 ) * incx + 1 - end if - - do i = 1, n - x(ix) = sa * x(ix) - ix = ix + incx - end do - - end if - - return -end subroutine dscal -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/srcsparsity/lsmrblasInterface.f90 b/srcsparsity/lsmrblasInterface.f90 deleted file mode 100644 index 58cefa0..0000000 --- a/srcsparsity/lsmrblasInterface.f90 +++ /dev/null @@ -1,41 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! File lsmrblasInterface.f90 -! -! BLAS1 Interfaces: ddot dnrm2 dscal -! -! Maintained by Michael Saunders . -! -! 19 Dec 2008: lsqrblasInterface module implemented. -! Metcalf and Reid recommend putting interfaces in a module. -! 16 Jul 2010: LSMR version derived from LSQR equivalent. -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -module lsmrblasInterface - - implicit none - public :: ddot, dnrm2, dscal - - interface ! Level 1 BLAS - function ddot (n,dx,incx,dy,incy) - use lsmrDataModule, only : dp - integer, intent(in) :: n,incx,incy - real(dp), intent(in) :: dx(*),dy(*) - real(dp) :: ddot - end function ddot - - function dnrm2 (n,dx,incx) - use lsmrDataModule, only : dp - integer, intent(in) :: n,incx - real(dp), intent(in) :: dx(*) - real(dp) :: dnrm2 - end function dnrm2 - - subroutine dscal (n,sa,x,incx) - use lsmrDataModule, only : dp - integer, intent(in) :: n,incx - real(dp), intent(in) :: sa - real(dp), intent(inout) :: x(*) - end subroutine dscal - end interface - -end module lsmrblasInterface diff --git a/srcsparsity/main.f90 b/srcsparsity/main.f90 deleted file mode 100644 index d71999c..0000000 --- a/srcsparsity/main.f90 +++ /dev/null @@ -1,756 +0,0 @@ - ! CODE FOR SURFACE WAVE TOMOGRAPHY USING DISPERSION MEASUREMENTS - ! VERSION: - ! 1.0 - ! AUTHOR: - ! HONGJIAN FANG. fanghj@mail.ustc.edu.cn - ! PURPOSE: - ! DIRECTLY INVERT SURFACE WAVE DISPERSION MEASUREMENTS FOR 3-D - ! STUCTURE WITHOUT THE INTERMEDIATE STEP OF CONSTUCTION THE PHASE - ! OR GROUP VELOCITY MAPS. - ! REFERENCE: - ! Fang, H., Yao, H., Zhang, H., Huang, Y. C., & van der Hilst, R. D. - ! (2015). Direct inversion of surface wave dispersion for - ! three-dimensional shallow crustal structure based on ray tracing: - ! methodology and application. Geophysical Journal International, - ! 201(3), 1251-1263. - ! HISTORY: - ! 2015/01/31 START TO REORGONIZE THE MESSY CODE - ! - - program SurfTomo - use lsmrModule, only:lsmr - use lsmrblasInterface, only : dnrm2 - implicit none - -! VARIABLE DEFINE - - character inputfile*80 - character logfile*100 - character outmodel*100 - character outsyn*100 - logical ex - character dummy*40 - character datafile*80 - - integer nx,ny,nz - real goxd,gozd - real dvxd,dvzd - integer nsrc,nrc - real weight,weight0 - real damp - real minthk - integer kmax,kmaxRc,kmaxRg,kmaxLc,kmaxLg - real*8,dimension(:),allocatable:: tRc,tRg,tLc,tLg - real,dimension(:),allocatable:: depz - integer itn - integer nout - integer localSize - real mean,std_devs,balances,balanceb - integer msurf - integer maxlevel,maxleveld - real,parameter:: tolr=1e-4 - real,dimension(:),allocatable:: obst,dsyn,cbst,wt,dtres,dist,datweight - real,dimension(:),allocatable:: pvall,depRp,pvRp - real sta1_lat,sta1_lon,sta2_lat,sta2_lon - real dist1 - integer dall - integer istep - real,parameter :: pi=3.1415926535898 - integer checkstat - integer ii,jj,kk - real, dimension (:,:), allocatable :: scxf,sczf - real, dimension (:,:,:), allocatable :: rcxf,rczf - integer,dimension(:,:),allocatable::wavetype,igrt,nrc1 - integer,dimension(:),allocatable::nsrc1,knum1 - integer,dimension(:,:),allocatable::periods - real,dimension(:),allocatable::rw - integer,dimension(:),allocatable::iw,col - real,dimension(:),allocatable::dv,norm - real,dimension(:,:,:),allocatable::vsf - real,dimension(:,:,:),allocatable::vsftrue - character strf - integer veltp,wavetp - real velvalue - integer knum,knumo,err - integer istep1,istep2 - integer period - integer knumi,srcnum,count1 - integer HorizonType,VerticalType - character line*200 - integer iter,maxiter - integer iiter,initer - integer maxnar - real acond - real anorm - real arnorm - real rnorm - real xnorm - character str1 - real atol,btol - real conlim - integer istop - integer itnlim - integer lenrw,leniw - integer nar,nar_tmp,nars - integer count3,nvz,nvx - integer m,maxvp,n - integer i,j,k - real Minvel,MaxVel - real spfra - integer domain,normt - real noiselevel - integer ifsyn - integer writepath - real averdws - real maxnorm - real threshold,threshold0 - -! OPEN FILES FIRST TO OUTPUT THE PROCESS - open(34,file='IterVel.out') - nout=36 - open(nout,file='lsmr.txt') - -! OUTPUT PROGRAM INFOMATION - write(*,*) - write(*,*),' S U R F T O M O' - write(*,*),'PLEASE contact Hongjain Fang & - (fanghj@mail.ustc.edu.cn) if you find any bug' - write(*,*) - -! READ INPUT FILE - if (iargc() < 1) then - write(*,*) 'input file [SurfTomo.in(default)]:' - read(*,'(a)') inputfile - if (len_trim(inputfile) <=1 ) then - inputfile = 'SurfTomo.in' - else - inputfile = inputfile(1:len_trim(inputfile)) - endif - else - call getarg(1,inputfile) - endif - inquire(file = inputfile, exist = ex) - if (.not. ex) stop 'unable to open the inputfile' - - open(10,file=inputfile,status='old') - read(10,'(a30)')dummy - read(10,'(a30)')dummy - read(10,'(a30)')dummy - read(10,*)datafile - read(10,*) nx,ny,nz - read(10,*) goxd,gozd - read(10,*) dvxd,dvzd - read(10,*) nsrc - read(10,*) weight0,damp - read(10,*) minthk - read(10,*) Minvel,Maxvel - read(10,*) domain,normt - read(10,*) HorizonType,VerticalType - read(10,*) maxlevel,maxleveld - read(10,*) maxiter,initer - read(10,*) spfra - read(10,*) kmaxRc - write(*,*) 'model origin:latitude,longitue' - write(*,'(2f10.4)') goxd,gozd - write(*,*) 'grid spacing:latitude,longitue' - write(*,'(2f10.4)') dvxd,dvzd - write(*,*) 'model dimension:nx,ny,nz' - write(*,'(3i5)') nx,ny,nz - 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 & - (fanghj@mail.ustc.edu.cn) if you find any bug' - write(66,*) - write(66,*) 'model origin:latitude,longitue' - write(66,'(2f10.4)') goxd,gozd - write(66,*) 'grid spacing:latitude,longitue' - write(66,'(2f10.4)') dvxd,dvzd - write(66,*) 'model dimension:nx,ny,nz' - write(66,'(3i5)') nx,ny,nz - if(kmaxRc.gt.0)then - allocate(tRc(kmaxRc),& - stat=checkstat) - if (checkstat > 0) stop 'error allocating RP' - read(10,*)(tRc(i),i=1,kmaxRc) - write(*,*)'Rayleigh wave phase velocity used,periods:(s)' - write(*,'(50f6.2)')(tRc(i),i=1,kmaxRc) - write(66,*)'Rayleigh wave phase velocity used,periods:(s)' - write(66,'(50f6.2)')(tRc(i),i=1,kmaxRc) - endif - read(10,*)kmaxRg - if(kmaxRg.gt.0)then - allocate(tRg(kmaxRg), stat=checkstat) - if (checkstat > 0) stop 'error allocating RP' - read(10,*)(tRg(i),i=1,kmaxRg) - write(*,*)'Rayleigh wave group velocity used,periods:(s)' - write(*,'(50f6.2)')(tRg(i),i=1,kmaxRg) - write(66,*)'Rayleigh wave group velocity used,periods:(s)' - write(66,'(50f6.2)')(tRg(i),i=1,kmaxRg) - endif - read(10,*)kmaxLc - if(kmaxLc.gt.0)then - allocate(tLc(kmaxLc), stat=checkstat) - if (checkstat > 0) stop 'error allocating RP' - read(10,*)(tLc(i),i=1,kmaxLc) - write(*,*)'Love wave phase velocity used,periods:(s)' - write(*,'(50f6.2)')(tLc(i),i=1,kmaxLc) - write(66,*)'Love wave phase velocity used,periods:(s)' - write(66,'(50f6.2)')(tLc(i),i=1,kmaxLc) - endif - read(10,*)kmaxLg - if(kmaxLg.gt.0)then - allocate(tLg(kmaxLg), stat=checkstat) - if (checkstat > 0) stop 'error allocating RP' - read(10,*)(tLg(i),i=1,kmaxLg) - write(*,*)'Love wave group velocity used,periods:(s)' - write(*,'(50f6.2)')(tLg(i),i=1,kmaxLg) - write(66,*)'Love wave group velocity used,periods:(s)' - write(66,'(50f6.2)')(tLg(i),i=1,kmaxLg) - endif - read(10,*)ifsyn - read(10,*)noiselevel - read(10,*) threshold0 - close(10) - nrc=nsrc - kmax=kmaxRc+kmaxRg+kmaxLc+kmaxLg - -! READ MEASUREMENTS - open(unit=87,file=datafile,status='old') - allocate(scxf(nsrc,kmax),sczf(nsrc,kmax),& - rcxf(nrc,nsrc,kmax),rczf(nrc,nsrc,kmax),stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate' - endif - allocate(periods(nsrc,kmax),wavetype(nsrc,kmax),& - nrc1(nsrc,kmax),nsrc1(kmax),knum1(kmax),& - igrt(nsrc,kmax),stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate' - endif - allocate(obst(nrc*nsrc*kmax),dist(nrc*nsrc*kmax),& - stat=checkstat) - allocate(pvall(nrc*nsrc*kmax),depRp(nrc*nsrc*kmax),& - pvRp(nrc*nsrc*kmax),stat=checkstat) - IF(checkstat > 0)THEN - write(6,*)'error with allocate' - ENDIF - istep=0 - istep2=0 - dall=0 - knumo=12345 - knum=0 - istep1=0 - do - read(87,'(a)',iostat=err) line - if(err.eq.0) then - if(line(1:1).eq.'#') then - read(line,*) str1,sta1_lat,sta1_lon,period,wavetp,veltp - if(wavetp.eq.2.and.veltp.eq.0) knum=period - if(wavetp.eq.2.and.veltp.eq.1) knum=kmaxRc+period - if(wavetp.eq.1.and.veltp.eq.0) knum=kmaxRg+kmaxRc+period - if(wavetp.eq.1.and.veltp.eq.1) knum=kmaxLc+kmaxRg+& - kmaxRc+period - if(knum.ne.knumo) then - istep=0 - istep2=istep2+1 - endif - istep=istep+1 - istep1=0 - sta1_lat=(90.0-sta1_lat)*pi/180.0 - sta1_lon=sta1_lon*pi/180.0 - scxf(istep,knum)=sta1_lat - sczf(istep,knum)=sta1_lon - periods(istep,knum)=period - wavetype(istep,knum)=wavetp - igrt(istep,knum)=veltp - nsrc1(knum)=istep - knum1(istep2)=knum - knumo=knum - else - read(line,*) sta2_lat,sta2_lon,velvalue - istep1=istep1+1 - dall=dall+1 - sta2_lat=(90.0-sta2_lat)*pi/180.0 - sta2_lon=sta2_lon*pi/180.0 - rcxf(istep1,istep,knum)=sta2_lat - rczf(istep1,istep,knum)=sta2_lon - call delsph(sta1_lat,sta1_lon,sta2_lat,sta2_lon,dist1) - dist(dall)=dist1 - obst(dall)=dist1/velvalue - pvall(dall)=velvalue - nrc1(istep,knum)=istep1 - endif - else - exit - endif - enddo - close(87) - allocate(depz(nz), stat=checkstat) - maxnar = dall*nx*ny*nz*spfra!sparsity fraction - maxvp = (nx-2)*(ny-2)*(nz-1) - allocate(dv(maxvp), stat=checkstat) - allocate(norm(maxvp), stat=checkstat) - allocate(vsf(nx,ny,nz), stat=checkstat) - allocate(vsftrue(nx,ny,nz), stat=checkstat) - - allocate(rw(maxnar), stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate: real rw' - endif - allocate(iw(2*maxnar+1), stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate: integer iw' - endif - allocate(col(maxnar), stat=checkstat) - if(checkstat > 0)then - write(6,*)'error with allocate: integer iw' - endif - allocate(cbst(dall+maxvp),dsyn(dall),datweight(dall),wt(dall+maxvp),dtres(dall+maxvp),& - stat=checkstat) - -! MEASUREMENTS STATISTICS AND READ INITIAL MODEL - write(*,'(a,i7)') 'Number of all measurements',dall - - open(10,file='MOD',status='old') - read(10,*) (depz(i),i=1,nz) - do k = 1,nz - do j = 1,ny - read(10,*)(vsf(i,j,k),i=1,nx) - enddo - enddo - close(10) - write(*,*) 'grid points in depth direction:(km)' - write(*,'(50f6.2)') depz - - - -! CHECKERBOARD TEST - if (ifsyn == 1) then - write(*,*) 'Checkerboard Resolution Test Begin' - vsftrue = vsf - - open(11,file='MOD.true',status='old') - do k = 1,nz - do j = 1,ny - read(11,*) (vsftrue(i,j,k),i=1,nx) - enddo - enddo - close(11) - - call synthetic(nx,ny,nz,maxvp,vsftrue,obst,& - goxd,gozd,dvxd,dvzd,kmaxRc,kmaxRg,kmaxLc,kmaxLg,& - tRc,tRg,tLc,tLg,wavetype,igrt,periods,depz,minthk,& - scxf,sczf,rcxf,rczf,nrc1,nsrc1,knum1,kmax,& - nsrc,nrc,noiselevel) - endif - - - -! ITERATE UNTILL CONVERGE - writepath = 0 - do iter = 1,maxiter - iw = 0 - rw = 0.0 - col = 0 - -! COMPUTE SENSITIVITY MATRIX - if (iter == maxiter) then - writepath = 1 - open(40,file='raypath.out') - endif - write(*,*) 'computing sensitivity matrix...' - call CalSurfG(nx,ny,nz,maxvp,vsf,iw,rw,col,dsyn,& - goxd,gozd,dvxd,dvzd,kmaxRc,kmaxRg,kmaxLc,kmaxLg,& - tRc,tRg,tLc,tLg,wavetype,igrt,periods,depz,minthk,& - scxf,sczf,rcxf,rczf,nrc1,nsrc1,knum1,kmax,& - nsrc,nrc,nar,domain,& - maxlevel,maxleveld,HorizonType,VerticalType,writepath) - - do i = 1,dall - cbst(i) = obst(i) - dsyn(i) - enddo - - threshold = threshold0+(maxiter/2-iter)/3*0.5 - do i = 1,dall - datweight(i) = 1.0 - if(abs(cbst(i)) > threshold) then - datweight(i) = exp(-(abs(cbst(i))-threshold)) - endif - cbst(i) = cbst(i)*datweight(i) - enddo - - do i = 1,nar - rw(i) = rw(i)*datweight(iw(1+i)) - enddo - - norm=0 - do i=1,nar - norm(col(i))=norm(col(i))+abs(rw(i)) - enddo - averdws=0 - maxnorm=0 - do i=1,maxvp - averdws = averdws+norm(i) - if(norm(i)>maxnorm) maxnorm=norm(i) - enddo - averdws=averdws/maxvp - write(66,*)'Maximum and Average DWS values:',maxnorm,averdws - write(66,*)'Threshold is:',threshold - -! WRITE OUT RESIDUAL FOR THE FIRST AND LAST ITERATION - if(iter.eq.1) then - open(88,file='residualFirst.dat') - do i=1,dall - write(88,*) dist(i),dsyn(i),obst(i), & - dsyn(i)*datweight(i),obst(i)*datweight(i),datweight(i) - enddo - close(88) - endif - if(iter.eq.maxiter) then - open(88,file='residualLast.dat') - do i=1,dall - write(88,*) dist(i),dsyn(i),obst(i), & - dsyn(i)*datweight(i),obst(i)*datweight(i),datweight(i) - enddo - close(88) - endif - - -! ADDING REGULARIZATION TERM - weight=dnrm2(dall,cbst,1)**2/dall*weight0 - nar_tmp=nar - nars=0 - ! if (domain == 0 .and. normt==0) then - if (domain == 0) then - do i=1,maxvp - rw(nar+i)=weight - iw(1+nar+i)=dall+i - col(nar+i)=i - cbst(dall+i)=0 - enddo - nar = nar + maxvp - m = dall + maxvp - n = maxvp - ! elseif(domain == 0 .and. normt/=0) then - ! do i=1,maxvp - ! rw(nar+i)=weight - ! iw(1+nar+i)=dall+i - ! col(nar+i)=i - ! cbst(dall+i)=0 - ! enddo - ! nar = nar + maxvp - ! m = dall + maxvp - ! n = maxvp - else - count3=0 - nvz=ny-2 - nvx=nx-2 - do k=1,nz-1 - do j=1,nvz - do i=1,nvx - if(i==1.or.i==nvx.or.j==1.or.j==nvz.or.k==1.or.k==nz-1)then - count3=count3+1 - col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i - rw(nar+1)=2.0*weight - iw(1+nar+1)=dall+count3 - cbst(dall+count3)=0 - nar=nar+1 - else - count3=count3+1 - col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i - rw(nar+1)=6.0*weight - iw(1+nar+1)=dall+count3 - rw(nar+2)=-1.0*weight - iw(1+nar+2)=dall+count3 - col(nar+2)=(k-1)*nvz*nvx+(j-1)*nvx+i-1 - rw(nar+3)=-1.0*weight - iw(1+nar+3)=dall+count3 - col(nar+3)=(k-1)*nvz*nvx+(j-1)*nvx+i+1 - rw(nar+4)=-1.0*weight - iw(1+nar+4)=dall+count3 - col(nar+4)=(k-1)*nvz*nvx+(j-2)*nvx+i - rw(nar+5)=-1.0*weight - iw(1+nar+5)=dall+count3 - col(nar+5)=(k-1)*nvz*nvx+j*nvx+i - rw(nar+6)=-1.0*weight - iw(1+nar+6)=dall+count3 - col(nar+6)=(k-2)*nvz*nvx+(j-1)*nvx+i - rw(nar+7)=-1.0*weight - iw(1+nar+7)=dall+count3 - col(nar+7)=k*nvz*nvx+(j-1)*nvx+i - cbst(dall+count3)=0 - nar=nar+7 - endif - enddo - enddo - enddo - m = dall + count3 - n = maxvp - nars = nar - nar_tmp - rw(nar+1:nar+nars) = rw(nar_tmp+1:nar) - endif - - iw(1)=nar - do i=1,nar - iw(1+nar+i)=col(i) - enddo - if (nar > maxnar) stop 'increase sparsity fraction(spfra)' - -! CALLING IRLS TO SOLVE THE PROBLEM - - leniw = 2*nar+1 - lenrw = nar - dv = 0 - atol = 1e-3 - btol = 1e-3 - conlim = 1200 - itnlim = 1000 - istop = 0 - anorm = 0.0 - acond = 0.0 - arnorm = 0.0 - xnorm = 0.0 - localSize = n/4 - - call LSMR(m, n, leniw, lenrw,iw,rw,cbst, damp,& - atol, btol, conlim, itnlim, localSize, nout,& - dv, istop, itn, anorm, acond, rnorm, arnorm, xnorm) - if(istop==3) print*,'istop = 3, large condition number' - - - if (domain == 0.and.normt==0) then - do iiter = 1, initer-1 - dtres=-cbst - call aprod(1,m,n,dv,dtres,leniw,lenrw,iw,rw) - do i=1,m - if(abs(dtres(i)).lt.tolr) then - wt(i)= 1.0/sqrt(abs(tolr)) - else - wt(i)=1.0/sqrt(abs(dtres(i))) - endif - enddo - do i=1,nar - rw(i)=rw(i)*wt(iw(i+1)) - enddo - do i=1,m - dtres(i)=cbst(i)*wt(i) - enddo - - dv = 0 - atol = 1e-3 - btol = 1e-3 - conlim = 1200 - itnlim = 1000 - istop = 0 - anorm = 0.0 - acond = 0.0 - arnorm = 0.0 - xnorm = 0.0 - - - call LSMR(m, n, leniw, lenrw,iw,rw,dtres, damp,& - atol, btol, conlim, itnlim, localSize, nout,& - dv, istop, itn, anorm, acond, rnorm, arnorm, xnorm) - if(istop==3) print*,'istop = 3, large condition number' - - do i=1,nar - rw(i)=rw(i)/wt(iw(i+1)) - enddo - - enddo ! finish inter interations for IRLS - endif - - - if(domain==0.and.normt/=0) then - do iiter = 1, initer-1 - do i=1,n - if (abs(dv(i)).lt.tolr) then - rw(nar_tmp+i)=1.0/sqrt(tolr)*weight - else - rw(nar_tmp+i)=sqrt(1.0/abs(dv(i)))*weight - endif - enddo - dv = 0 - atol = 1e-3 - btol = 1e-3 - conlim = 1200 - itnlim = 1000 - istop = 0 - anorm = 0.0 - acond = 0.0 - arnorm = 0.0 - xnorm = 0.0 - - call LSMR(m, n, leniw, lenrw,iw,rw,cbst, damp,& - atol, btol, conlim, itnlim, localSize, nout,& - dv, istop, itn, anorm, acond, rnorm, arnorm, xnorm) - if(istop==3) print*,'istop = 3, large condition number' - enddo - endif - - - - if (domain/=0)then - do iiter = 1,initer-1 - - dtres = 0 - call aprod(1,m,n,dv,dtres,leniw,lenrw,iw,rw) - do i = nar_tmp+1,nar - if(abs(dtres(iw(1+i))) 0 group velocity -c kmax - I4: number of periods (t) for dispersion calculation -c t - period vector (t(NP)) -c cg - output phase or group velocities (vector,cg(NP)) -c----- - real*4 thkm(NLAY),vpm(NLAY),vsm(NLAY),rhom(NLAY) - integer nlayer,iflsph,iwave,mode,igr,kmax - double precision twopi,one,onea - double precision cc,c1,clow,cm,dc,t1 - double precision t(NP),c(NP),cb(NP),cg(NP) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi - integer*4 iverb(2) - integer*4 llw - integer*4 nsph, ifunc, idispl, idispr, is, ie - real*4 sone0, ddc0, h0, sone, ddc, h - -c maximum number of layers in the model - mmax = nlayer -c is the model flat (nsph = 0) or sphere (nsph = 1) - nsph = iflsph - -c----- -c save current values - do 39 i=1,mmax - b(i) = vsm(i) - a(i) = vpm(i) - d(i) = thkm(i) - rho(i) = rhom(i) -c print *,d(i), b(i) - 39 continue - - if(iwave.eq.1)then - idispl = kmax - idispr = 0 - elseif(iwave.eq.2)then - idispl = 0 - idispr = kmax - endif - - iverb(1) = 0 - iverb(2) = 0 -c ---- constant value - sone0 = 1.500 -c ---- phase velocity increment for searching root - ddc0 = 0.005 -c ---- frequency increment (%) for calculating group vel. using g = dw/dk = dw/d(w/c) - h0 = 0.005 -c ---- period range is:ie for calculation of dispersion - -c----- -c check for water layer -c----- - llw=1 - if(b(1).le.0.0) llw=2 - twopi=2.d0*3.141592653589793d0 - one=1.0d-2 - if(nsph.eq.1) call sphere(0,0,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - JMN = 1 - betmx=-1.e20 - betmn=1.e20 -c----- -c find the extremal velocities to assist in starting search -c----- - do 20 i=1,mmax - if(b(i).gt.0.01 .and. b(i).lt.betmn)then - betmn = b(i) - jmn = i - jsol = 1 - elseif(b(i).le.0.01 .and. a(i).lt.betmn)then - betmn = a(i) - jmn = i - jsol = 0 - endif - if(b(i).gt.betmx) betmx=b(i) - 20 continue -cc WRITE(6,*)'betmn, betmx:',betmn, betmx -c if(idispl.gt.0)then -cc open(1,file='tmpsrfi.06',form='unformatted', -cc 1 access='sequential') -cc rewind 1 -c read(*,*) lovdispfile -c open(1, file = lovdispfile); -c endif -c if(idispr.gt.0)then -cc open(2,file='tmpsrfi.07',form='unformatted', -cc 1 access='sequential') -cc rewind 2 -c read(*,*) raydispfile -c open(2, file = raydispfile); -c endif - do 2000 ifunc=1,2 - if(ifunc.eq.1.and.idispl.le.0) go to 2000 - if(ifunc.eq.2.and.idispr.le.0) go to 2000 - if(nsph.eq.1) call sphere(ifunc,1,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - ddc = ddc0 - sone = sone0 - h = h0 -c read(*,*) kmax,mode,ddc,sone,igr,h -c write(*,*) kmax,mode,ddc,sone,igr,h -c read(*,*) (t(i),i=1,kmax) -c write(*,*) (t(i),i=1,kmax) -cc write(ifunc,*) mmax,nsph -cc write(ifunc,*) (btp(i),i=1,mmax) -cc write(ifunc,*) (dtp(i),i=1,mmax) -cc do 420 i=1,mmax -cc write(ifunc,*) d(i),a(i),b(i),rho(i) -cc 420 continue -c write(ifunc,*) kmax,igr,h - if(sone.lt. 0.01) sone=2.0 - onea=dble(sone) -c----- -c get starting value for phase velocity, -c which will correspond to the -c VP/VS ratio -c----- - if(jsol.eq.0)then -c----- -c water layer -c----- - cc1 = betmn - else -c----- -c solid layer solve halfspace period equation -c----- - call gtsolh(a(jmn),b(jmn),cc1) - endif -c----- -c back off a bit to get a starting value at a lower phase velocity -c----- - cc1=.95*cc1 - CC1=.90*CC1 - cc=dble(cc1) - dc=dble(ddc) - dc = dabs(dc) - c1=cc - cm=cc - do 450 i=1,kmax - cb(i)=0.0d0 - c(i)=0.0d0 - 450 continue - ift=999 - do 1800 iq=1,mode - is = 1 - ie = kmax -c read(*,*) is,ie -c write(*,*) 'is =', is, ', ie = ', ie - itst=ifunc - do 1600 k=is,ie - if(k.ge.ift) go to 1700 - t1=dble(t(k)) - if(igr.gt.0)then - t1a=t1/(1.+h) - t1b=t1/(1.-h) - t1=dble(t1a) - else - t1a=sngl(t1) - tlb=0.0 - endif -c----- -c get initial phase velocity estimate to begin search -c -c in the notation here, c() is an array of phase velocities -c c(k-1) is the velocity estimate of the present mode -c at the k-1 period, while c(k) is the phase velocity of the -c previous mode at the k period. Since there must be no mode -c crossing, we make use of these values. The only complexity -c is that the dispersion may be reversed. -c -c The subroutine getsol determines the zero crossing and refines -c the root. -c----- - if(k.eq.is .and. iq.eq.1)then - c1 = cc - clow = cc - ifirst = 1 - elseif(k.eq.is .and. iq.gt.1)then - c1 = c(is) + one*dc - clow = c1 - ifirst = 1 - elseif(k.gt.is .and. iq.gt.1)then - ifirst = 0 -c clow = c(k) + one*dc -c c1 = c(k-1) -onea*dc - clow = c(k) + one*dc - c1 = c(k-1) - if(c1 .lt. clow)c1 = clow - elseif(k.gt.is .and. iq.eq.1)then - ifirst = 0 - c1 = c(k-1) - onea*dc - clow = cm - endif -c----- -c bracket root and refine it -c----- - call getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) - if(iret.eq.-1)goto 1700 - c(k) = c1 -c----- -c for group velocities compute near above solution -c----- - if(igr.gt.0) then - t1=dble(t1b) - ifirst = 0 - clow = cb(k) + one*dc - c1 = c1 -onea*dc - call getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) -c----- -c test if root not found at slightly larger period -c----- - if(iret.eq.-1)then - c1 = c(k) - endif - cb(k)=c1 - else - c1 = 0.0d+00 - endif - cc0 = sngl(c(k)) - cc1 = sngl(c1) - if(igr.eq.0) then -c ----- output only phase velocity -c write(ifunc,*) itst,iq,t(k),cc0,0.0 - cg(k) = cc0 - else -c ----- calculate group velocity and output phase and group velocities - gvel = (1/t1a-1/t1b)/(1/(t1a*cc0)-1/(t1b*cc1)) - cg(k) = gvel -c write(ifunc,*) itst,iq,t(k),(cc0+cc1)/2,gvel -c ----- print *, itst,iq,t(k),t1a,t1b,cc0,cc1,gvel - endif - 1600 continue - go to 1800 - 1700 if(iq.gt.1) go to 1750 - if(iverb(ifunc).eq.0)then - iverb(ifunc) = 1 - write(LOT,*)'improper initial value in disper - no zero found' - write(*,*)'WARNING:improper initial value in disper - no zero found' - write(LOT,*)'in fundamental mode ' - write(LOT,*)'This may be due to low velocity zone ' - write(LOT,*)'causing reverse phase velocity dispersion, ' - write(LOT,*)'and mode jumping.' - write(LOT,*)'due to looking for Love waves in a halfspace' - write(LOT,*)'which is OK if there are Rayleigh data.' - write(LOT,*)'If reverse dispersion is the problem,' - write(LOT,*)'Get present model using OPTION 28, edit sobs.d,' - write(LOT,*)'Rerun with onel large than 2' - write(LOT,*)'which is the default ' -c----- -c if we have higher mode data and the model does not find that -c mode, just indicate (itst=0) that it has not been found, but -c fill out file with dummy results to maintain format - note -c eigenfunctions will not be found for these values. The subroutine -c 'amat' in 'surf' will worry about this in building up the -c input file for 'surfinv' -c----- - write(LOT,*)'ifunc = ',ifunc ,' (1=L, 2=R)' - write(LOT,*)'mode = ',iq-1 - write(LOT,*)'period= ',t(k), ' for k,is,ie=',k,is,ie - write(LOT,*)'cc,cm = ',cc,cm - write(LOT,*)'c1 = ',c1 - write(LOT,*)'d,a,b,rho (d(mmax)=control ignore)' - write(LOT,'(4f15.5)')(d(i),a(i),b(i),rho(i),i=1,mmax) - write(LOT,*)' c(i),i=1,k (NOTE may be part)' - write(LOT,*)(c(i),i=1,k) - endif -c if(k.gt.0)goto 1750 -c go to 2000 - 1750 ift=k - itst=0 - do 1770 i=k,ie - t1a=t(i) -c write(ifunc,*) itst,iq,t1a,0.0,0.0 - cg(i) = 0.0 - 1770 continue - 1800 continue -c close(ifunc,status='keep') - 2000 continue -c close(3,status='keep') - - end - - - - - - - subroutine gtsolh(a,b,c) -c----- -c starting solution -c----- - real*4 kappa, k2, gk2 - c = 0.95*b - do 100 i=1,5 - gamma = b/a - kappa = c/b - k2 = kappa**2 - gk2 = (gamma*kappa)**2 - fac1 = sqrt(1.0 - gk2) - fac2 = sqrt(1.0 - k2) - fr = (2.0 - k2)**2 - 4.0*fac1*fac2 - frp = -4.0*(2.0-k2) *kappa - 1 +4.0*fac2*gamma*gamma*kappa/fac1 - 2 +4.0*fac1*kappa/fac2 - frp = frp/b - c = c - fr/frp - 100 continue - return - end - - subroutine getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) -c----- -c subroutine to bracket dispersion curve -c and then refine it -c----- -c t1 - period -c c1 - initial guess on low side of mode -c clow - lowest possible value for present mode in a -c reversed direction search -c dc - phase velocity search increment -c cm - minimum possible solution -c betmx - maximum shear velocity -c iret - 1 = successful -c - -1= unsuccessful -c ifunc - 1 - Love -c - 2 - Rayleigh -c ifirst - 1 this is first period for a particular mode -c - 0 this is not the first period -c (this is to define period equation sign -c for mode jumping test) -c----- - parameter (NL=200) - real*8 wvno, omega, twopi - real*8 c1, c2, cn, cm, dc, t1, clow - real*8 dltar, del1, del2, del1st, plmn - save del1st - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - integer llw,mmax -c----- -c to avoid problems in mode jumping with reversed dispersion -c we note what the polarity of period equation is for phase -c velocities just beneath the zero crossing at the -c first period computed. -c----- -c bracket solution -c----- - twopi=2.d0*3.141592653589793d0 - omega=twopi/t1 - wvno=omega/c1 - del1 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - if(ifirst.eq.1)del1st = del1 - plmn = dsign(1.0d+00,del1st)*dsign(1.0d+00,del1) - if(ifirst.eq.1)then - idir = +1 - elseif(ifirst.ne.1 .and. plmn.ge.0.0d+00)then - idir = +1 - elseif(ifirst.ne.1 .and. plmn.lt.0.0d+00)then - idir = -1 - endif -c----- -c idir indicates the direction of the search for the -c true phase velocity from the initial estimate. -c Usually phase velocity increases with period and -c we always underestimate, so phase velocity should increase -c (idir = +1). For reversed dispersion, we should look -c downward from the present estimate. However, we never -c go below the floor of clow, when the direction is reversed -c----- - 1000 continue - if(idir.gt.0)then - c2 = c1 + dc - else - c2 = c1 - dc - endif - if(c2.le.clow)then - idir = +1 - c1 = clow - endif - if(c2.le.clow)goto 1000 - omega=twopi/t1 - wvno=omega/c2 - del2 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - if (dsign(1.0d+00,del1).ne.dsign(1.0d+00,del2)) then - go to 1300 - endif - c1=c2 - del1=del2 -c check that c1 is in region of solutions - if(c1.lt.cm) go to 1700 - if(c1.ge.(betmx+dc)) go to 1700 - go to 1000 -c----- -c root bracketed, refine it -c----- - 1300 call nevill(t1,c1,c2,del1,del2,ifunc,cn,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - c1 = cn - if(c1.gt.(betmx)) go to 1700 - iret = 1 - return - 1700 continue - iret = -1 - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - subroutine sphere(ifunc,iflag,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c----- -c Transform spherical earth to flat earth -c -c Schwab, F. A., and L. Knopoff (1972). Fast surface wave and free -c mode computations, in Methods in Computational Physics, -c Volume 11, -c Seismology: Surface Waves and Earth Oscillations, -c B. A. Bolt (ed), -c Academic Press, New York -c -c Love Wave Equations 44, 45 , 41 pp 112-113 -c Rayleigh Wave Equations 102, 108, 109 pp 142, 144 -c -c Revised 28 DEC 2007 to use mid-point, assume linear variation in -c slowness instead of using average velocity for the layer -c Use the Biswas (1972:PAGEOPH 96, 61-74, 1972) density mapping -c -c ifunc I*4 1 - Love Wave -c 2 - Rayleigh Wave -c iflag I*4 0 - Initialize -c 1 - Make model for Love or Rayleigh Wave -c----- - parameter(NL=200,NP=60) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - integer mmax,llw -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi - double precision z0,z1,r0,r1,dr,ar,tmp,twopi - save dhalf - ar=6370.0d0 - dr=0.0d0 - r0=ar - d(mmax)=1.0 - if(iflag.eq.0) then - do 5 i=1,mmax - dtp(i)=d(i) - rtp(i)=rho(i) - 5 continue - do 10 i=1,mmax - dr=dr+dble(d(i)) - r1=ar-dr - z0=ar*dlog(ar/r0) - z1=ar*dlog(ar/r1) - d(i)=z1-z0 -c----- -c use layer midpoint -c----- - TMP=(ar+ar)/(r0+r1) - a(i)=a(i)*tmp - b(i)=b(i)*tmp - btp(i)=tmp - r0=r1 - 10 continue - dhalf = d(mmax) - else - d(mmax) = dhalf - do 30 i=1,mmax - if(ifunc.eq.1)then - rho(i)=rtp(i)*btp(i)**(-5) - else if(ifunc.eq.2)then - rho(i)=rtp(i)*btp(i)**(-2.275) - endif - 30 continue - endif - d(mmax)=0.0 - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - subroutine nevill(t,c1,c2,del1,del2,ifunc,cc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c----- -c hybrid method for refining root once it has been bracketted -c between c1 and c2. interval halving is used where other schemes -c would be inefficient. once suitable region is found neville s -c iteration method is used to find root. -c the procedure alternates between the interval halving and neville -c techniques using whichever is most efficient -c----- -c the control integer nev means the following: -c -c nev = 0 force interval halving -c nev = 1 permit neville iteration if conditions are proper -c nev = 2 neville iteration is being used -c----- - parameter (NL=200,NP=60) - implicit double precision (a-h,o-z) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - dimension x(20),y(20) - integer llw,mmax -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi -c----- -c initial guess -c----- - omega = twopi/t - call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - nev = 1 - nctrl=1 - 100 continue - nctrl=nctrl+1 - if(nctrl.ge.100) go to 1000 -c----- -c make sure new estimate is inside the previous values. If not -c perform interval halving -c----- - if(c3 .lt. dmin1(c1,c2) .or. c3. gt.dmax1(c1,c2))then - nev = 0 - call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - endif - s13 = del1 - del3 - s32 = del3 - del2 -c----- -c define new bounds according to the sign of the period equation -c----- - if(dsign(1.d+00,del3)*dsign(1.d+00,del1) .lt.0.0d+00)then - c2 = c3 - del2 = del3 - else - c1 = c3 - del1 = del3 - endif -c----- -c check for convergence. A relative error criteria is used -c----- - if(dabs(c1-c2).le.1.d-6*c1) go to 1000 -c----- -c if the slopes are not the same between c1, c3 and c3 -c do not use neville iteration -c----- - if(dsign (1.0d+00,s13).ne.dsign (1.0d+00,s32)) nev = 0 -c----- -c if the period equation differs by more than a factor of 10 -c use interval halving to avoid poor behavior of polynomial fit -c----- - ss1=dabs(del1) - s1=0.01*ss1 - ss2=dabs(del2) - s2=0.01*ss2 - if(s1.gt.ss2.or.s2.gt.ss1 .or. nev.eq.0) then - call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - nev = 1 - m = 1 - else - if(nev.eq.2)then - x(m+1) = c3 - y(m+1) = del3 - else - x(1) = c1 - y(1) = del1 - x(2) = c2 - y(2) = del2 - m = 1 - endif -c----- -c perform Neville iteration. Note instead of generating y(x) -c we interchange the x and y of formula to solve for x(y) when -c y = 0 -c----- - do 900 kk = 1,m - j = m-kk+1 - denom = y(m+1) - y(j) - if(dabs(denom).lt.1.0d-10*abs(y(m+1)))goto 950 - x(j)=(-y(j)*x(j+1)+y(m+1)*x(j))/denom - 900 continue - c3 = x(1) - wvno = omega/c3 - del3 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - nev = 2 - m = m + 1 - if(m.gt.10)m = 10 - goto 951 - 950 continue - call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - nev = 1 - m = 1 - 951 continue - endif - goto 100 - 1000 continue - cc = c3 - return - end - - subroutine half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, - & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - implicit double precision (a-h,o-z) - parameter(NL=200) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - c3 = 0.5*(c1 + c2) - wvno=omega/c3 - del3 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - function dltar(wvno,omega,kk,d,a,b,rho,rtp,dtp,btp,mmax,llw,twop) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) -c control the way to P-SV or SH. -c - implicit double precision (a-h,o-z) - parameter(NL=200) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) -c - if(kk.eq.1)then -c love wave period equation - dltar = dltar1(wvno,omega,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) - elseif(kk.eq.2)then -c rayleigh wave period equation - dltar = dltar4(wvno,omega,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - endif - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - function dltar1(wvno,omega,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c find SH dispersion values. -c - parameter (NL=200,NP=60) - implicit double precision (a-h,o-z) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) - integer llw,mmax -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi -c -c Haskell-Thompson love wave formulation from halfspace -c to surface. -c - beta1=dble(b(mmax)) - rho1=dble(rho(mmax)) - xkb=omega/beta1 - wvnop=wvno+xkb - wvnom=dabs(wvno-xkb) - rb=dsqrt(wvnop*wvnom) - e1=rho1*rb - e2=1.d+00/(beta1*beta1) - mmm1 = mmax - 1 - do 600 m=mmm1,llw,-1 - beta1=dble(b(m)) - rho1=dble(rho(m)) - xmu=rho1*beta1*beta1 - xkb=omega/beta1 - wvnop=wvno+xkb - wvnom=dabs(wvno-xkb) - rb=dsqrt(wvnop*wvnom) - q = dble(d(m))*rb - if(wvno.lt.xkb)then - sinq = dsin(q) - y = sinq/rb - z = -rb*sinq - cosq = dcos(q) - elseif(wvno.eq.xkb)then - cosq=1.0d+00 - y=dble(d(m)) - z=0.0d+00 - else - fac = 0.0d+00 - if(q.lt.16)fac = dexp(-2.0d+0*q) - cosq = ( 1.0d+00 + fac ) * 0.5d+00 - sinq = ( 1.0d+00 - fac ) * 0.5d+00 - y = sinq/rb - z = rb*sinq - endif - e10=e1*cosq+e2*xmu*z - e20=e1*y/xmu+e2*cosq - xnor=dabs(e10) - ynor=dabs(e20) - if(ynor.gt.xnor) xnor=ynor - if(xnor.lt.1.d-40) xnor=1.0d+00 - e1=e10/xnor - e2=e20/xnor - 600 continue - dltar1=e1 - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - function dltar4(wvno,omga,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) -c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) -c find P-SV dispersion values. -c - parameter (NL=200,NP=60) - implicit double precision (a-h,o-z) - dimension e(5),ee(5),ca(5,5) - real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) -c common/modl/ d,a,b,rho,rtp,dtp,btp -c common/para/ mmax,llw,twopi -c common/ovrflw/ a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz -c - omega=omga - if(omega.lt.1.0d-4) omega=1.0d-4 - wvno2=wvno*wvno - xka=omega/dble(a(mmax)) - xkb=omega/dble(b(mmax)) - wvnop=wvno+xka - wvnom=dabs(wvno-xka) - ra=dsqrt(wvnop*wvnom) - wvnop=wvno+xkb - wvnom=dabs(wvno-xkb) - rb=dsqrt(wvnop*wvnom) - t = dble(b(mmax))/omega -c----- -c E matrix for the bottom half-space. -c----- - gammk = 2.d+00*t*t - gam = gammk*wvno2 - gamm1 = gam - 1.d+00 - rho1=dble(rho(mmax)) - e(1)=rho1*rho1*(gamm1*gamm1-gam*gammk*ra*rb) - e(2)=-rho1*ra - e(3)=rho1*(gamm1-gammk*ra*rb) - e(4)=rho1*rb - e(5)=wvno2-ra*rb -c----- -c matrix multiplication from bottom layer upward -c----- - mmm1 = mmax-1 - do 500 m = mmm1,llw,-1 - xka = omega/dble(a(m)) - xkb = omega/dble(b(m)) - t = dble(b(m))/omega - gammk = 2.d+00*t*t - gam = gammk*wvno2 - wvnop=wvno+xka - wvnom=dabs(wvno-xka) - ra=dsqrt(wvnop*wvnom) - wvnop=wvno+xkb - wvnom=dabs(wvno-xkb) - rb=dsqrt(wvnop*wvnom) - dpth=dble(d(m)) - rho1=dble(rho(m)) - p=ra*dpth - q=rb*dpth - beta=dble(b(m)) -c----- -c evaluate cosP, cosQ,.... in var. -c evaluate Dunkin's matrix in dnka. -c----- - call var(p,q,ra,rb,wvno,xka,xkb,dpth,w,cosp,exa, - & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - call dnka(ca,wvno2,gam,gammk,rho1, - & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - do 200 i=1,5 - cr=0.0d+00 - do 100 j=1,5 - cr=cr+e(j)*ca(j,i) - 100 continue - ee(i)=cr - 200 continue - call normc(ee,exa) - do 300 i = 1,5 - e(i)=ee(i) - 300 continue - 500 continue - if(llw.ne.1) then -c----- -c include water layer. -c----- - xka = omega/dble(a(1)) - wvnop=wvno+xka - wvnom=dabs(wvno-xka) - ra=dsqrt(wvnop*wvnom) - dpth=dble(d(1)) - rho1=dble(rho(1)) - p = ra*dpth - beta = dble(b(1)) - znul = 1.0d-05 - call var(p,znul,ra,znul,wvno,xka,znul,dpth,w,cosp,exa, - & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) - w0=-rho1*w - dltar4 = cosp*e(1) + w0*e(2) - else - dltar4 = e(1) - endif - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine var(p,q,ra,rb,wvno,xka,xkb,dpth,w,cosp,exa,a0,cpcq, - & cpy,cpz,cqw,cqx,xy,xz,wy,wz) -c----- -c find variables cosP, cosQ, sinP, sinQ, etc. -c as well as cross products required for compound matrix -c----- -c To handle the hyperbolic functions correctly for large -c arguments, we use an extended precision procedure, -c keeping in mind that the maximum precision in double -c precision is on the order of 16 decimal places. -c -c So cosp = 0.5 ( exp(+p) + exp(-p)) -c = exp(p) * 0.5 * ( 1.0 + exp(-2p) ) -c becomes -c cosp = 0.5 * (1.0 + exp(-2p) ) with an exponent p -c In performing matrix multiplication, we multiply the modified -c cosp terms and add the exponents. At the last step -c when it is necessary to obtain a true amplitude, -c we then form exp(p). For normalized amplitudes at any depth, -c we carry an exponent for the numerator and the denominator, and -c scale the resulting ratio by exp(NUMexp - DENexp) -c -c The propagator matrices have three basic terms -c -c HSKA cosp cosq -c DUNKIN cosp*cosq 1.0 -c -c When the extended floating point is used, we use the -c largest exponent for each, which is the following: -c -c Let pex = p exponent > 0 for evanescent waves = 0 otherwise -c Let sex = s exponent > 0 for evanescent waves = 0 otherwise -c Let exa = pex + sex -c -c Then the modified matrix elements are as follow: -c -c Haskell: cosp -> 0.5 ( 1 + exp(-2p) ) exponent = pex -c cosq -> 0.5 ( 1 + exp(-2q) ) * exp(q-p) -c exponent = pex -c (this is because we are normalizing all elements in the -c Haskell matrix ) -c Compound: -c cosp * cosq -> normalized cosp * cosq exponent = pex + qex -c 1.0 -> exp(-exa) -c----- - implicit double precision (a-h,o-z) -c common/ovrflw/ a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz - exa=0.0d+00 - a0=1.0d+00 -c----- -c examine P-wave eigenfunctions -c checking whether c> vp c=vp or c < vp -c----- - pex = 0.0d+00 - sex = 0.0d+00 - if(wvno.lt.xka)then - sinp = dsin(p) - w=sinp/ra - x=-ra*sinp - cosp=dcos(p) - elseif(wvno.eq.xka)then - cosp = 1.0d+00 - w = dpth - x = 0.0d+00 - elseif(wvno.gt.xka)then - pex = p - fac = 0.0d+00 - if(p.lt.16)fac = dexp(-2.0d+00*p) - cosp = ( 1.0d+00 + fac) * 0.5d+00 - sinp = ( 1.0d+00 - fac) * 0.5d+00 - w=sinp/ra - x=ra*sinp - endif -c----- -c examine S-wave eigenfunctions -c checking whether c > vs, c = vs, c < vs -c----- - if(wvno.lt.xkb)then - sinq=dsin(q) - y=sinq/rb - z=-rb*sinq - cosq=dcos(q) - elseif(wvno.eq.xkb)then - cosq=1.0d+00 - y=dpth - z=0.0d+00 - elseif(wvno.gt.xkb)then - sex = q - fac = 0.0d+00 - if(q.lt.16)fac = dexp(-2.0d+0*q) - cosq = ( 1.0d+00 + fac ) * 0.5d+00 - sinq = ( 1.0d+00 - fac ) * 0.5d+00 - y = sinq/rb - z = rb*sinq - endif -c----- -c form eigenfunction products for use with compound matrices -c----- - exa = pex + sex - a0=0.0d+00 - if(exa.lt.60.0d+00) a0=dexp(-exa) - cpcq=cosp*cosq - cpy=cosp*y - cpz=cosp*z - cqw=cosq*w - cqx=cosq*x - xy=x*y - xz=x*z - wy=w*y - wz=w*z - qmp = sex - pex - fac = 0.0d+00 - if(qmp.gt.-40.0d+00)fac = dexp(qmp) - cosq = cosq*fac - y=fac*y - z=fac*z - return - end -c -c -c - subroutine normc(ee,ex) -c This routine is an important step to control over- or -c underflow. -c The Haskell or Dunkin vectors are normalized before -c the layer matrix stacking. -c Note that some precision will be lost during normalization. -c - implicit double precision (a-h,o-z) - dimension ee(5) - ex = 0.0d+00 - t1 = 0.0d+00 - do 10 i = 1,5 - if(dabs(ee(i)).gt.t1) t1 = dabs(ee(i)) - 10 continue - if(t1.lt.1.d-40) t1=1.d+00 - do 20 i =1,5 - t2=ee(i) - t2=t2/t1 - ee(i)=t2 - 20 continue -c----- -c store the normalization factor in exponential form. -c----- - ex=dlog(t1) - return - end -c -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c - subroutine dnka(ca,wvno2,gam,gammk,rho, - & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) -c Dunkin's matrix. -c - implicit double precision (a-h,o-z) - dimension ca(5,5) -c common/ ovrflw / a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz - data one,two/1.d+00,2.d+00/ - gamm1 = gam-one - twgm1=gam+gamm1 - gmgmk=gam*gammk - gmgm1=gam*gamm1 - gm1sq=gamm1*gamm1 - rho2=rho*rho - a0pq=a0-cpcq - ca(1,1)=cpcq-two*gmgm1*a0pq-gmgmk*xz-wvno2*gm1sq*wy - ca(1,2)=(wvno2*cpy-cqx)/rho - ca(1,3)=-(twgm1*a0pq+gammk*xz+wvno2*gamm1*wy)/rho - ca(1,4)=(cpz-wvno2*cqw)/rho - ca(1,5)=-(two*wvno2*a0pq+xz+wvno2*wvno2*wy)/rho2 - ca(2,1)=(gmgmk*cpz-gm1sq*cqw)*rho - ca(2,2)=cpcq - ca(2,3)=gammk*cpz-gamm1*cqw - ca(2,4)=-wz - ca(2,5)=ca(1,4) - ca(4,1)=(gm1sq*cpy-gmgmk*cqx)*rho - ca(4,2)=-xy - ca(4,3)=gamm1*cpy-gammk*cqx - ca(4,4)=ca(2,2) - ca(4,5)=ca(1,2) - ca(5,1)=-(two*gmgmk*gm1sq*a0pq+gmgmk*gmgmk*xz+ - * gm1sq*gm1sq*wy)*rho2 - ca(5,2)=ca(4,1) - ca(5,3)=-(gammk*gamm1*twgm1*a0pq+gam*gammk*gammk*xz+ - * gamm1*gm1sq*wy)*rho - ca(5,4)=ca(2,1) - ca(5,5)=ca(1,1) - t=-two*wvno2 - ca(3,1)=t*ca(5,3) - ca(3,2)=t*ca(4,3) - ca(3,3)=a0+two*(cpcq-ca(1,1)) - ca(3,4)=t*ca(2,3) - ca(3,5)=t*ca(1,3) - return - end diff --git a/srcsparsity/waveletD8.f90 b/srcsparsity/waveletD8.f90 deleted file mode 100644 index ea83395..0000000 --- a/srcsparsity/waveletD8.f90 +++ /dev/null @@ -1,113 +0,0 @@ - subroutine transformD8(a,n) - implicit none - integer n - real a(n) - - integer i,j - integer half - real tmp(n) - real*8 h(8),g(8) - data h/-0.010597401784997278,& - 0.032883011666982945,& - 0.030841381835986965,& - -0.18703481171888114,& - -0.02798376941698385,& - 0.6308807679295904,& - 0.7148465705525415,& - 0.23037781330885523/ - - - data g/-0.23037781330885523,& - 0.7148465705525415,& - -0.6308807679295904,& - -0.02798376941698385,& - 0.18703481171888114,& - 0.030841381835986965,& - -0.032883011666982945,& - -0.010597401784997278/ - - half=n/2 - i=1 - tmp=0 - do j=1,n-7,2 - tmp(i)=a(j)*h(1)+a(j+1)*h(2)+a(j+2)*h(3)+a(j+3)*h(4)+a(j+4)*h(5) & - +a(j+5)*h(6)+a(j+6)*h(7)+a(j+7)*h(8) - tmp(i+half)=a(j)*g(1)+a(j+1)*g(2)+a(j+2)*g(3)+a(j+3)*g(4) & - +a(j+4)*g(5)+a(j+5)*g(6)+a(j+6)*g(7)+a(j+7)*g(8) - i=i+1 - enddo - - tmp(i)=a(n-5)*h(1)+a(n-4)*h(2)+a(n-3)*h(3)+a(n-2)*h(4)+a(n-1)*h(5) & - +a(n)*h(6)+a(1)*h(7)+a(2)*h(8) - tmp(i+half)=a(n-5)*g(1)+a(n-4)*g(2)+a(n-3)*g(3)+a(n-2)*g(4) & - +a(n-1)*g(5) +a(n)*g(6)+a(1)*g(7)+a(2)*g(8) - tmp(i+1)=a(n-3)*h(1)+a(n-2)*h(2)+a(n-1)*h(3)+a(n)*h(4)+a(1)*h(5) & - +a(2)*h(6)+a(3)*h(7)+a(4)*h(8) - tmp(i+1+half)=a(n-3)*g(1)+a(n-2)*g(2)+a(n-1)*g(3)+a(n)*g(4) & - +a(1)*g(5)+a(2)*g(6)+a(3)*g(7)+a(4)*g(8) - tmp(i+2)=a(n-1)*h(1)+a(n)*h(2)+a(1)*h(3)+a(2)*h(4)+a(3)*h(5) & - +a(4)*h(6)+a(5)*h(7)+a(6)*h(8) - tmp(i+2+half)=a(n-1)*g(1)+a(n)*g(2)+a(1)*g(3)+a(2)*g(4)+a(3)*g(5) & - +a(4)*g(6)+a(5)*g(7)+a(6)*g(8) - - do i=1,n - a(i)=tmp(i) - enddo - - end subroutine - - subroutine invTransformD8(a,n) - implicit none - integer n - real a(n) - - real tmp(n) - real*8 Ih(8),Ig(8) - integer half - integer i,j - data Ih/0.23037781330885523,& - 0.7148465705525415,& - 0.6308807679295904,& - -0.02798376941698385,& - -0.18703481171888114,& - 0.030841381835986965,& - 0.032883011666982945,& - -0.010597401784997278/ - data Ig/-0.010597401784997278,& - -0.032883011666982945,& - 0.030841381835986965,& - 0.18703481171888114,& - -0.02798376941698385,& - -0.6308807679295904,& - 0.7148465705525415,& - -0.23037781330885523/ - - half=n/2 - tmp(2)=a(half-2)*Ih(1)+a(n-2)*Ig(1)+a(half-1)*Ih(3)+a(n-1)*Ig(3) & - +a(half)*Ih(5)+a(n)*Ig(5)+a(1)*Ih(7)+a(half+1)*Ig(7) - tmp(1)=a(half-2)*Ih(2)+a(n-2)*Ig(2)+a(half-1)*Ih(4)+a(n-1)*Ig(4) & - +a(half)*Ih(6)+a(n)*Ig(6)+a(1)*Ih(8)+a(half+1)*Ig(8) - tmp(4)=a(half-1)*Ih(1)+a(n-1)*Ig(1)+a(half)*Ih(3)+a(n)*Ig(3) & - +a(1)*Ih(5)+a(half+1)*Ig(5)+a(2)*Ih(7)+a(half+2)*Ig(7) - tmp(3)=a(half-1)*Ih(2)+a(n-1)*Ig(2)+a(half)*Ih(4)+a(n)*Ig(4) & - +a(1)*Ih(6)+a(half+1)*Ig(6)+a(2)*Ih(8)+a(half+2)*Ig(8) - tmp(6)=a(half)*Ih(1)+a(n)*Ig(1)+a(1)*Ih(3)+a(half+1)*Ig(3) & - +a(2)*Ih(5)+a(half+2)*Ig(5)+a(3)*Ih(7)+a(half+3)*Ig(7) - tmp(5)=a(half)*Ih(2)+a(n)*Ig(2)+a(1)*Ih(4)+a(half+1)*Ig(4) & - +a(2)*Ih(6)+a(half+2)*Ig(6)+a(3)*Ih(8)+a(half+3)*Ig(8) - - j=6 - do i=1,half-3 - j=j+1 - tmp(j)=a(i)*Ih(2)+a(i+half)*Ig(2)+a(i+1)*Ih(4)+a(i+1+half)*Ig(4) & - +a(i+2)*Ih(6)+a(i+2+half)*Ig(6)+a(i+3)*Ih(8)+a(i+3+half)*Ig(8) - j=j+1 - tmp(j)=a(i)*Ih(1)+a(i+half)*Ig(1)+a(i+1)*Ih(3)+a(i+1+half)*Ig(3) & - +a(i+2)*Ih(5)+a(i+2+half)*Ig(5)+a(i+3)*Ih(7)+a(i+3+half)*Ig(7) - enddo - - do i=1,n - a(i)=tmp(i) - enddo - - end subroutine diff --git a/srcsparsity/wavelettrans3domp.f90 b/srcsparsity/wavelettrans3domp.f90 deleted file mode 100644 index 6c3d6df..0000000 --- a/srcsparsity/wavelettrans3domp.f90 +++ /dev/null @@ -1,90 +0,0 @@ - subroutine wavelettrans(nx,ny,nz,row,maxlevel,maxleveld,HorizonType,VerticalType) - use omp_lib - implicit none - integer nx,ny,nz,maxlevel,maxleveld - real row(*) - - integer j,k - real fxs(nx),fzs(nz),fys(ny) - integer HorizonType,VerticalType -! if(PorS == 1 .or. PorS == 3) then -!!$omp parallel & -!!$omp default(private) & -!!$omp shared(nz,ny,nx,maxlevel,row,HorizonType) -!!$omp do -! do k=1,nz -! do j=1,ny -! fxp=row(1+(j-1)*nx+(k-1)*nx*ny:nx+(j-1)*nx+(k-1)*nx*ny) -! call forwardtrans(fxp,nx,maxlevel,HorizonType) -! row(1+(j-1)*nx+(k-1)*nx*ny:nx+(j-1)*nx+(k-1)*nx*ny)=fxp -! enddo -! enddo -!!$omp end do -!!$omp end parallel -!!$omp parallel & -!!$omp default(private) & -!!$omp shared(nz,ny,nx,maxlevel,row,HorizonType) -!!$omp do -! do k=1,nz -! do j=1,nx -! fyp=row(j+(k-1)*nx*ny:j+(ny-1)*nx+(k-1)*nx*ny:nx) -! call forwardtrans(fyp,ny,maxlevel,HorizonType) -! row(j+(k-1)*nx*ny:j+(ny-1)*nx+(k-1)*nx*ny:nx)=fyp -! enddo -! enddo -!!$omp end do -!!$omp end parallel -!!$omp parallel & -!!$omp default(private) & -!!$omp shared(nz,ny,nx,maxleveld,row,VerticalType) -!!$omp do -! do k=1,ny -! do j=1,nx -! fzp=row(j+(k-1)*nx:j+(k-1)*nx+(nz-1)*nx*ny:nx*ny) -! call forwardtrans(fzp,nz,maxleveld,VerticalType) -! row(j+(k-1)*nx:j+(k-1)*nx+(nz-1)*nx*ny:nx*ny)=fzp -! enddo -! enddo -!!$omp end do -!!$omp end parallel -! endif -!$omp parallel & -!$omp default(private) & -!$omp shared(nz,ny,nx,maxlevel,row,HorizonType) -!$omp do - do k=1,nz - do j=1,ny - fxs=row(1+(j-1)*nx+(k-1)*nx*ny:nx+(j-1)*nx+(k-1)*nx*ny) - call forwardtrans(fxs,nx,maxlevel,HorizonType) - row(1+(j-1)*nx+(k-1)*nx*ny:nx+(j-1)*nx+(k-1)*nx*ny)=fxs - enddo - enddo -!$omp end do -!$omp end parallel -!$omp parallel & -!$omp default(private) & -!$omp shared(nz,ny,nx,maxlevel,row,HorizonType) -!$omp do - do k=1,nz - do j=1,nx - fys=row(j+(k-1)*nx*ny:j+(ny-1)*nx+(k-1)*nx*ny:nx) - call forwardtrans(fys,ny,maxlevel,HorizonType) - row(j+(k-1)*nx*ny:j+(ny-1)*nx+(k-1)*nx*ny:nx)=fys - enddo - enddo -!$omp end do -!$omp end parallel -!$omp parallel & -!$omp default(private) & -!$omp shared(nz,ny,nx,maxleveld,row,VerticalType) -!$omp do - do k=1,ny - do j=1,nx - fzs=row(j+(k-1)*nx:j+(k-1)*nx+(nz-1)*nx*ny:nx*ny) - call forwardtrans(fzs,nz,maxleveld,VerticalType) - row(j+(k-1)*nx:j+(k-1)*nx+(nz-1)*nx*ny:nx*ny)=fzs - enddo - enddo -!$omp end do -!$omp end parallel - end subroutine