Commit eee694d2 authored by thomas.forbriger's avatar thomas.forbriger Committed by thomas.forbriger
Browse files

proceeding with new functions

This is a legacy commit from before 2015-03-01.
It may be incomplete as well as inconsistent.
See COPYING.legacy and README.history for details.


SVN Path:     http://gpitrsvn.gpi.uni-karlsruhe.de/repos/TFSoftware/branches/su1
SVN Revision: 3658
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent e65e0c21
/*! \file fapid_sff_ropen.cc
* \brief simply open file (implementation)
*
* ----------------------------------------------------------------------------
*
* $Id$
* \author Thomas Forbriger
* \date 02/01/2011
*
* simply open file (implementation)
*
* Copyright (c) 2011 by Thomas Forbriger (BFO Schiltach)
*
* ----
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
* ----
*
*
* REVISIONS and CHANGES
* - 02/01/2011 V1.0 Thomas Forbriger
*
* ============================================================================
*/
#define TF_FAPID_SFF_ROPEN_CC_VERSION \
"TF_FAPID_SFF_ROPEN_CC V1.0 "
#define TF_FAPID_SFF_ROPEN_CC_CVSID \
"$Id$"
#include <fapidxx/fapidsff.h>
#include <fapidxx/fileunit.h>
#include <fapidxx/helper.h>
#include <sffxx.h>
using namespace fapidxx;
/*! \brief Open SFF file
*
* \ingroup implemented_functions
*
* Description from stuff.f:
* \code
c----------------------------------------------------------------------
subroutine sff_ROpen(lu, filename,
& version, timestamp, code, ierr)
c
c Open file for reading. Read STAT line.
c
c input:
c lu logical file unit
c filename name of file
c ouput:
c version version of writing library
c timestamp time and date file was written
c code indicates optional blocks
c ierr error status (ok: ierr=0)
c
integer lu, ierr
real version
character timestamp*(*), code *(*)
character filename*(*)
c----------------------------------------------------------------------
* \endcode
*/
int sff_ropen__(integer *lu, char *filename, real *version, char *timestamp,
char *code, integer *ierr, ftnlen filename_len,
ftnlen timestamp_len, ftnlen code_len)
{
int retval=0;
*ierr=0;
try {
datrw::ianystream &is=
istreammanager.open(static_cast<int>(*lu),
stringfromfstring(filename, filename_len));
std::string ocode("");
if (is.hasfree()) { ocode.append("F"); }
if (is.hassrce()) { ocode.append("S"); }
// set output
fillfstring(ocode, code, code_len);
// timestamp and version got lost
sff::STAT stat;
fillfstring(stat.timestamp, timestamp, timestamp_len);
*version=static_cast<real>(sff::STAT::libversion);
}
catch(...) {
*ierr=1;
}
return retval;
} // int sff_ropen__
/* ----- END OF fapid_sff_ropen.cc ----- */
......@@ -93,12 +93,10 @@ int sff_ropens__(integer *lu, char *filename, real *version, char *timestamp,
istreammanager.open(static_cast<int>(*lu),
stringfromfstring(filename, filename_len));
sff::SRCE srce;
std::string ocode;
if (is.hassrce())
{
is >> srce;
ocode="S";
}
std::string ocode("");
if (is.hasfree()) { ocode.append("F"); }
if (is.hassrce()) { ocode.append("S"); }
if (is.hassrce()) { is >> srce; }
// set output
std::string srceline=srce.line();
fillfstring(ocode, code, code_len);
......
/*! \file fapid_sff_rtrace.cc
* \brief simply read one trace (implementation)
*
* ----------------------------------------------------------------------------
*
* $Id$
* \author Thomas Forbriger
* \date 02/01/2011
*
* simply read one trace (implementation)
*
* Copyright (c) 2011 by Thomas Forbriger (BFO Schiltach)
*
* ----
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
* ----
*
*
* REVISIONS and CHANGES
* - 02/01/2011 V1.0 Thomas Forbriger
*
* ============================================================================
*/
#define TF_FAPID_SFF_RTRACE_CC_VERSION \
"TF_FAPID_SFF_RTRACE_CC V1.0 "
#define TF_FAPID_SFF_RTRACE_CC_CVSID \
"$Id$"
#include <fapidxx/fapidsff.h>
#include <fapidxx/fileunit.h>
#include <fapidxx/helper.h>
#include <fapidxx/error.h>
using namespace fapidxx;
/*! \brief Read one trace of data
*
* \ingroup implemented_functions
*
* Description from stuff.f:
* \code
c----------------------------------------------------------------------
subroutine sff_RTrace(lu, tanf, dt,
& wid2line, nsamp, fdata, idata, code, last, ierr)
c
c Read one data block starting with DAST line.
c The File will be closed after writing the last trace.
c
c input
c lu logical file unit
c nsamp array dimension of idata and fdata
c ouput:
c ierr error status (ok: ierr=0)
c code code indicating optional blocks
c wid2line valid WID2 line
c tanf time of first sample from midnight
c dt sampling interval in seconds
c nsamp number of samples
c fdata data array
c last is true if read trace is the last one in this file
c
c workspace:
c idata data will be first read to idata and then converted
c to fdata using sff_i2f (both array may be in same memory
c space - see comments on sff_f2i)
c
integer lu, nsamp, idata(nsamp)
real fdata(nsamp), dt, tanf
logical last
character wid2line*132, code*(*)
c----------------------------------------------------------------------
* \endcode
*/
int sff_rtrace__(integer *lu, real *tanf, real *dt, char *wid2line,
integer *nsamp, real *fdata, integer *idata, char *code,
logical *last, integer *ierr,
ftnlen wid2line_len, ftnlen code_len)
{
int retval=0;
*ierr=0;
try {
datrw::ianystream &is=istreammanager(static_cast<int>(*lu));
sff::WID2 wid2;
datrw::Tfseries iseries;
is >> iseries;
FAPIDXX_fuassert((static_cast<int>(iseries.size())<=(*nsamp)), *lu,
"sff_rtracei__: too many samples");
int nsamples=iseries.size();
aff::LinearShape shape(0, nsamples-1, 0);
datrw::Tfseries series(shape, aff::SharedHeap<real>(fdata, *nsamp));
series.copyin(iseries);
*last = is.last() ? 1 : 0;
is >> wid2;
std::string ocode("");
if (is.hasfree()) { ocode.append("F"); }
if (is.hasinfo()) { ocode.append("I"); }
if (!is.last()) { ocode.append("D"); }
fillfstring(ocode, code, code_len);
*tanf=real(maketanf(wid2.date));
*dt=real(wid2.dt);
fillfstring(wid2.line(), wid2line, wid2line_len);
*nsamp=series.size();
}
catch(...) {
*ierr=1;
}
return retval;
} // int sff_rtrace__
/* ----- END OF fapid_sff_rtrace.cc ----- */
/*! \file fapid_sff_rtracefi.cc
* \brief read trace with FREE block and INFO line (implementation)
*
* ----------------------------------------------------------------------------
*
* $Id$
* \author Thomas Forbriger
* \date 03/01/2011
*
* read trace with FREE block and INFO line (implementation)
*
* Copyright (c) 2011 by Thomas Forbriger (BFO Schiltach)
*
* ----
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
* ----
*
*
* REVISIONS and CHANGES
* - 03/01/2011 V1.0 Thomas Forbriger
*
* ============================================================================
*/
#define TF_FAPID_SFF_RTRACEFI_CC_VERSION \
"TF_FAPID_SFF_RTRACEFI_CC V1.0 "
#define TF_FAPID_SFF_RTRACEFI_CC_CVSID \
"$Id$"
#include <fapidxx/fapidsff.h>
#include <fapidxx/fileunit.h>
#include <fapidxx/helper.h>
#include <fapidxx/error.h>
using namespace fapidxx;
/*! \brief Read one trace of data and return FREE block and
* INFO line additionally
*
* \ingroup implemented_functions
*
* Description from stuff.f:
* \code
c----------------------------------------------------------------------
subroutine sff_RTraceFI(lu, tanf, dt,
& wid2line, nsamp, fdata, idata, code, last,
& nline, lines, lindim, lenmax,
& cs, c1, c2, c3, nstack, ierr)
c
c Read one data block starting with DAST line.
c Read also FREE block and INFO line.
c The File will be closed after writing the last trace.
c
c input
c lu logical file unit
c lindim number of elements in FREE block array lines
c nsamp array dimension of idata and fdata
c ouput:
c ierr error status (ok: ierr=0)
c code code indicating optional blocks
c wid2line valid WID2 line
c tanf time of first sample from midnight
c dt sampling interval in seconds
c nsamp number of samples
c fdata data array
c last is true if read trace is the last one in this file
c nline number of FREE block lines read
c lines FREE block lines
c lenmax length of longest line in FREE block array lines
c cs coordinate system
c c1, c2, c3 receiver coordinates
c nstack number of stacks
c
c workspace:
c idata data will be first read to idata and then converted
c to fdata using sff_i2f (both array may be in same memory
c space - see comments on sff_f2i)
c
integer lu, nsamp, idata(nsamp), nline, nstack, lindim, lenmax
real fdata(nsamp), c1, c2, c3, dt, tanf
logical last
character wid2line*132, lines(lindim)*(*), cs*1, code*(*)
c----------------------------------------------------------------------
* \endcode
*/
{
int retval=0;
*ierr=0;
try {
datrw::ianystream &is=istreammanager(static_cast<int>(*lu));
sff::WID2 wid2;
sff::INFO info;
datrw::Tfseries iseries;
is >> iseries;
FAPIDXX_fuassert((static_cast<int>(iseries.size())<=(*nsamp)), *lu,
"sff_rtracei__: too many samples");
int nsamples=iseries.size();
aff::LinearShape shape(0, nsamples-1, 0);
datrw::Tfseries series(shape, aff::SharedHeap<real>(fdata, *nsamp));
series.copyin(iseries);
*last = is.last() ? 1 : 0;
is >> wid2;
std::string ocode("");
if (is.hasfree()) { ocode.append("F"); }
if (is.hasinfo()) { ocode.append("I"); }
if (!is.last()) { ocode.append("D"); }
if (is.hasinfo()) { is >> info; }
fillfstring(ocode, code, code_len);
*tanf=real(maketanf(wid2.date));
*dt=real(wid2.dt);
fillfstring(wid2.line(), wid2line, wid2line_len);
*nsamp=series.size();
char thecs=sff::coosysID(info.cs);
fillfstring(std::string(&thecs, 1), cs, cs_len);
*c1=real(info.cx);
*c2=real(info.cy);
*c3=real(info.cz);
*nstack=info.nstacks;
}
catch(...) {
*ierr=1;
}
return retval;
} // int sff_rtracei__
/* ----- END OF fapid_sff_rtracefi.cc ----- */
......@@ -102,7 +102,7 @@ int sff_rtracei__(integer *lu, real *tanf, real *dt, char *wid2line,
sff::INFO info;
datrw::Tfseries iseries;
is >> iseries;
FAPIDXX_fuassert((int(iseries.size())<=(*nsamp)), *lu,
FAPIDXX_fuassert((static_cast<int>(iseries.size())<=(*nsamp)), *lu,
"sff_rtracei__: too many samples");
int nsamples=iseries.size();
aff::LinearShape shape(0, nsamples-1, 0);
......@@ -111,12 +111,10 @@ int sff_rtracei__(integer *lu, real *tanf, real *dt, char *wid2line,
*last = is.last() ? 1 : 0;
is >> wid2;
std::string ocode("");
if (is.hasinfo())
{
is >> info;
ocode="I";
}
if (!is.last()) { ocode += "D"; }
if (is.hasfree()) { ocode.append("F"); }
if (is.hasinfo()) { ocode.append("I"); }
if (!is.last()) { ocode.append("D"); }
if (is.hasinfo()) { is >> info; }
fillfstring(ocode, code, code_len);
*tanf=real(maketanf(wid2.date));
*dt=real(wid2.dt);
......
c this is <fapid_sff_trimlen.f>
c ----------------------------------------------------------------------------
c ($Id$)
c
c Copyright (c) 2011 by Thomas Forbriger (BFO Schiltach)
c
c sff_TrimLen function copied from stuff.f
c
c ----
c This program is free software; you can redistribute it and/or modify
c it under the terms of the GNU General Public License as published by
c the Free Software Foundation; either version 2 of the License, or
c (at your option) any later version.
c
c This program is distributed in the hope that it will be useful,
c but WITHOUT ANY WARRANTY; without even the implied warranty of
c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
c GNU General Public License for more details.
c
c You should have received a copy of the GNU General Public License
c along with this program; if not, write to the Free Software
c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
c ----
c
c
c REVISIONS and CHANGES
c 02/01/2011 V1.0 Thomas Forbriger
c
c ============================================================================
c
c This function is copied from stuff.f
c It is implemented in libfapidxx since it cannot be replaced by the intrinsic
c Fortran function index in all cases. index(string,' ')-1 finds the
c index of the last character only in cases where the string does not
c contain spaces.
c
cD
c----------------------------------------------------------------------
subroutine sff_TrimLen(string,ntrim)
c
c give length of a string excluding trailing blanks
c Input:
c string: String to be trimmed
c Output:
c ntrim: length of string excluding trailing blanks
c
integer ntrim
character string*(*)
cE
do 10 ntrim=len(string),1,-1
10 if(string(ntrim:ntrim).ne.' ') return
ntrim = 1
return
end
c
c ----- END OF fapid_sff_trimlen.f -----
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment