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

new data weight routines

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/trunk
SVN Revision: 830
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent 8c982248
c this is <gremlin.f>
c------------------------------------------------------------------------------
c $Id: gremlin.f,v 1.16 2002-05-06 15:43:13 forbrig Exp $
c $Id: gremlin.f,v 1.17 2002-05-07 16:35:25 forbrig Exp $
c
c 05/12/97 by Thomas Forbriger (IfG Stuttgart)
c
......@@ -81,6 +81,7 @@ c 19/04/02 V4.13 support square error ense-test by command swense
c 03/05/02 V4.13b only test selected parameters in resolution analysis
c 06/05/02 V4.13c - allow for sqr and rms scaling in sense and ense
c - allow to use preexisting partial derivatives
c 07/05/02 V4.14 new data weight routines
c
c==============================================================================
c
......@@ -88,7 +89,7 @@ c
c
character*79 version
parameter(version=
& 'GREMLIN V4.13c GREens Matrix Linearized INversion')
& 'GREMLIN V4.14 GREens Matrix Linearized INversion')
c common blocks
include 'libs/glq_dim.inc'
include 'libs/glq_para.inc'
......@@ -99,7 +100,7 @@ c
c program loop
logical hot, subs_exists
integer ival
real numin, numax, rval
real numin, numax, rval, rval2
c commandline
integer maxopt, lastarg, iargc
character*80 argument
......@@ -369,6 +370,9 @@ c call oldgremlin
call mod_read(argument(5:80), mb_work)
call pg_fullset(.false.)
endif
elseif (argument(1:8).eq.'weights ') then
read(argument(9:80), *, err=98, end=98) rval, rval2
call dat_mmweights(rval,rval2)
elseif (argument(1:5).eq.'term ') then
hot=.false.
elseif (argument(1:9).eq.'morehelp ') then
......@@ -421,6 +425,18 @@ c
c
if (arg(1:6).eq.'green ') then
if (subs_exists(arg(7:80), .true.)) call dat_rgreen(arg(7:80))
elseif (arg(1:5).eq.'wwrt ') then
if (.not.(subs_exists(arg(6:80), .false.)))
& call dat_wtweight(arg(6:80), .true.)
elseif (arg(1:5).eq.'wwct ') then
if (.not.(subs_exists(arg(6:80), .false.)))
& call dat_wtweight(arg(6:80), .false.)
elseif (arg(1:5).eq.'wwrg ') then
if (.not.(subs_exists(arg(6:80), .false.)))
& call dat_wgweight(arg(6:80), .true.)
elseif (arg(1:5).eq.'wwcg ') then
if (.not.(subs_exists(arg(6:80), .false.)))
& call dat_wgweight(arg(6:80), .false.)
elseif (arg(1:4).eq.'mtt ') then
if (subs_exists(arg(5:80), .true.)) call dat_mtt(arg(5:80))
elseif (arg(1:3).eq.'tt ') then
......
c this is <gremlin_help.f>
c------------------------------------------------------------------------------
c $Id: gremlin_help.f,v 1.5 2002-05-06 14:49:17 forbrig Exp $
c $Id: gremlin_help.f,v 1.6 2002-05-07 16:35:25 forbrig Exp $
c
c 25/03/98 by Thomas Forbriger (IfG Stuttgart)
c
......@@ -14,6 +14,7 @@ c 24/05/00 V1.3 - introduced reso option wgpd
c - introduced reso option wense
c 19/04/02 V1.4 introduced command swense
c 06/05/02 V1.5 introduced sqense and ssense
c 07/05/02 V1.6 new data weight routines
c
c==============================================================================
c
......@@ -50,6 +51,11 @@ c
call gremhelp_subtit('set/display inversion parameters')
print *,' spa set various parameters'
print *,' dpa display all parameter settings'
print *,' weights th1,th2'
print *,' calculate misfit-dependend data weights'
print *,' you are invited to have a look in'
print *,' subroutine dat_mmweights to learn about'
print *,' the calculation rule ;-)'
call gremhelp_subtit('control inversion')
print *,' dda display basic crontrol screen'
print *,' opt lim,step optimize model with extra break condition'
......@@ -165,6 +171,10 @@ c
print *,'resp file write complex response file'
print *,'wsave file save model parameter weights to file'
print *,'wread file read model parameter weights from file'
print *,'wwrt file write original traveltime weights'
print *,'wwct file write calculated traveltime weights'
print *,'wwrg file write original green weights'
print *,'wwcg file write calculated green weights'
print *,'exit leave submenu'
print *,'quit leave submenu'
return
......
cS
c this is <dat_wgweight.f>
c ----------------------------------------------------------------------------
c ($Id: dat_wgweight.f,v 1.1 2002-05-07 16:35:27 forbrig Exp $)
c
c Copyright (c) 2002 by Thomas Forbriger (IMG Frankfurt)
c
c write green data weights to a file
c
c REVISIONS and CHANGES
c 07/05/2002 V1.0 Thomas Forbriger
c
c ============================================================================
c
subroutine dat_wgweight(filename,orig)
c
c orig: write original weights if true (calculated else)
c
logical orig
character*(*) filename
c
include 'glq_dim.inc'
include 'glq_data.inc'
include 'glq_verbose.inc'
c
cE
c
c magic number for binary file identification
parameter(wcmagic='123S')
integer magic
integer lu,i,j
parameter(lu=13)
c
c write taper code (easy to use)
c
if (verb_io) then
print *,'NOTICE (dat_wgweight): '
print *,' opening green weight file ',
& filename(1:index(filename,' ')),
& ' - overwrite mode'
endif
open(lu, file=filename, form='unformatted', err=98)
call tf_magic(wcmagic, magic)
write(lu, err=97) magic
write(lu, err=97) data_nfre, data_nslo
if (orig) then
write(lu, err=97)
& ((rgweight(i,j), i=1,data_nfre), j=1,data_nslo)
else
write(lu, err=97) ((gweight(i,j), i=1,data_nfre), j=1,data_nslo)
endif
close(lu, err=96)
if (verb_io) print *,'NOTICE (dat_wgweight): ',
& 'green weight file written and closed'
c
return
98 stop 'ERROR: opening green weight file'
97 stop 'ERROR: writing green weight file'
96 stop 'ERROR: closing green weight file'
end
c
c ----- END OF dat_wgweight.f -----
c this is <dat_wtweight.f>
c ----------------------------------------------------------------------------
c ($Id: dat_wtweight.f,v 1.1 2002-05-07 16:35:27 forbrig Exp $)
c
c Copyright (c) 2002 by Thomas Forbriger (IMG Frankfurt)
c
c write traveltime weights to a file
c
c REVISIONS and CHANGES
c 07/05/2002 V1.0 Thomas Forbriger
c
c ============================================================================
c
subroutine dat_wgweight(filename,orig)
c
c orig: write original weights if true (calculated else)
c
logical orig
character*(*) filename
c
include 'glq_dim.inc'
include 'glq_data.inc'
include 'glq_verbose.inc'
c
cE
c
integer lu,i
parameter(lu=13)
c
c write code (easy to use)
c
if (verb_io) then
print *,'NOTICE (dat_wtweight): '
print *,' opening traveltime weight file ',
& filename(1:index(filename,' ')),
& ' - overwrite mode'
endif
open(lu, file=filename, err=98)
write(lu, err=97, fmt=50) data_ntts,'offset','weight'
if (orig) then
write(lu, err=97, fmt=51)
& (travx(i), rtweight(i,j), i=1,data_ntts)
else
write(lu, err=97, fmt=51)
& (travx(i), tweight(i,j), i=1,data_ntts)
endif
close(lu, err=96)
if (verb_io) print *,'NOTICE (dat_wtweight): ',
& 'traveltime weight file written and closed'
c
return
98 stop 'ERROR: opening traveltime weight file'
97 stop 'ERROR: writing traveltime weight file'
96 stop 'ERROR: closing traveltime weight file'
50 format('traveltime weights',//,i5,' offsets',//,2(2x,a10))
51 format(2(2x,g10.4))
end
c
c ----- END OF dat_wtweight.f -----
Supports Markdown
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