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

added two new reso options to gremlin1

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: 178
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent d3371bdb
c this is <gremlin.f>
c------------------------------------------------------------------------------
c $Id: gremlin.f,v 1.7 2000-05-24 18:41:34 thof Exp $
c
c 05/12/97 by Thomas Forbriger (IfG Stuttgart)
c
......@@ -70,13 +71,15 @@ c 01/07/99 V4.5 - added pg monitor devices
c 02/07/99 V4.6 - allow reading of green weights
c 09/04/00 V4.7 - added some data modifying functionality
c 10/04/00 V4.8 introduced model_interval and did update documentation
c 24/05/00 V4.9 - introduced reso option wgpd
c - introduced reso option wense
c
c==============================================================================
c
program gremlin
c
character*79 version
parameter(version='GREMLIN V4.8 GREens Matrix Linearized INversion')
parameter(version='GREMLIN V4.9 GREens Matrix Linearized INversion')
c common blocks
include 'libs/glq_dim.inc'
include 'libs/glq_para.inc'
......@@ -463,7 +466,7 @@ c
include 'libs/glq_dim.inc'
include 'libs/glq_model.inc'
c
character arg*(80)
character arg*(80), bn*80
logical hot, inv_part, inv_mat, dat_cref
integer ival, ival2
real rval,rval2
......@@ -484,6 +487,13 @@ c
else
print *,'calculation of partial derivatives failed'
endif
elseif (arg(1:6).eq.'wense ') then
read(arg(7:80), *, err=98, end=98) ival,ival2,rval,rval2,bn
if (inv_mat()) then
call res_wresmod(ival, ival2, rval, rval2, bn)
else
print *,'calculation of partial derivatives failed'
endif
elseif (arg(1:5).eq.'ense ') then
read(arg(6:80), *, err=98, end=98) ival,ival2,rval,rval2
if (inv_mat()) then
......@@ -516,6 +526,19 @@ c
else
print *,'calculation of reference synthetics failed'
endif
elseif (arg(1:5).eq.'wgpd ') then
if (dat_cref()) then
if (inv_part()) then
call inv_ds
do ival=1,mod_n
call res_wgpart(arg(6:), ival)
enddo
else
print *,'calculation of partial derivatives failed'
endif
else
print *,'calculation of reference synthetics failed'
endif
elseif (arg(1:4).eq.'gpd ') then
read(arg(5:80), *, err=98, end=98) ival
if (dat_cref()) then
......
c this is <gremlin_help.f>
c------------------------------------------------------------------------------
c $Id: gremlin_help.f,v 1.2 2000-05-24 18:41:34 thof Exp $
c
c 25/03/98 by Thomas Forbriger (IfG Stuttgart)
c
......@@ -9,6 +10,8 @@ c REVISIONS and CHANGES
c 25/03/98 V1.0 Thomas Forbriger
c 14/01/99 V1.1 removed link to old gremlin code
c 04/03/99 V1.2 file/mtt explanation
c 24/05/00 V1.3 - introduced reso option wgpd
c - introduced reso option wense
c
c==============================================================================
c
......@@ -95,12 +98,17 @@ c
print *,' tpda plot travel time partial derivatives for all parameters'
print *,' gpd ival plot green partial derivatives for parameter ival'
print *,' gpda plot green partial derivatives for all parameters'
print *,' wgpd name write green partial derivatives to files with'
print *,' base ''name'' '
print *,' ense f,t,nu,rms rate model parameters with index from ''f'' to'
print *,' ''t'' when optimizing all other free parameters'
print *,' stabilized with ''nu'' and accepting an rms-error'
print *,' of ''rms'' in a linear approximation'
print *,' sense f,t,nu,rms just like ''ense'' but puts rating for each'
print *,' parameter on a different page'
print *,' wense f,t,nu,rms,name'
print *,' just like ''sense'' but puts rating for each'
print *,' parameter to a file with base ''name'' '
call gremhelp_subtit('tests')
print *,' orth calculate scalar products and normalized scalar'
print *,' products of vectors of partial derivatives'
......
#
# $Id: Makefile,v 1.3 2000-04-11 21:39:45 thof Exp $
# $Id: Makefile,v 1.4 2000-05-24 18:41:34 thof Exp $
#
# Makefile for green/gremlin1/libs
#
......@@ -36,7 +36,7 @@ PGOBS=pg_fullset.o pg_gdata.o pg_green.o pg_inv.o pg_invfix.o pg_linx2.o \
pg_resmod.o pg_sresmod.o pgs_par1.o pg_scoli.o pg_colis.o pg_zcoli.o \
pg_tapgreen.o pgmon_update.o pgmon_togupdt.o pgmon_tmgupdt.o \
pgmon_trgupdt.o
RESOBS=res_part.o res_opt.o res_orth.o
RESOBS=res_part.o res_opt.o res_orth.o res_wgpart.o res_wresmod.o
OLDOBS=mod_parcor1.o mod_chop1.o
OLGPGOBS=
......
c this is <res_wgpart.f>
c------------------------------------------------------------------------------
cS
c ($Source: /home/tforb/svnbuild/cvssource/CVS/thof/src/green/gremlin1/libs/res_wgpart.f,v $)
c ($Id: res_wgpart.f,v 1.1 2000-05-24 18:41:34 thof Exp $)
c
c 24/05/2000 by Thomas Forbriger (IfG Stuttgart)
c
c write partial derivative of green
c
c REVISIONS and CHANGES
c 24/05/2000 V1.0 Thomas Forbriger
c
c==============================================================================
c
subroutine res_wgpart(basename, ipar)
c
c declare parameters
c basename: filename base
c ipar: partial derivative for parameter
c
character*(*) basename
integer ipar
c
cE
c declare local variables
character*(*) res_wgpart_id
parameter (res_wgpart_id='$Id: res_wgpart.f,v 1.1 2000-05-24 18:41:34 thof Exp $')
c
include 'glq_dim.inc'
include 'glq_data.inc'
include 'glq_model.inc'
include 'glq_inv.inc'
include 'glq_para.inc'
include 'glq_verbose.inc'
c
cE
integer ipara
character*80 title, filename
integer islo, ifre, lu,i,j
parameter(lu=20)
integer mpar, msec, mpol, iano
character*20 parname
real pi2
parameter(pi2=2.*3.14159265358979311599)
c
c magic number for binary file identification
integer magic
character*4 cmagic
parameter(cmagic='1234')
c
c------------------------------------------------------------------------------
c go
c
if (verb_subaction) print *,'ENTER res_wgpart(',basename,',',ipar,')'
c
if (verb_subaction) print *,
& 'NOTICE (res_wgpart): write green partial derivatives for parameter ',
& ipar,' to file'
c
c set model index
ipara=ipar
if ((ipara.lt.1).or.(ipara.gt.mod_n)) then
print *,'WARNING (res_wgpart): invalid model parameter index ',ipara
return
endif
c
c copy values
iano=0
do islo=rng_smin,rng_smax
do ifre=rng_fmin,rng_fmax
iano=iano+1
readgreen(islo, ifre)=lq_dss(iano, ipara)
enddo
enddo
c
do islo=rng_smin,rng_smax
read_dat_slo(islo)=dat_slo(islo)*1.e-3
enddo
c
do ifre=rng_fmin,rng_fmax
read_dat_om(ifre)=dat_fre(ifre)*pi2
enddo
c
c plot
call mod_identify(ipara, msec, mpol, mpar, parname)
write (title, 50) ipara, mpol-1,
& parname(1:index(parname,' ')), msec
write (filename, 51) basename(1:index(basename,' ')-1),ipara,
& parname(1:index(parname,' ')-1), msec, mpol-1
c
c write green code (easy to use)
c
if (verb_io) print *,'NOTICE: opening green file ',
& filename(1:index(filename,' ')),
& ' - overwrite mode'
open(lu, file=filename, form='unformatted', err=98)
call tf_magic(cmagic, magic)
write(lu, err=97) magic
write(lu, err=97) (rng_fmax-rng_fmin)+1, (rng_smax-rng_smin)+1
write(lu, err=97) (read_dat_om(i), i=rng_fmin,rng_fmax),
& (read_dat_slo(i), i=rng_smin,rng_smax)
write(lu, err=97) ((readgreen(j,i), i=rng_fmin,rng_fmax),
& j=rng_smin,rng_smax)
close(lu, err=96)
if (verb_io) print *,'NOTICE: closed file'
c
if (verb_subaction) print *,'LEAVE res_wgpart'
c
return
50 format('partial derivatives for parameter ',i3,': ord. ',i3,
& ' of ',a,'in section ',i3)
51 format(a,'.',i3.3,'.',a,'.',i3.3,'.',i3.3)
99 stop 'ERROR: reading command line argument'
98 stop 'ERROR: opening green file'
97 stop 'ERROR: writing green file'
96 stop 'ERROR: closing green file'
c the following line prevents the linker from removing the ID string
95 print *, res_wgpart_id
end
c
c ----- END OF res_wgpart.f -----
c this is <res_wresmod.f>
c------------------------------------------------------------------------------
cS
c ($Source: /home/tforb/svnbuild/cvssource/CVS/thof/src/green/gremlin1/libs/res_wresmod.f,v $)
c ($Id: res_wresmod.f,v 1.1 2000-05-24 18:41:34 thof Exp $)
c
c 24/05/2000 by Thomas Forbriger (IfG Stuttgart)
c
c write result of resolution analysis to model files
c
c REVISIONS and CHANGES
c 24/05/2000 V1.0 Thomas Forbriger
c
c==============================================================================
c
subroutine res_wresmod(mimin, mimax, nu, finalrms, basename)
c
c call res_opt for given partial derivatives and precalculated
c matrices for model parameters mimin to mimax and write resulting
c ensemble of models - each to a seperate file
c
c nu: stabilization factor
c finalrms: rms error increase to find parameter changes for
c basename: base for filenames
c
integer mimin,mimax
real nu, finalrms
character*(*) basename
c
include 'glq_dim.inc'
include 'glq_model.inc'
include 'glq_verbose.inc'
c
cE
c declare local variables
logical res_opt
integer mi, i
character*120 parname, title, filename
integer mpol, mpar, msec
character*(*) res_wresmod_id
parameter (res_wresmod_id='$Id: res_wresmod.f,v 1.1 2000-05-24 18:41:34 thof Exp $')
c
if (verb_subaction) print *,'ENTER res_wresmod(',mimin,',',mimax,
& nu,',',finalrms,',',basename,')'
c
if (verb_subaction)
& print *,'NOTICE (res_wresmod): plot rated models for parameters',
& mimin,' to ',mimax,' to viewports 1,2,3'
c
c check parameter range
if (mimin.gt.mimax) then
print *,'WARNING (res_wresmod): ',
& 'mimin is greater than mimax'
return
endif
if (mimin.lt.1) then
print *,'WARNING (res_wresmod): ',
& 'mimin is less than 1'
return
endif
if (mimax.gt.mod_n) then
print *,'WARNING (res_wresmod): ',
& 'mimax is too large'
return
endif
c
do mi=mimin,mimax
c plot
call mod_identify(mi, msec, mpol, mpar, parname)
write (title, 50) mi, mpol-1,
& parname(1:index(parname,' ')), msec,finalrms,nu
c plot pure model
call mod_chop(mb_ref)
if (verb_topstrategy) print *,'NOTICE (res_wresmod): ',
& 'going for parameter ',mi
if (res_opt(mi, nu, finalrms)) then
call mod_parcor
write (filename, 51) basename(1:index(basename,' ')-1),mi,
& parname(1:index(parname,' ')-1), msec, mpol-1,'up'
call mod_save(filename,mb_work,.true.,title)
do i=1,mod_n
mdelta(i)=-mdelta(i)
enddo
call mod_parcor
write (filename, 51) basename(1:index(basename,' ')-1),mi,
& parname(1:index(parname,' ')-1), msec, mpol-1,'down'
call mod_save(filename,mb_work,.true.,title)
else
print *,'WARNING (res_wresmod): ',
& 'res_opt failed for parameter ',mi
endif
enddo
c
if (verb_subaction) print *,'LEAVE res_wresmod'
c
return
50 format('rating par. ',i3,': ord. ',i3,
& ' of ',a,'in section ',i3,' (Xrms=',
& g10.2,', nu=',g10.2,')')
51 format(a,'.',i3.3,'.',a,'.',i3.3,'.',i3.3,'.',a)
c the following line prevents the linker from removing the ID string
99 print *, res_wresmod_id
end
c
c ----- END OF res_wresmod.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