Skip to content

GitLab

Commit 775f627d authored by thomas.forbriger's avatar thomas.forbriger
Browse files

libs/libseife [FEATURE]: add M3 to tide removal in C-version 

revision of tide removal code:
- both versions (C and Fortran): do case of nstep=1 explicitly
  seife by default averages over serval samples and uses the tidal
  hamonic as well as its derivatives for corrections; this appears to
  have saved computation time in the very early times but is of no
  relevance nowadays; by not averaging the code (and the computation)
  becomes much more straight-forward and less error-prone
- C-version: add M3 frequency
  The number of frequencies was fixed to 6 in the original version; to
  allow for the addition of frequencies, the dimensions of arrays now
  are det by C preprocessor macros; the function seife_gauss is modified
  accordingly to allow for a larger system of equations
parents e73b9e98 e69dcd9c
Hide whitespace changes
Inline Side-by-side
src/libs/libseife/COPYING
View file @ 775f627d
this is <COPYING>
============================================================================
libseife
--------
$Id$
============================================================================
The source code in this directory is part of libseife which compiles to
......
src/libs/libseife/Makefile
View file @ 775f627d
# this is <Makefile>
# ----------------------------------------------------------------------------
# ($Id$)
#
# 25/10/2000 by Thomas Forbriger (IMGF Frankfurt)
#
......
src/libs/libseife/cseife.c
View file @ 775f627d
......@@ -3,8 +3,6 @@
*
* ----------------------------------------------------------------------------
*
* $Id$
*
* ----
* 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
......@@ -37,8 +35,6 @@
*/
#define TF_CSEIFE_C_VERSION \
"TF_CSEIFE_C V1.2"
#define TF_CSEIFE_C_CVSID \
"$Id$"
#include <cseife.h>
#include <stdio.h>
......
src/libs/libseife/cseife.h
View file @ 775f627d
......@@ -3,7 +3,6 @@
*
* ----------------------------------------------------------------------------
*
* $Id$
* \author Thomas Forbriger
* \date 14/01/2005
*
......@@ -40,8 +39,6 @@
#define TF_CSEIFE_H_VERSION \
"TF_CSEIFE_H V1.2"
#define TF_CSEIFE_H_CVSID \
"$Id$"
#define SEIFE_EXIT_FAILURE 1
......
src/libs/libseife/cseife_deriv.c
View file @ 775f627d
......@@ -7,8 +7,6 @@
* This algorithm was part of seife.f. A current version of seife.f can be
* obtained from http://www.software-for-seismometry.de/
*
* $Id$
*
* ----
* 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
......@@ -36,8 +34,6 @@
*/
#define TF_CSEIFE_DERIV_C_VERSION \
"TF_CSEIFE_DERIV_C V1.0 "
#define TF_CSEIFE_DERIV_C_CVSID \
"$Id$"
#include <cseife.h>
......
src/libs/libseife/cseife_gauss.c
View file @ 775f627d
......@@ -7,8 +7,6 @@
* This algorithm was part of seife.f. A current version of seife.f can be
* obtained from http://www.software-for-seismometry.de/
*
* $Id$
*
* ----
* 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
......@@ -32,13 +30,13 @@
* REVISIONS and CHANGES
* - 28/06/2005 V1.0 Thomas Forbriger
* - 15/11/2010 V1.1 do not use tfmacros.h
* - 22/06/2020 V1.2 increase array size to allow for more tidal
* frequencies
*
* ============================================================================
*/
#define TF_CSEIFE_GAUSS_C_VERSION \
"TF_CSEIFE_GAUSS_C V1.1"
#define TF_CSEIFE_GAUSS_C_CVSID \
"$Id$"
"TF_CSEIFE_GAUSS_C V1.2"
#include <cseife.h>
#include <stdio.h>
......@@ -51,6 +49,7 @@
the code was derived through f2c, but modified thereafter
*/
#define C_MSIZE 20
void seife_gauss(double *aik, int m, int n, double* rs, double* f)
{
/* System generated locals */
......@@ -58,15 +57,15 @@ void seife_gauss(double *aik, int m, int n, double* rs, double* f)
double d__1;
/* Local variables */
int imax[14];
double h__[15];
int imax[(C_MSIZE+1)];
double h__[(C_MSIZE+2)];
int j, k, l;
double q;
int index;
double aikmax;
SEIFE_CHECKERROR( m>13 , "seife_gauss", "matrix is too large" )
SEIFE_CHECKERROR( n>13 , "seife_gauss", "matrix is too large" )
SEIFE_CHECKERROR( m>C_MSIZE , "seife_gauss", "matrix is too large" )
SEIFE_CHECKERROR( n>C_MSIZE , "seife_gauss", "matrix is too large" )
/* solve linear equations */
/* Parameter adjustments */
--f;
......
src/libs/libseife/cseife_rekfl.c
View file @ 775f627d
......@@ -7,8 +7,6 @@
* This algorithm was part of seife.f. A current version of seife.f can be
* obtained from http://www.software-for-seismometry.de/
*
* $Id$
*
* ----
* 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
......@@ -37,8 +35,6 @@
*/
#define TF_CSEIFE_REKFL_C_VERSION \
"TF_CSEIFE_REKFL_C V1.1"
#define TF_CSEIFE_REKFL_C_CVSID \
"$Id$"
#include <stdio.h>
#include <cseife.h>
......
src/libs/libseife/cseife_rfk.c
View file @ 775f627d
......@@ -7,8 +7,6 @@
* This algorithm was part of seife.f. A current version of seife.f can be
* obtained from http://www.software-for-seismometry.de/
*
* $Id$
*
* ----
* 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
......@@ -36,8 +34,6 @@
*/
#define TF_CSEIFE_RFK_C_VERSION \
"TF_CSEIFE_RFK_C V1.0 "
#define TF_CSEIFE_RFK_C_CVSID \
"$Id$"
#include <cseife.h>
#include <math.h>
......
src/libs/libseife/cseife_tides.c
View file @ 775f627d
......@@ -7,8 +7,6 @@
* This algorithm was part of seife.f. A current version of seife.f can be
* obtained from http://www.software-for-seismometry.de/
*
* $Id$
*
* ----
* 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
......@@ -25,19 +23,19 @@
* Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
* ----
*
* \date 28/06/2005
* \date 22/06/2020
*
* remove tides (implementation)
*
* REVISIONS and CHANGES
* - 28/06/2005 V1.0 Thomas Forbriger
* - 22/06/2020 V1.1 handle case of nstep=1 explicitly
* V1.2 make array size flexible and add M3 frequency
*
* ============================================================================
*/
#define TF_CSEIFE_TIDES_C_VERSION \
"TF_CSEIFE_TIDES_C V1.0 "
#define TF_CSEIFE_TIDES_C_CVSID \
"$Id$"
"TF_CSEIFE_TIDES_C V1.1"
#include <cseife.h>
#include <math.h>
......@@ -54,7 +52,10 @@ void seife_tid(double* x, int n, double dt, int nstep)
{
/* Initialized data */
static double omega[6] = { 1.93227,.92954,2.,1.00274,1.89567,.89293 };
#define C_MFREQ 7
#define C_MDIM (C_MFREQ*2+1)
static double omega[C_MFREQ] = { 2.898450424,
1.93227,.92954,2.,1.00274,1.89567,.89293 };
static double zero = 0.;
static double one = 1.;
static double two = 2.;
......@@ -62,19 +63,25 @@ void seife_tid(double* x, int n, double dt, int nstep)
/* System generated locals */
int i__1, i__2, i__3, i__4;
/* Builtin functions */
// double atan(double), cos(double), sin(double);
/* Local variables */
double tdif, omeg[6];
int ndim;
double step, tint, omeg0, xgez1, xgez2, xgez3, a[169] /*
was [13][13] */, c__[13], d__[13], e[13], f[13];
int i__, j, k;
double t;
int nfreq, k2, k3;
double tstep2;
int jj;
double rs[13], sx, dth;
int nco;
double cor[6], dur;
static double tdif, omeg[C_MFREQ];
static int ndim;
static double step, tint, omeg0, xgez1, xgez2, xgez3,
a[C_MDIM*C_MDIM], c__[C_MDIM], d__[C_MDIM],
e[C_MDIM], f[C_MDIM];
static int i__, j, k;
static double t;
static int nfreq, k2, k3;
static double tstep2;
static int jj;
static double rs[C_MDIM], sx, dth;
static int nco;
static double cor[C_MFREQ], dur;
// extern /* Subroutine */ int seife_gauss__(doublereal *, integer *,
// integer *, doublereal *, doublereal *);
/* remove tides. number of frequencies is automatically chosen according */
/* to the total length of the record. */
......@@ -82,7 +89,7 @@ void seife_tid(double* x, int n, double dt, int nstep)
--x;
/* Function Body */
ndim = 13;
ndim = C_MDIM;
dth = dt / two;
if (nstep == 0) {
......@@ -92,20 +99,25 @@ void seife_tid(double* x, int n, double dt, int nstep)
step = (double) nstep;
tstep2 = (step - one) * dth;
tint = tstep2 + dth;
if (nstep == 1) {
step = 1.;
tstep2 = 0.;
tint = dth;
}
/* determine the number of frequencies required for a good fit */
dur = n * dt / 3600.;
nfreq = 6;
nfreq = C_MFREQ;
if (dur < 35.) {
nfreq = 5;
nfreq = 6;
}
if (dur < 18.) {
nfreq = 4;
nfreq = 5;
}
if (dur < 14.) {
nfreq = 3;
nfreq = 4;
}
if (dur < 5.) {
nfreq = 2;
nfreq = 3;
}
nco = (nfreq << 1) + 1;
omeg0 = atan(one) * 8. / 86400.;
......@@ -121,87 +133,143 @@ void seife_tid(double* x, int n, double dt, int nstep)
i__2 = nco;
for (k = 1; k <= i__2; ++k) {
/* L1: */
a[i__ + k * 13 - 14] = 0.;
a[i__ + k * C_MDIM - (C_MDIM+1)] = 0.;
}
}
if (nstep == 1) {
/* ====================================================================== */
/* do not average */
/* ============== */
/* correction for averaging over nstep samples */
i__2 = nfreq;
for (j = 1; j <= i__2; ++j) {
cor[j - 1] = 1.;
}
/* set up system of linear equations */
c__[0] = one;
i__2 = n;
for (j = 1; j <= i__2; ++j) {
sx = zero;
i__1 = j;
for (jj = j; jj <= i__1; ++jj) {
sx += x[jj];
}
t = (j - 1) * dt;
i__1 = nfreq;
for (k = 1; k <= i__1; ++k) {
c__[(k << 1) - 1] = cos(omeg[k - 1] * t);
c__[k * 2] = sin(omeg[k - 1] * t);
}
i__1 = nco;
for (i__ = 1; i__ <= i__1; ++i__) {
rs[i__ - 1] += sx * c__[i__ - 1];
i__3 = nco;
for (k = 1; k <= i__3; ++k) {
a[i__ + k * C_MDIM - (C_MDIM+1)] += c__[i__ - 1] * c__[k - 1];
}
}
}
/* solve for partial amplitudes */
seife_gauss(a, nco, ndim, rs, f);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
t = (j - 1) * dt;
/* remove average and tides */
xgez1 = f[0];
i__1 = nfreq;
for (k = 1; k <= i__1; ++k) {
k2 = k << 1;
k3 = k2 + 1;
c__[k2 - 1] = cos(omeg[k - 1] * t);
c__[k3 - 1] = sin(omeg[k - 1] * t);
xgez1 = xgez1 + f[k2 - 1] * c__[k2 - 1] + f[k3 - 1] * c__[k3
- 1];
}
x[j] -= xgez1;
}
} else {
/* ====================================================================== */
/* average over nstep samples */
/* ========================== */
/* correction for averaging over nstep samples */
i__2 = nfreq;
for (j = 1; j <= i__2; ++j) {
i__2 = nfreq;
for (j = 1; j <= i__2; ++j) {
/* L102: */
cor[j - 1] = step * sin(omeg[j - 1] * dth) / sin(step * omeg[j - 1] *
dth);
}
cor[j - 1] = step * sin(omeg[j - 1] * dth) / sin(step * omeg[j -
1] * dth);
}
/* set up system of linear equations */
c__[0] = one;
i__2 = n - nstep + 1;
i__1 = nstep;
for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
sx = zero;
i__3 = j + nstep - 1;
for (jj = j; jj <= i__3; ++jj) {
c__[0] = one;
i__2 = n - nstep + 1;
i__1 = nstep;
for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
sx = zero;
i__3 = j + nstep - 1;
for (jj = j; jj <= i__3; ++jj) {
/* L12: */
sx += x[jj];
}
sx /= step;
t = (j - 1) * dt + tstep2;
i__3 = nfreq;
for (k = 1; k <= i__3; ++k) {
c__[(k << 1) - 1] = cos(omeg[k - 1] * t);
sx += x[jj];
}
sx /= step;
t = (j - 1) * dt + tstep2;
i__3 = nfreq;
for (k = 1; k <= i__3; ++k) {
c__[(k << 1) - 1] = cos(omeg[k - 1] * t);
/* L103: */
c__[k * 2] = sin(omeg[k - 1] * t);
}
i__3 = nco;
for (i__ = 1; i__ <= i__3; ++i__) {
rs[i__ - 1] += sx * c__[i__ - 1];
i__4 = nco;
for (k = 1; k <= i__4; ++k) {
c__[k * 2] = sin(omeg[k - 1] * t);
}
i__3 = nco;
for (i__ = 1; i__ <= i__3; ++i__) {
rs[i__ - 1] += sx * c__[i__ - 1];
i__4 = nco;
for (k = 1; k <= i__4; ++k) {
/* L2: */
a[i__ + k * 13 - 14] += c__[i__ - 1] * c__[k - 1];
a[i__ + k * C_MDIM - (C_MDIM+1)] += c__[i__ - 1] * c__[k - 1];
}
}
}
}
/* solve for partial amplitudes */
seife_gauss(a, nco, ndim, rs, f);
i__4 = n - nstep + 1;
i__3 = nstep;
for (j = 1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
t = (j - 1) * dt + tstep2;
seife_gauss(a, nco, ndim, rs, f);
i__4 = n - nstep + 1;
i__3 = nstep;
for (j = 1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
t = (j - 1) * dt + tstep2;
/* remove average and tides */
i__1 = nfreq;
for (k = 1; k <= i__1; ++k) {
k2 = k << 1;
k3 = k2 + 1;
c__[k2 - 1] = cos(omeg[k - 1] * t);
c__[k3 - 1] = sin(omeg[k - 1] * t);
d__[k2 - 1] = -omeg[k - 1] * c__[k3 - 1];
d__[k3 - 1] = omeg[k - 1] * c__[k2 - 1];
e[k2 - 1] = -omeg[k - 1] * d__[k3 - 1];
i__1 = nfreq;
for (k = 1; k <= i__1; ++k) {
k2 = k << 1;
k3 = k2 + 1;
c__[k2 - 1] = cos(omeg[k - 1] * t);
c__[k3 - 1] = sin(omeg[k - 1] * t);
d__[k2 - 1] = -omeg[k - 1] * c__[k3 - 1];
d__[k3 - 1] = omeg[k - 1] * c__[k2 - 1];
e[k2 - 1] = -omeg[k - 1] * d__[k3 - 1];
/* L104: */
e[k3 - 1] = omeg[k - 1] * d__[k2 - 1];
}
xgez1 = f[0];
xgez2 = zero;
xgez3 = zero;
i__1 = nfreq;
for (k = 1; k <= i__1; ++k) {
k2 = k << 1;
k3 = k2 + 1;
xgez1 += cor[k - 1] * (f[k2 - 1] * c__[k2 - 1] + f[k3 - 1] * c__[
k3 - 1]);
xgez2 += cor[k - 1] * (f[k2 - 1] * d__[k2 - 1] + f[k3 - 1] * d__[
k3 - 1]);
e[k3 - 1] = omeg[k - 1] * d__[k2 - 1];
}
xgez1 = f[0];
xgez2 = zero;
xgez3 = zero;
i__1 = nfreq;
for (k = 1; k <= i__1; ++k) {
k2 = k << 1;
k3 = k2 + 1;
xgez1 += cor[k - 1] * (f[k2 - 1] * c__[k2 - 1] + f[k3 - 1] *
c__[k3 - 1]);
xgez2 += cor[k - 1] * (f[k2 - 1] * d__[k2 - 1] + f[k3 - 1] *
d__[k3 - 1]);
/* L105: */
xgez3 += cor[k - 1] * (f[k2 - 1] * e[k2 - 1] + f[k3 - 1] * e[k3 -
1]) / two;
}
if (j > n - (nstep << 1) + 1) {
nstep = n + 1 - j;
}
i__1 = j + nstep - 1;
for (jj = j; jj <= i__1; ++jj) {
tdif = (jj - j) * dt - tstep2;
xgez3 += cor[k - 1] * (f[k2 - 1] * e[k2 - 1] + f[k3 - 1] * e[
k3 - 1]) / two;
}
if (j > n - (nstep << 1) + 1) {
nstep = n + 1 - j;
}
i__1 = j + nstep - 1;
for (jj = j; jj <= i__1; ++jj) {
tdif = (jj - j) * dt - tstep2;
/* L3: */
x[jj] = x[jj] - xgez1 - xgez2 * tdif - xgez3 * tdif * tdif;
x[jj] = x[jj] - xgez1 - xgez2 * tdif - xgez3 * tdif * tdif;
}
}
}
} /* seife_tides__ */
......
src/libs/libseife/subs/seife.f
View file @ 775f627d
c this is <seife.f>
c------------------------------------------------------------------------------
c ($Id$)
c
c Copyright 1984 by Erhard Wielandt
c This code was part of the program seife.f. A current version of seife.f can
......@@ -131,21 +130,21 @@ c
c All input
c Seife main routine converted to a subroutine
c-------------------------------------------------------------
subroutine seife(typ,par,n,dt,tmin,tsec,x,msg)
subroutine seife(typ,par,n,dt,tmin,tsec,x,msg)
include 'seife_common.inc'
character version*80
double precision x(n)
character typ*3, par*(*), msg*(*)
logical nil
double precision x(n)
character typ*3, par*(*), msg*(*)
logical nil
c
version='LIBSEIFE V1.8 time domain signal processing'
nil=.true.
msg=' '
if(typ.eq.'lim') then
read(par,*) npts
n=min(n,npts)
nil=.false.
endif
if(typ.eq.'lim') then
read(par,*) npts
n=min(n,npts)
nil=.false.
endif
if(typ.eq.'fac') call seife_factor(nil,par,x,n,msg)
if(typ.eq.'nrm') call seife_normalize(nil,par,x,n,msg)
if(typ.eq.'mim') call seife_mim(nil,par,x,n,msg)
......@@ -154,8 +153,8 @@ c
if(typ.eq.'spl') call seife_interp(nil,par,x,n,msg)
if(typ.eq.'csi') call seife_intpo (nil,par,dt,x,n,msg)
if(typ.eq.'win'.or.typ.eq.'sin'.or.typ.eq.'skp'.or.typ.eq.'tap'
& .or.typ.eq.'sis'.or.typ.eq.'cos'.or.typ.eq.'cob')
& call seife_window(nil,typ,par,x,n,dt,tmin,tsec,msg)
& .or.typ.eq.'sis'.or.typ.eq.'cos'.or.typ.eq.'cob')
& call seife_window(nil,typ,par,x,n,dt,tmin,tsec,msg)
if(typ.eq.'twi') call seife_timwin(nil,par,x,n,dt,tmin,tsec,msg)
if(typ.eq.'nul') call seife_null(nil,par,x,n,msg)
if(typ.eq.'clp') call seife_clip(nil,par,x,n,msg)
......@@ -174,19 +173,19 @@ c
if(typ.eq.'abs') call seife_abs(nil,par,x,n,msg)
if(typ.eq.'fir') call seife_resetfirst(nil,par,x,n,.true.,msg)
if(typ.eq.'rfi') call seife_resetfirst(nil,par,x,n,.false.,msg)
if(typ.eq.'lp1'.or.
1 typ.eq.'int'.or.
1 typ.eq.'hp1'.or.
1 typ.eq.'le1'.or.
1 typ.eq.'he1'.or.
1 typ.eq.'lp2'.or.
1 typ.eq.'hp2'.or.
1 typ.eq.'bp2'.or.
1 typ.eq.'le2'.or.
1 typ.eq.'he2'.or.
1 typ.eq.'lpb'.or.
1 typ.eq.'hpb')
1 call seife_filter(nil,typ,par,x,n,dt,msg)
if(typ.eq.'lp1'.or.
1 typ.eq.'int'.or.
1 typ.eq.'hp1'.or.
1 typ.eq.'le1'.or.
1 typ.eq.'he1'.or.
1 typ.eq.'lp2'.or.
1 typ.eq.'hp2'.or.
1 typ.eq.'bp2'.or.
1 typ.eq.'le2'.or.
1 typ.eq.'he2'.or.
1 typ.eq.'lpb'.or.
1 typ.eq.'hpb')
1 call seife_filter(nil,typ,par,x,n,dt,msg)
if(typ.eq.'hel') call seife_help(nil,version,msg)
if(typ.eq.'rem') call seife_remark(nil, typ, par, msg)
if(typ.eq.'DBG') then
......
src/libs/libseife/subs/seife_abs.f
View file @ 775f627d
c this is <seife_abs.f>
c------------------------------------------------------------------------------
c ($Id$)
c
c Copyright 1984 by Erhard Wielandt
c This code was part of seife.f. A current version of seife.f can be obtained
......
src/libs/libseife/subs/seife_add.f
View file @ 775f627d
c this is <seife_add.f>
c------------------------------------------------------------------------------
c ($Id$)
c
c Copyright 1984 by Erhard Wielandt
c This code was part of seife.f. A current version of seife.f can be obtained
......
src/libs/libseife/subs/seife_baseline.f
View file @ 775f627d
c this is <seife_baseline.f>
c ----------------------------------------------------------------------------
c ($Id$)
c
c Copyright (c) 2002 by Thomas Forbriger (IMG Frankfurt)
c
......
src/libs/libseife/subs/seife_clip.f
View file @ 775f627d
c this is <seife_clip.f>
c------------------------------------------------------------------------------