[cig-commits] r17049 - in seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process: . asc2sac
liuqy at geodynamics.org
liuqy at geodynamics.org
Fri Jul 16 15:19:51 PDT 2010
Author: liuqy
Date: 2010-07-16 15:19:51 -0700 (Fri, 16 Jul 2010)
New Revision: 17049
Added:
seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/
seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/asc2sac.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/ascfile.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/compile
Log:
add seismic processing utility asc2sac, which has been modified to use only in-house subroutines and sac libraries.
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/asc2sac.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/asc2sac.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/asc2sac.f90 2010-07-16 22:19:51 UTC (rev 17049)
@@ -0,0 +1,23 @@
+program asc2sac
+
+ implicit none
+
+ integer, parameter :: NDATAMAX = 40000
+ integer :: npts, nl, nerr
+ character(len=250) :: cnl, ascfile, sacfile
+ real b, dt, data(NDATAMAX)
+
+ call getarg(1,ascfile)
+ call getarg(2,cnl)
+ call getarg(3,sacfile)
+ if (trim(ascfile) == '' .or. trim(cnl) == '' .or. trim(sacfile) == '') &
+ stop 'Usage: asc2sac ascfile npts sacfile'
+ read(cnl,*) nl
+
+ call rasc(ascfile,data,npts,b,dt,NDATAMAX,nerr)
+ if (npts > NDATAMAX .or. npts /= nl) stop 'Check npts'
+
+ call wsac1(sacfile,data,npts,b,dt,nerr)
+
+
+end program asc2sac
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/ascfile.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/ascfile.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/ascfile.f90 2010-07-16 22:19:51 UTC (rev 17049)
@@ -0,0 +1,66 @@
+!------------------------------------------------
+
+subroutine rasc(ascfile,dat,npts,b,dt,nmax,nerr)
+
+ implicit none
+ character(len=*) ascfile
+ real dat(1), b, dt
+ integer npts, nmax, nerr
+
+ real tv
+ integer nline, ios, IOUNIT
+
+ IOUNIT=99
+
+ open(IOUNIT,file=trim(ascfile),status='old',iostat=ios)
+ if (ios /= 0) then
+ print 'Error opening '//trim(ascfile); nerr=1
+ return
+ endif
+
+ nline=0
+ do while(ios == 0)
+ read(IOUNIT,*,iostat=ios) tv,dat(nline+1)
+ if (ios == 0) nline=nline+1
+ if (nline==1) then
+ b=tv
+ else if (nline == 2) then
+ dt=tv-b
+ endif
+ enddo
+
+ if (nline > nmax) then
+ print *, 'npts exceeding nmax '; nerr=2
+ return
+ endif
+
+ npts=nline
+ nerr=0
+ close(IOUNIT)
+
+end subroutine rasc
+
+subroutine wasc(ascfile,dat,npts,b,dt,nerr)
+
+ implicit none
+
+ character(len=*) :: ascfile
+ real :: dat(1), b, dt
+ integer :: npts, nerr, i, ios, IOUNIT
+
+ IOUNIT=99
+ open(IOUNIT,file=trim(ascfile),status='unknown',iostat=ios)
+ if (ios /= 0) then
+ print 'Error opening '//trim(ascfile)//' for writing'
+ nerr = 1; return
+ endif
+ do i = 1, npts
+ write(IOUNIT,'(2g15.7)') b+(i-1)*dt, dat(i)
+ enddo
+ close(IOUNIT)
+
+ nerr=0
+
+end subroutine wasc
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/compile
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/compile (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/compile 2010-07-16 22:19:51 UTC (rev 17049)
@@ -0,0 +1,5 @@
+#!/bin/bash
+
+SACLIB='/opt/sac-101.0/lib/libsacio.a'
+
+gfortran -o asc2sac asc2sac.f90 ascfile.f90 $SACLIB
Property changes on: seismo/3D/SPECFEM3D_GLOBE/trunk/UTILS/seis_process/asc2sac/compile
___________________________________________________________________
Name: svn:executable
+ *
More information about the CIG-COMMITS
mailing list