Report
Report
Report
GEOLOGICAL SURVEY
by
R.A. Harris and P. Segalll
This report is preliminary and has not been edited or reviewed for conformity
with Geological Survey standards and nomenclature. Any use of trade names and
trademarks in this publication is for descriptive purposes only and does not
constitute endorsement by the U.S. Geological Survey. Although this program
has been tested extensively, the U.S. Geological Survey makes no guarantee of
correct results.
PAGE
INTRODUCTION .......................................................... 3
REFERENCES ............................................................. 19
ILLUSTRATIONS
FIGURE 1 ............................................................... 16
INTRODUCTION
INVERSE.FOR is a FORTRAN 77 program which runs on the VAX/VMS 785
computer. Its creation was motivated by the desire to use line-length
measurements made at the earth's surface for information about two-dimensional
slip at depth on the San Andreas fault near Parkfield, California. In the
Parkfield area, a transition occurs as the surface expression of the San
Andreas fault progresses from a creeping zone in the northwest to a locked
zone in the southeast. We have used the inverse program to invert line-length
measurements made in the Parkfield area for slip on the San Andreas fault.
The results have included the imaging of a locked patch at depth, located
beneath the transition zone. (Harris and Segall, 1985, Segall and Harris,
1986).
The program is designed to perform a two-dimensional inversion of
trilateration line-length data or strain data to solve for strike-slip motion
on a vertical strike-slip fault. It also solves for a component of strain
perpendicular to the fault plane. A few parts of the program, such as the
subroutine CHINSSL, have been borrowed from Will Prescott's program
MAIN29.FOR. Interactive input routines and the subroutine which sends the
slip model to a file where it can be plotted were provided by Bob Simpson.
There are five subroutines in the program. They are:
1) CHINSSL, which calculates the Green's functions using Chinnery's equations
(Chinnery, 1961) for surface displacement caused by a vertical rectangular
dislocation in an elastic half-space.
2) CRD, which translates and rotates coordinates to a fault-centered system.
3) FMODEL, which reads the fault geometry information and sets up a fault grid
representing the fault plane.
4) MODELWT, which calculates a weighting matrix for the model.
5) SENSIT, which does a singular-value-decomposition of the data kernel matrix
and computes a number of paramenters for each run. Included among these are
the model and data resolution and covariance, the estimated model, data
misfits, and the geodetically determined seismic moment. One may loop through
SENSIT using a varying number of singular values from the decomposition. This
permits the user to choose the optimal variance and resolution of the model.
Operation of the program requires the input of station coordinates,
line-length or strain data with standard deviations, and geometry of the fault
grid. One may also input constraints on the slip to be allowed in the model.
Output consists of all input values, the calculated model, data misfits, and
moment.
This report begins with a mathematical explanation of the program.
Because the data are treated as a linear function of the model, the matrix
equations are relatively simple. The math section shows how the model
constraints are entered into the data kernel matrix and the data vector. It
also explains the model and data-weighting, in addition to computations for
the fit of the model.
The portion of the report entitled INPUT consists of a line-by-line
description of a sample input file, 22KSCC.DAT. Each element required by the
program is defined. The section entitled OUTPUT, gives a list of the
information shown in the sample output file, 22KSCC.OUT. Brief instructions
are also provided to show the user how to run this FORTRAN program on the
VAX/VMS 785. The last section contains a printout of the FORTRAN program
INVERSE.FOR, the sample input file, 22KSCC.DAT, and the sample output file,
22KSCC.OUT.
MATHEMATICAL METHOD
The object of the FORTRAN program INVERSE.FOR is to solve the discretized
linear matrix problem
Y = [A] x X (1)
for the unknown (mxl) model vector X, given the (nxl) data vector, Y, and the
(nxm) Green's function matrix [A]. Treatment of this basic problem is found
in many linear algebra texts (e.g. Strang, 1976, Lanczos, 1961). We assume
that measurements at the earth's surface, Y, may be explained by some
distribution of strike-slip motion on the fault plus a component of normal
strain, which together form elements of the model vector, X. The "formal"
inverse solution, in the discrete form, is
*est = [A]' 1 x Y (2)
where [A]-l is the inverse of [A], and Xest is an estimate of the solution.
In order to solve the inverse problem, (2), we need to specify the data
kernel, [A], which relates behaviour on the fault to behaviour on the earth's
surface. We begin by treating the fault as a 2-dimensional fault plane
consisting of discrete dislocations in a homogeneous, isotropic, elastic,
half-space. (Chinnery, 1961). The centers of the discrete dislocations are
arranged in a rectangular grid pattern which we call the fault grid.
Individual rectangular elements in this grid are referred to as blocks. Slip
is constant in each block. The bottom of the fault grid is referred to as the
transition depth. Below this depth the slip rate is assumed to be constant,
both in space and time. To the left of the fault grid, down to the transition
depth, the slip rate is also assumed constant. This simulates a freely
creeping zone. To the right, the slip is assumed to be zero, simulating a
completely locked portion of the fault. (See Figure 1.) Only strike-slip
motion on the fault plane and a component of normal strain are modelled.
If there is auxiliary information available, such as near fault surface
slip data, which we desire to strongly influence the model in certain blocks,
we may accomplish this by adding elements to the data vector Y and to the data
kernel, [A]. For each of the nff (number of constrained) model blocks, one
row with an appropriate distribution of 1's and O's is added to the data
kernel matrix, after the first n rows of Chinnery functions. The
corresponding slip value for each constrained block is added as an element to
the data vector. Y then becomes an (n+nff x 1) vector of displacement
measurements and [A] becomes an (n+nff x m) dimensioned data kernel.
In order to solve equation (2), we use the generalized or, Lanczos
inverse, [A]L to operate on the data vector, y (Lanczos, 1961). For our
case, which is a mixed-determined problem, the Lanczos inverse simultaneously
minimizes the length of the model vector, X 2 an d the length of the
residual vector |e |2 where
e 2 = (Y - [A] x X) 2 (3)
The mixed-determined problem assumes that for some model elements there
is more than one data element resolving that area while for other model
elements there are no data elements which are capable of resolving the slip
distribution. In the overdetermined regions of the model, a least-squares fit
to the data is used. Simultaneously, the underdetermined regions of the model
are solved for with the help of some a-priori assumption, such as minimum
model length, or smoothness, or closeness of fit to a prior model.
An efficient way of obtaining the Lanczos inverse of the data kernel, and
at the same time neatly splitting the data kernel into underdetermined and
overdetermined parts is to use the singular value decomposition approach
(s.v.d.). Any (n x m) matrix, [A] may be decomposed into 3 matrices [U], an
(nxn) square matrix of eigenvectors which span the data space of [A], an (nxm)
matrix, [A], consisting of the singular values of [A] on the diagonal with
zeroes elsewhere, and an (mxm) square matrix V-transpose, [V]t containing
the eigenvectors spanning the model space.
CA] = [U] x [A] x [V]t (4)
This is referred to as the singular value decomposition (s.v.d.) of the matrix
[A].
The singular value matrix, [A], may be split into two parts, a (pxp) part
with non-zero singular values on the diagonal, [A]p and an (n-p x m-p) part
with zero singular values, CA]Q. Correspondingly, the data eigenvector
matrix splits into [U]p and [UJ 0 and the model eigenvector matrix [V]p
and [V] 0 . This split is important because it tells us what we can and
cannot determine about the model from the data. All of the information to be
derived from the matrix [A] is contained in the three matrices [U] p , [A! P
and [V] p . The other three matrices, [U] 0 , [A] 0 and [V] 0 are
orthogonal to the p-space, and lie in the null space of the data kernel.
An inverse, so-called the Lanczos or generalized inverse, [A]L may be
formed
[A]L = [V] x [A]-l x [U]t (5)
where [A]-l is the inverse matrix of [A] and [U]t is the transpose matrix
of [U]. One can solve the inverse problem for the estimated model parameters,
xest»
xest = CA]- L x Y (6)
= [V] x [A]-l x [U]t x [Y] (7)
As discussed above, [A] can also be constructed as
[A] = [U]p x [A]p x [V]j5, (8)
so we can also form
xest = [V] p x [A]pl x [U]f x Y (9)
As mentioned previously, the Lanczos inverse simultaneously minimizes the
data residual and the length of the model vector. Such solutions are called
"minimum-length" solutions. Another assumption may be made about the nature
of the "underdetermined" regions of the model; one can require that the
solution across such regions is as smooth as possible. This is a desired
characteristic, as it ties some of the more poorly determined fault-grid
blocks to the better known boundary constraints, such as the shallow
slip-rates and the long term deep slip-rate.
In the smooth case what we minimize is the length of the second
derivative of model parameters, rather than the model parameters themselves.
This leads us to minimize
[Tm] x X 2 (10)
where Tm is an m x m matrix of Laplacian operators. (Menke, 1984). By using
this model weighting matrix, Tm , the model estimate resulting from the
Lanczos inverse becomes a smooth model. The "overdetermined parts of the
model are still best fits to the data while the "underdetermined" parts now
smoothly blend into the better determined regions.
The new equations for X 1 which is the new weighted version of the model
vector, X and for Y 1 which is the new weighted version of the data vector, Y
are:
X 1 = [Tm] x X (11)
Y 1 = [Td ] x Y. (12)
Tm is the smoothing matrix for the model and Td is a data weighting matrix
in which each data element is weighted by the inverse of the standard
deviation of that element.
Y 1 = [A 1 ] x [X 1 ] (13)
with
The data resolution, which maps the observed data into the calculated data is
and the model covariance, which provides error bars on the model is
can be compared with its expected variance, a(Y") x [\]'- 2 , for each
singular value, to determine which elements exceed their expected
uncertainties. Because the matrix [cov Y"] is just the identity matrix, we
end up comparing chekmod with the inverse of the smallest singular value.
When chekmod is greater than this value, it has exceeded its expected
uncertainty.
The elements which are not included in the sum are the deep slip, the slip in
the left-hand block, and the normal strain component.
Two statistical parameters which are useful to calculate are the misfit
of the data to the model, *2, and the root mean square standard deviation of
the model elements. The misfit, or *2 is given by
((o(i)-c(i))/C(i)) 2 (23)
over all lines
where o(i) is the observed data measurement, c(i) is the calculated data
measurement, and C(i) is the standard deviation of that line. The root mean
square standard deviation of the model parameters, rmsstdev is defined as
*DISMARK1*
Mark-to-mark distance (meters)
Note this is not used in the program.
*DISTAN*
Arc-distance (meters)
*SD*
Standard deviation of the line-length change (meters)
Second card in the pair
*NET*
*SN1*
*SN2*
*DATE*
*AZ*
*DISMARK2*
Mark-to-mark distance of the second distance measurement (meters)
*DIST2*
Arc-distance of the second distance measurement (meters)
*SD*
14
The following cards in the input file are used to set up the fault grid model
Fault blocks can be specified in 3 ways by defining "kode"
1 = one endpoint, azimuth, length
2 = two endpoints
Each line in the input is for a different fault block or fault-grid block
geometry. The fault information to be input in each line is:
format(3i4,4x,8f8.0)
*KODE*
A number (1,2,3,4) as defined above
*NHE*
The number of horizontal elements in the grid
(NHE = 0 if kode is not 4)
*NVE*
The number of vertical elements in the grid
(NVE = 0 if kode is not 4)
*DU*
The depth to the top of the fault block (or grid) in kilometers
*DL*
The depth to the bottom of the fault partition in kilometers
*AZ*
Azimuth from north, in degrees
*LENGTH*
Total fault length in kilometers
If kode = 3 then fault half-length
*X1*
Endpoint coordinate (meters)
If kode = 3 then midpoint coordinate
*Y1*
Endpoint coordinate (midpoint if kode = 3)
*X2*
*Y2*
15
After reading in the fault model parameters, the next NFF lines are the model
slip constraints.
Each line consists of:Ki4,2el2.4)
*INDEX*
The block number which is assigned fixed slip
*CONSRAT
The constrained slip value in meters/year
*CONSWT*
The standard deviation of the constraint (meters/year)
Block 2 6 10 14
Creeping zone
[constant slip) 3 7 11
Locked zone
15
(no slip)
Block 1
4 8 12 16
5 9 13 17
Transition depth
Increasing
depth
Block 18
1 '*/ Cr° SS section of tne fau1 t. To the left of the fault grid, In
i *Je -5 ^ constant, equal to the creep in that region. To the
betwn th^fSn?' ? e f? UU ! S 10Cked and there is n° S11'P- The 11ne runni "9
between the fault plane (consisting of Blocks 1 to 17 and the locked zone) and
"*
17
OUTPUT DESCRIPTION
The output file (see Appendix B for an example) reproduces the input
file, then shows the calculated block coordinates and lists the assigned
constraints. In detail, this includes:
REFERENCES
Chinnery, M.A. (1961), "The deformation of the ground around surface faults."
Bull. Seism. Soc. Am. 51, 355-372.
Harris, R., and P. Segall (1985), "Determination of the slip deficit along the
Parkfield CA section of the San Andreas fault from the inversion of
trilateration data." EOS Trans. AGU (abstract), 46, 985.
King, N.E., Prescott, W.H., and K.J. Wendt, Unpublished line-length record
information. August 1983, revised January 1984.
Segall, P., and R. Harris (1986), "Slip deficit on the Parkfield, California
section of the San Andreas fault as revealed by inversion of geodetic
data." Science, in press.
Strang, G. (1976), Linear Algebra and its Applications. Academic Press, New
York, New York.
20
APPENDIX A
0 134 45 23 14 Parkfield
airway x = 372863.34 y - 205517.50 meters cal zone
almond x - 387280.44 y = 230311.04 meters cal zone
barren x - 376124.53 y - 219925.67 meters cal zone
bench x = 397009.41 y - 251596.36 meters cal zone
blhllres x = 352361.27 y = 209785.62 meters cal zone
bonnie x = 405248.78 y = 266058.53 meters cal zone
castle x - 398499.18 y = 273018.53 meters cal zone
chiches2 x - 396029.12 y = 212436.47 meters cal zone
cotton x = 408764.94 y = 256002.59 meters cal zone
davis x = 356267.64 y « 195729.09 meters cal zone
gold x - 397333.49 y = 261032.85 meters cal zone
hatch x = 412537.33 y = 244618.21 meters cal zone
hopper x = 394082.18 y = 243719.35 meters cal zone
kenger x = 397814.27 y - 270235.58 meters cal zone
mason x = 388953.45 y = 261439.02 meters cal zone
mid f x = 382038.42 y - 271317.48 meters cal zone
mine mt x - 390064.12 y - 276596.15 meters cal zone
mine rm2 x - 390064.39 y = 276599.84 meters cal zone
park x - 401440.70 y = 268212.82 meters cal zone
red hill x = 404862.12 y - 235801.52 meters cal zone
shade x = 367312.91 y = 284025.23 meters cal zone
tess x = 364621.55 y - 212466.02 meters cal zone
wild x = 386399.82 y = 253809.22 meters cal zone
sanlu + airway barren 79.487 6 14772.850 0.0006 0.0018 11.3
sanlu + airway blhllres 80.613 5 20942.138-0.0007 0.0013 280.3
sanlu + airway chiches2 79.495 6 24165.589 0.0005 0.0013 72.1
sanlu + airway davis 80.543 5 19268.005-0.0031 0.0026 237.9
sanlu + airway tess 80.603 5 10780.267-0.0008 0.0009 308.7
sanlu + almond barren 79.500 6 15242.453-0.0013 0.0009 225.7
sanlu + almond bench 79.128 7 23402.636-0.0037 0.0011 23.2
sanlu + almond chiches2 79.499 6 19901.080-0.0009 0.0011 152.5
sanlu + almond red hill 81.929 23 18418.864 0.0012 0.0016 71.3
sanlu + barren chiches2 79.489 6 21268.287 0.0012 0.0011 109.3
sanlu + barren tess 79.820 5 13710.150-0.0014 0.0009 235.5
sanlu + bench bonnie 77.421 8 16643.001-0.0052 0.0006 28.3
21
sanlu + bench cotton 76.521 17 12553.207 0. 0031 0.0004 68.2
sanlu -1- bench gold 82.364 4 9441.189-0. 0058 0.0027 0.6
sanlu -I- bench hatch 78.857 10 17023.263 0. 0059 0.0008 113.0
sanlu +red bench hopper 77.753 6 8402.882-0. 0021 0.0009 199.0
sanlu + bench kenger 76.522 17 18654.694-0. 0076 0.0011 1.1
sanlu + bench mason 76.744 14 12718.058 0. 0017 0.0006 319.3
sanlu -I- bench red hill 78.641 10 17638.621-0. 0006 0.0008 152.3
sanlu + bench wild 78.446 5 10837.091 0. 0014 0.0006 280.4
sanlu -I- blhllres davis 80.371 4 14589.692-0. 0011 0.0013 162.9
sanlu -1- blhllres tess 80.614 5 12550.087-0. 0016 0.0016 76.1
sanlu + bonnie cotton 78.134 7 10651.863-0. 0031 0.0010 159.5
sanlu + bonnie gold 78.462 5 9374.990-0. 0007 0.0005 236.3
sanlu + bonnie kenger 78.134 7 8526.553-0. 0007 0.0005 298.0
sanlu + bonnie mason 77.418 8 16935.680 0. 0053 0.0006 252.9
sanlu + castle shade 77.549 10 32455.025 0. 0172 0.0013 288.1
sanlu -1- chiches2 red hill 79.489 6 24979.096-0. 0036 0.0013 19.4
sanlu + cotton gold 78.703 6 12488.113 0. 0004 0.0011 292.4
sanlu + cotton kenger 78.301 9 17956.211-0. 0021 0.0013 321.1
sanlu + cotton mason 76.040 17 20541.974 0. 0108 0.0009 284.0
sanlu + cotton red hill 80.384 27 20573.730-0. 0073 0.0010 189.7
sanlu -1- davis tess 83.315 3 18706.194 0. 0031 0.0035 24.9
sanlu + gold kenger 78.703 6 9214.194-0. 0026 0.0014 1.7
sanlu -I- hatch red hill 76.206 18 11688.836-0. 0024 0.0004 219.8
sanlu +red hopper mason 78.475 5 18445.590 0. 0024 0.0008 342.5
sanlu -l-red hopper red hill 80.940 4 13375.042-0. 0004 0.0024 124.9
sanlu +red hopper wild 78.466 5 12680.805 0. 0022 0.0008 321.3
sanlu + kenger mason 76.573 17 12484.315-0. 0022 0.0005 223.9
sanlu -1- kenger mid f 80.474 8 15682.504 0. 0076 0.0010 272.6
sanlu + mason mine rm2 77.274 15 15196.422-0. 0099 0.0007 2.8
sanlu + mason wild 78.471 5 8045.069-0. 0023 0.0006 197.1
sanlu + mid f mine mt 79.127 10 9482.293 0. 0023 0.0011 55.3
sanlu + mine mt shade 77.811 21 23304.541 0. 0186 0.0007 286.6
sanlu + park red hill 78.153 27 32504.094-0. 0086 0.0007 172.7
1 0 0 0. 22. 319.3 100. 379999. 280068. 000000. 000000,
4 12 11 0. 22. 139.3 36. 379999. 280068. 000000. 000000,
3 0 0 22. 1000. 139.3 11
1000. 379999. 280068. 000000. 000000,
1 2.51e-02 l.Oe-05
2 2.4e-02 l.Oe-05
13 2.2e-02 l.Oe-05
24 2.2e-02 l.Oe-05
35 1.8e-02 l.Oe-05
46 1.6e-02 l.Oe-05
57 1.4e-02 l.Oe-05
68 1.2e-02 l.Oe-05
79 l.le-02 l.Oe-05
90 0.9e-02 l.Oe-05
101 0.8e-02 l.Oe-05
112 0.6e-02 l.Oe-05
123 0.4e-02 l.Oe-05
134 3.3e-02 l.Oe-05
0
22
APPENDIX B
CONSTRAINTS:
'S: RATE AND STANDARD DEVIATION (M/YR
for block 1 rate = 0.2510E-01+/- 0.1000E-04
for block 2 rate - 0.2400E-01+/- 0.1000E-04
for block 13 rate = 0.2200E-01+/- 0.1000E-04
for block 24 rate - 0.2200E-01+/- 0.1000E-04
for block 35 rate - 0.1800E-01+/- 0.1000E-04
for block 46 rate = 0.1600E-01+/- 0.1000E-04
for block 57 rate = 0.1400E-01+/- 0.1000E-04
for block 68 rate = 0.1200E-01+/- 0.1000E-04
for block 79 rate - 0.1100E-01+/- 0.1000E-04
for block 90 rate - 0.9000E-02+/- 0.1000E-04
for block 101
.01 rate = 0.8000E-02+/- 0.1000E-04
for block 112
.12 rate = 0.6000E-02+/- 0.1000E-04
for block 123
23 rate = 0.4000E-02+/- 0.1000E-04
for block 134
34 rate = 0.3300E-01+/- 0.1000E-04
26
APPENDIX C
x3=0
kk=i
c
c
c al,a2,a3,a4 are displacement components in the ul-direction
c bl,b2,b3,b4 u2-direction
c cl,c2,c3,c4 u3-direction
c dl,d2,d3,d4 are the strain components in the 1-direction
c fl,f2,f3,f4 2-direction
c hl,h2,h3,h4 12-direction
c sdx is the total displacement in the x-direction (parallel fault)
c sdy y-direction (perpendicular)
c sdz z-direction (vertical)
c
call chinssl (slip,-fx(kk),y(kk),x3,+al,+dl,al,bl,cl,dl,fl,hl)
call chinssl (slip,+x(kk) ,y(kk),x3,+al,+du,a2,b2,c2,d2,f2,h2)
call chinssl (slip,+x(kk),y(kk) ,x3,-al,-Kll,a3,b3,c3,d3,f3,h3)
call chinssl (slip,+x(kk) ,y(kk),x3,-al,+du,a4,b4,c4,d4,f4,h4)
sll=(dl-d2-d34d4)*1000.
s22=(fl-f2-f3+f4)*1000.
Sl2=(hl-h2-h3+h4)*1000.
c
sdx(i)=al-a2-a3+a4
sdy(i)=bl-b2-b3+b4
sdz=cl-c2-c3+c4
c
106 continue
c
c compute line length changes due to current fault.
c
if (nlines.eq.O) go to 112
do 104 j=l,nlines
c
do 103 1-1,2
keep(i) = 0
do 102 k=l,nstns
if (sn(i,j).ne.sta(k)) go to 102
keep(i)~k
kk=keep(i)
go to 101
102 continue
101 continue
dx(i)=sdx(kk)
dy(i)=sdy(kk)
103 continue
c
35
c
dist = dist + deltal(j,jf)
c
c
104 continue
112 continue
c
c********************************************************
c
c express station displacements in ns-ew coord system.
c save station displacements due to current fault before
c obtaining next one.
c
call crd(jf,sdx,sdy,nstns,nf,az,0.,0.,proje,projn)
do 114 it=l,nstns
stamovx(it,jf)=sdx(it)
stamovy(it,jf)=sdy(it)
114 continue
c
c************************************************
c ..........................
if(jf.lt.nf) go to 107
c
c end of loop
c *********************************************************
36
c
c add to 1st nf rows of green 1 column representing the strain component
c perpendicular to the fault
c alpha = angle of the fault parallel axis counterclockwise from north
c
if(nstrain.ne.2) go to 313
alpha = 180.0 - azs(nf)
do 312 i=l,nlines
omega(i) - (90.0 - (azi(i) + alpha)) * dtr
green(i,nfplusl)=distan(i)*1.0e-06*cos(omega(i))*cos(omega(i))
312 continue
c
c
c add lines to green's funcs for the nff constrained segments
c
313 if(nff.eq.O) go to 310
c
c set nlines+1 to nlines+nff rows of the data kernel to zeros
do 304 i=nlines+l,nlines+nff
do 305 j=l,nfplusl
green(i,j)=0.0
305 continue
304 continue
c
c
c read constraints and standard deviations (rates in m/yr)
c
write(6,519)
do 306 1-1,nff
read(5,615)index,consrat,conswt
write(6,521) index,consrat,conswt
green(nlines+i,index) -1.0
str(nlines+i) « consrat
sd(nlines+i) = conswt
306 continue
c
310 continue
c
c
c Form data weight matrix - weight by 1/variance of each datum
c *****************************************************************
do 300 i=l,lindex
do 301 j-l,llndex
if(i.eq.j) td(i,j) - 1.0/sd(i)
if(i.eq.j) tdinv(i,j) - sd(i)
if(i.ne.j) td(i,j) - 0.0
if(i.ne.j) tdinv(i,j) - 0.0
301 continue
300 continue
c
c Form model weigting subroutine
(*************************;
CALL MODELWT(NF,NFPLUSl,NFDIM,TM,TMT,NVET,NHET,RATIO,NWT)
38
stop
end
40
c
c SUBROUTINES CALLED BY INVERSE
c ***********************************************
c ***********************************************
c GETINT
c
c converts a string answer to an integer provided the string
c is not blank....
c ques = question to be asked
c intdefault = default answer
c int » integer answer
c
subroutine getint(ques,intdefault,int)
c
integer int, intdefault
character*(*) ques
character*10 default, ans, fmt
character bel*l
parameter (bel-char(7))
c
write(default,'(ilO) f ) intdefault
call 1just(default)
lengdef = lentrue(default)
c
lengq = lentrue(ques)
10 print f (/,lh$,a) f
& ques(1:lengq)//': ['//default(Itlengdef)//'] '
read (*,'(a)') ans
leng = lentrue(ans)
if(leng.eq.O) then
int = intdefault
else
write(fmt,'(a,i3,a) f ) '(i f leng, ')'
read(ans(1:leng),fmt,err=90) int
endif
c
return
c
c.....error message
90 print f (/,lx,a) f ,
&'*** error, expecting an integer answer... try again...'
print *, bel
goto 10
end
c
c
41
c ***********************************************
c MODELWT
c
c subroutine to calculate model-weight matrix
c for second differences (laplacian) in two dimensional inverse
c
SUBROUTINE MODELWT(NF,NFPLUS1,NFDIM,D,DT,NVE,NHE,RATIO,NWT)
c
DIMENSION d(nfdim,l),dt(nfdim,l)
dimension xpartd(500,500), ypartd(500,500)
c
c
c nf=number of faults
c nhe^number of horizontal elements in grid
c nve=number of vertical elements in grid
c ngrid=number of elements in grid
c nuprhs^upper r.h. block in grid
c nlrhs=lower r.h. block in grid
c ratioKLength/height of blocks in grid=dx/dy
c nwt=l if no model-weighting is desired,
c nvt-2 if smoothing is desired
c
RATIOSQ - RATIO * RATIO
NGRID - NHE * NVE
NUPRHS - NGRID - NVE -I- 2
NLRHS - NGRID + 1
C
C IF NO MODEL-WEIGHTING IS DESIRED, ASSIGN MODEL-WEIGHTING
C MATRIX, [D], TO BE THE IDENTITY MATRIX
C
IF(NWT.EQ.1)GO TO 500
C
C INITIALIZE ARRAY ELEMENTS
DO 5 I=l,NLRHS+2
DO 5 J=l,NLRHS+2
XPARTD(I,J) =0.0
YPARTD(I,J) - 0.0
D(I,J) - 0.0
5 CONTINUE
C
C TO LEFT EDGE OF GRID ASSIGN XPART OF LAPLACIAN
DO 10 I - 2,NVE+1
XPARTDU,!) - + 1.0
XPARTD(I,I) - - 2.0
XPARTD(I,I+NVE) - + 1.0
10 CONTINUE
C
C TO RIGHT EDGE OF GRID ASSIGN XPART OF LAPLACIAN
DO 20 I - NUPRHS,NLRHS
XPARTDU,I-NVE) - + 1.0
XPARTD(I,I) - - 2.0
20 CONTINUE
C
42
C TO TOP ASSIGN YPART OF LAPLACIAN
DO 30 I = 2,NUPRHS,NVE
YPARTD(I,I) = - 1.0
YPARTD(I,I-H) - + 1.0
30 CONTINUE
C
C TO BOTTOM ASSIGN YPART OF LAPLACIAN
DO 40 I = NVE+1,NLRHS,NVE
YPARTD(I,I-1) = + 1.0
YPARTD(I,I) = - 2.0
YPARTD(I,NGRID+2) = + 1.0
40 CONTINUE
C
C ASSIGN XPARTS TO ALL PREVIOUSLY UNASSIGNED
C (EXCLUDE LEFT & RIGHT EDGES)
DO 100 I - NVE+2, NLRHS-NVE
XPARTD(I,I-NVE) = + 1.0
XPARTD(I,I) = - 2.0
XPARTD(I,I+NVE) = + 1.0
100 CONTINUE
C
C ASSIGN YPARTS TO ALL PREVIOUSLY UNASSIGNED
C (EXCLUDE TOP & BOTTOM EDGES)
K - 3
150 L = K + NVE - 3
DO 200 I - K,L
IF(I.GT.NLRHS) GO TO 250
YPARTD(I,I-1) = + 1.0
YPARTD(I,I) = - 2.0
YPARTD(I,I+1) = + 1.0
200 CONTINUE
K = K + NVE
GO TO 150
C
C ADD XPART & YPART OF LAPLACIAN TO FORM D(I,J)
C WEIGHT SMOOTHING FOR NON-SQUARE BLOCKS
250 DO 300 I = 1,NLRHS+1
DO 300 J = 1,NLRHS+1
D(I,J) - XPARTD(I,J) + RATIOSQ*YPARTD(I,J)
300 CONTINUE
c
C ASSIGN D(I,J) TO 2 SIDE CONSTRAINTS AND TO THE STRAIN COMPONENT
D(l,l) = 1-0
D(NLRHS+1,NLRHS+1) =1.0
D(NFPLUS1,NFPLUS1) =1.0
GO TO 700
C
500 DO 600 I=1,NFPLUS1
DO 600 J=1,NFPLUS1
IF(I.EQ.J) D(I,J)=1.0
IF(I.NE.J) D(I,J)=0.0
600 CONTINUE
C
C
43
900 continue
C
return
end
c
c
c
C
c CRD
c translates and rotates coordinates to fault-centered system, with x parallel
c to fault.
c
c called from inverse
c
subroutine crd(jf ,x,y,n,nf ,azi,fx,fy,proje,projn)
dimension x(n),y(n) ,proje(n) ,projn(n)
alpha- ( 90. -azi)*2.*3. 1415927/360.
c-cos( alpha)
s=s in (alpha)
do 20 i=l,n
xx=x(i)-fx
yy=y(i)-fy
x(i)=xx*c+yy*s
y(i)=+xx*s-yy*c
20 continue
c
if(jf.ne.nf)go to 30
do 25 i-l,n
proje(i)=-y(i)*sin (-alpha)
pro jn(i)=-y(i)*cos (-alpha)
25 continue
c
30 continue
return
end
44
c ************************************************
c FMODEL
subroutine fmodel(nf,nff,nfdim,als,dus,dls,azs,fxs,fys,
+ . nve,nhe,elarea,ratio)
c
c this subroutine reads fault cards and calculates
c elements required by inverse,
c faults can be specified in 3 ways:
c one endpoint, azimuth, length
c two endpoints
c midpoint, azimuth, half-length
c subroutine returns midpoint, azimuth, and half-length to inverse.
c .........................
c
c variables:
c
c kode = l=one endpoint, azimuth, length
c 2=both endpoints
c 3=midpoint, azimuth, half-length
c 4=grid; one endpoint azimuth length
c nhe - number of horizontal elements, used for kode=4
c nve = number of vertical elements, used for kode=4
c du = depth to top (km)
c dl = depth to bottom (km)
c az = azimuth (from 1 to 2)
c length = total fault length (km), or half-length if kode=3
c xl,yl,x2,y2 = end pt coordinates (m), or (xl,yl) asmidpt if kode=3
c al = half length (km)
c fx,fy = mid pt coordinates (m)
c
real length
data dtr/0.01745329/
dimension als(nfdim),dus(nfdim),dls(nfdim)
dimension azs(nfdim),fxs(nfdim),fys(nfdim)
c
k=0
c
c read model parameters
c
700 read(5,617) kode,nhe,nve,du,dl,az,length,xl,yl,x2,y2
write(6,523)
write(6,525) kode,nhe,nve,du,dl,az,length,xl,yl,x2,y2
c
go to (1,2,3,4) kode
c
c **************************************
c one endpoint, azimuth, length
c **************************************
1 angle = az * dtr
al - length/2.
fx = xl -l- al * sin(angle) * 1000.
fy = yl + al * cos(angle) * 1000.
go to 5
c **************************************
45
c two endpoints
c **************************************
2 continue
fx = 0.5 * (xl + x2)
fy - 0.5 * (yl + y2)
dx = x2 - xl
dy = y2 - yl
al = sqrt(dx*dx + dy*dy) / 2000.
az = atan2(dx,dy)/dtr
if ( az .It. 0.0 ) az - az + 360.
go to 5
c *************************************
c midpoint, azimuth, half-length
c *************************************
3 fx=xl
fy-yi
al=length
go to 5
c *************************************
5 k=k+l
als(k)=al
dus(k)=du
dls(k)=dl
azs(k)=az
fxs(k)=fx
fys(k)=fy
c
if(k.eq.nf) go to 1000
if(k.lt.nf) go to 700
c *************************************
c gridded fault elements
c *************************************
4 continue
c
write(6,527) nhe
write(6,529) nve
nhesave=nhe
nvesave=nve
ngf=nhe*nve
deltalen=length/float(nhe)
deltaht=(dl-du)/float(nve)
ratio=deltalen/deltaht
elarea=deltalen*deltaht*l.Oe+10
azrads=(180-az)*3.14159/180.0
deltax=1000*deltalen*sin(azrads)
deltay=1000*deltalen*cos(azrads)
xstart=xl-0.5*deltax
ystart=y1+0.5*deltay
gdu=du
46
do 600
fxaBxstart+j*deltax
fyssystart-j*deltay
do 500 i=l,nve
k=k+l
du=gdu + (i-l)*deltaht
dl=gdu + i*deltaht
als (k) !BdeltaIen/2.0
dus(k)=du
dls(k)=dl
azs(k)~az
fxs(k)=fx
fys(k)=fy
500 continue
600 continue
c
if(k.lt.nf) go to 700
c
c *************************************
c print computed elements
1000 continue
write(6,531)
write(6,533)
do 1100 1-1,nf
write(6,535) dus(i),dls(i),azs(i),als(i),fxs(i),fys(i)
1100 continue
c
c
nve - nvesave
nhe - nhesave
c
c read and write format statements
c
523 format(//lx, f INPUT MODEL GRIDDING')
525 format(lX,3i4,4x,8f8.0)
527 format(/lx,*# of horizontal elements in grid - f ,i4)
529 format(lx,*# of vertical elements in grid - f ,i4)
531 format(/lx, f MODEL PARAMETERS 1 )
533 format(4x, f du(km) f ,2x, f dl(km) f ,2x, f az f ,3x,
+ f hfIn(km) f ,lx, f xl(m) f ,lx, f yl(m) f )
535 format(4f8.1,2f8.0)
617 format(314,4x,8f8.0)
c
return
end
c
c
47
c SENSIT
subroutine sensit (v,a,aprime,ut,sinval,wk,workar,
+ u,td,tdinv,tm,tminv,prodl,prod2,
+ prod3,resolv,datares,sinvalm2,sinvalml,
+ covm,utnew,c,estmodl,str,nldim,nfdim,
+ NFPLUSl,nlines,nf,nvf,nff,
+ datacalc,sd,dmisfit,sdmod,Istsig,sn,
+ nstart,numrun,lindex,vnew,chekmod,
+ nhe,nve,elarea,slipco,sta,
+ stamovx,stamovy,nstns,stndispx,stndispy,
+ stndisp,proje,projn)
c
c Computes the u,v and s matrices of a singular value decomposition,
c Prints out singular values.
c Also calculates model-resolution, covariance, and
c estimated model, and data resolution
c Does calculations which keep a varying number of singular values,
c Can compare chekmod and 1/smallest singval to decide how many
c singular values to keep- want chekmod | I/smallest singular value,
c
c Notes: nlines - number of baselines
c nf total number of faults (fixed + variable)
c nff - number of fixed faults
c nvf - number of variable faults
c a Greens func array in main program (unrotated)
c aprime " Greens func array in Sensit (rotated space)
c
dimension a(nldim,l),aprime(nldim,!),v(nldim,l)
dimens ion ut(nldim,1),sinval(1),wk(1)
dimens ion u(nldim,1),workar(nldim,1),resolv(nfdim,1)
dimension td(nldim,1),tdinv(nldim,1),tm(nfdim,1)
dimension tminv(nfdim,l),prodl(nfdim,!)
dimension prod2(nfdim,l),prod3(nfdim,l)
dimension sinvalml(nfdim),sinvalm2(nfdim)
dimension c(nfdim,1),covm(nfdim,1),utnew(nldim,1)
dimension estmodl(nfdim),str(nldim),npar(4)
dimension datares(nldim,!),datacalc(nldim),sd(nldim)
dimension dmisfit(nldim),sdmod(nfdim),slipco(nfdim)
dimension vnew(nldim,l),chekmod(nfdim),product(500)
dimension stamovx(nfdim,!),stamovy(nfdim,!)
dimension stndispx(nldim),stndispy(nldim)
dimension stndisp(2*nldim),proje(nldim),projn(nldim)
real*8 sn(2,nldim), sta(2*nldim)
c
c
c Weight (or 'transform') the data kernel A; A'=Td*A*Tm**-l
c
call vmulff(td,a,lindex,lindex,nfPLUSl,nldim,nldim,
+ prodl,nldim,ier)
call vmulff(prodl,tminv,lindex,nfPLUS1,nfPLUS1,
+ nldim,nfdim,aprime,nldim,ier)
cw call uswfm ('Rotated Greens func',19,aprime,nldim,
cw + lindex,nfPLUSl,3)
c
48
c Form singular value decomposition of aprime where A f =U*S*Vt
c note that U,S,and V are in transformed (primed) system
c Create a space to store V
do 1 i = l,lindex
do 1 j = l,nfPLUSl
v(i,j) = aprime(i,j)
1 continue
c
c create a space to put U, where Ut = U-transpose
do 45 i=l,lindex
do 42 j=l,lindex
if(i.eq.j) ut(i,j) = 1.0
if(i.ne.j) ut(i,j) = 0.0
42 continue
45 continue
c
c ** Call IMSL SVD routine to find aprime = u*s*vt **
c
call Isvdf (v,nldim,lindex,nfPLUSl,ut,nldim,
+ lindex,sinval,wk,ier)
write(6,541) lstsig,rmsstdev
541 formatClx/for'jiS,' singvals'/
+ 10x, f rms model st.dev=t ,e!2.4)
c
c
c
c ** calculate mest = Tm**(-l)*V * 1/sinval * Ut * Td *data **
c
619 do 16 i=l,lstsig
sinvalml(i) = sqrt(sinvalm2(i))
16 continue
cw call uswfm ('v-matrix',8,v,nldim,nfPLUSl,nfPLUSl,3)
cw call uswfm ( f u-matrixt f ,9,ut,nldim,lindex,lindex,3)
c
c only use first Istsig columns of v
do 442 i=l,nfPLUSl
do 446 j-1,Istsig
vnew(i,j) - v(i,j)
446 continue
442 continue
c
c only use first Istsig rows of ut
do 335 i = 1,Istsig
do 333 j = 1,lindex
utnew(i,j) = ut(i,j)
333 continue
335 continue
c
c form chekmod = sinvalml * utnew * td * data
c prodl = utnew * td
c product = prodl * data
c
call vmulff(utnew,td,Istsig,lindex,lindex,
+ nldim,nldim,prodl,nfdim,ier)
c
c
do 222 i-1,Istsig
product(i) =0.0
do 220 j=l,lindex
product(i) = product(i) + prodl(i,j)*str(j)
220 continue
222 continue
c
do 217 1-1,Istsig
chekmod(i) product(i) * sinvalml(i)
217 continue
c
51
c ******************************************************
c reformat model to plot on color graphics terminals
c
c add 2 extra columns of blocks to grid on l.h.s to
c replace large block
c add 3 extra rows of blocks to grid on bottom
211 nec=2
ner=3
c
index=l
c
do 300 i=l,nec
do 310 j=l,nve
slipco(index)=estmodl(l)
index=index+l
310 continue
do 320 k=l,ner
slipco(index)=estmodl(nf)
index=index+l
320 continue
300 continue
c
c
icount=2
do AGO i=l,nhe
do 410 j=icount,icount+nve-1
slipco(index)=estmodl(j)
index=index+l
410 continue
do 420 k=l,ner
slipco(index)=estmodl(nf)
index=index+l
420 continue
icount=j
400 continue
c
c
c CONVERT TO MILLIMETERS
c
ncol=nhe+nec
nrow=nve+ner
ncolel=ncol*nrow
do 900 i=l,ncolel
slipco(i)=1000*slipco(i)
900 continue
c
xo=0.0
yo=0.0
dx=3.0
dy=2.0
call outsg(lstsig,ncol,nrow,xo,dx,yo,dy,slipco)
53
c*****************************
c
c
c determine the calculated data using the model
c
c do 334 i=l,lindex
do 334 i»l,nlines
datacalcCi^O.O
do 334 j-l,nfPLUSl
datacalc(i) asdatacalc(i)+a(i,j)*estmodl(j)
334 continue
c
c ** determine the data misfits **
c ** « (obs. data - calc. data)i / st. dev. data point i **
c
do 339 i=l,nlines
dmisfit(i)= (str(i)-datacalc(i))/sd(i)
339 continue
c
c
c
c ** determine sum (misfits)sq. **
c ** « sum (dmisfit(i))sq. **
chisq^O.O
do 356 i=l,nlines
chisq » chisq + dmisfit(i)*dmisfit(i)
356 continue
write(6,543)chisq
543 format(lx,llx,'sum of, the misfits squared * *,el2.4)
c
c
c
c calculate moment rate and standard deviation
c do not include slip rates in first or last model elements
c shearmod =* shear modulus of medium (c.g.s)
c elarea *" area of grid elements (cm**2); returned from fmodel
c
c
shearmod ** 3.0e+ll
smoment =0.0
covmoment =0.0
do 448 l-2,nf-l
smoment = smoment + estmodl(i)
do 448 j-2,nf-l
covmoment = covmoment + covm(i,j)
448 continue
smoment = shearmod*elarea*smoment*100
sdmoment ** shearmod*elarea*sqrt(covmoment)*100
write(6,545) smoment, sdmoment
545 format(12x,'moment rate - f ,el2.4,2x,' +/- f ,2x,e!2.4)
c
c
54
c more writing routines
c
write(6,547) chekmod(lstsig),sinvalml(lstsig)
547 format(lx, f chekmod = ',e!2.4, f I/smallest sinval = f ,e!2.4)
write(6,549)
549 format(//24x,'obs data*,7x, f calc data*,5x,'(obs-calc)/sigma f )
do 444 i=l,nlines
write(6,551)(sn(j,i),j=l,2),str(i),datacalc(i),dmisfit(i)
551 format(lx,a8,lx,a8,4x,el2.4,4x,el2.4,4x,el2.4)
444 continue
c
write(6,553)
553 format(/// f ESTIMATED MODEL (M/YR) f )
write(6,555)
555 format(lx,'block slip(m/yr) st.dev.(m/yr)*)
do 447 i=l,nfplusl
write(6,557) i,estmodl(i),sdmod(i)
557 format(lx,i4,el2.4,3x,e!2.4)
447 continue
c
if(nfplusl.eq.nf) go to 560
WRITE(6,559) ESTMODL(NFPLUSl)
559 FORMATCIX,' THE EXTENSION-RATE PERPENDICULAR TO THE F.P. IS 1 ,
-I- E12.4,' MICRO-STRAIN/YR')
C
560 write(6,561)
561 formatC// 1 stn displacement (m)V
-I- 17x, f x-direc y-direc f )
do 458 i=l,nstns
write(6,563) sta(i),stndispx(i),stndispy(i)
563 format(lx,a8,4x,el2.4,4x,el2.4)
458 continue
c
c reformat stndisp to be 1 long vector w/ alternating x and y components
c for input to main!2
c
do 882 i=l,nstns
stndisp(2*i-l) = stndispx(i)
stndisp(2*i) = stndispy(i)
882 continue
c
do 881 i=l,2*nstns
write(85,565) stndisp(i),sta((i-KL)/2)
881 continue
565 format(e!2.4,a8)
c
c
884 continue
999 return
end
55
c
c CHINSSL
c fault displacements for chinnery strike slip fault model
c called from inverse
c
c ul,u2,u3 are the components of the displacement vector u(k)
c
subroutine chinssl (u,xl,x2,x3,pl,p3,ul,u2,u3,el,e2,el2)
r - sqrt((xl-pl)**2+x2**2+(x3-p3)**2)
rp - r + p3
f - 0.0
if(r.lt.l.e9) f K3.*r*rp-(3.*r+A.*p3)*(3.*r+p3))/(rp*r**3)
el=(u/25.1328)*(x2/rp**2)*(l.-(xl-pl)**2*f)
e2-(u/25.1328)*(x2/rp**2)*(l. -2.*(3.*r+A.*p3)/r-x2**2*f)
c e!2= (u/50.2656)^((xl-pl)/r)*(A.*p3/(x2**2+p3**2)-(7.*r+8.*p3)
c 1 /rp**2-x2**2*r*f/rp**2) +((xl-pl)/rp**2)*(l.-x2**2*f))
ud - u/50.2656
xlmpl = xl - pi
xlpldr = xlmpl/r
x2sq » x2**2
p3sq » p3**2
x2p3 « x2sq + p3sq
r78p3 = 7. *r + 8. *p3
p3xp - p3/x2p3
p3xpt4 - A. * p3xp
rpsq = rp**2
r78pdr = r78p3/rpsq
fdrpsq = f/rpsq
x2sqr = x2sq * r
xrfrp " x2sqr * fdrpsq
xlplrp = xlmpl / rpsq
x2sqf * x2sq * f
x2sql ~ 1. - x2sqf
yl = p3xptA - r78pdr
y2 yl - xrfrp
y3 - xlplrp * x2sql
yA « xlpldr * y2
y5 - yA 4- y3
e!2 - ud * y5
u2 - (u/25.1328)*(alog(rp) +p3/rp -x2**2*(3.*r+A.*p3)/(r*rp**2))
u3=(u/12.566A)*x2*(rp+p3)/(r*(r4-p3))
if (pS.eq.O.) p3-.00001
ul - (u/25.1328)*(-x2*(xl-pl)*(3.*r4-A.*p3)/(r*rp**2)
1 +A.*atan(x2*r/(p3*(xl-pl))))
return
end
56
c
c OUTSG
c
c Converts a grid file to Standard Grid Format for color plotting.
c
subroutine outsg(iter,ncol,nrow,xo,dx,yo,dy,array)
c
character*10 line, ques
parameter (line = '(/,lx,a)', ques = '(/,lh$,a)')
c
character filename*50, fileroot*50, idroot*50, id*56, pgm*8
character numb*4
real array(*), grid(500,500)
c
parameter (iout=22)
common/outsgntimes/ ntimes
ntimes « ntimes + 1
c
c..... Get info
if(ntimes.eq.l) then
print ques, ' Give root for SG filename: '
read '(a)', fileroot
print ques, ' Give title (45 chars): '
read '(a)', idroot
pgm - 'greform '
dummy = 0.0
nz = 1
iprj - 0
cm = 0.0
bl - 0.0
endif
c
c.....Open files.
write(numb,'(i4)') iter
call 1just(numb)
filename = fileroot(l:lentrue(fileroot))//numb(l:lentrue(numb))
& //'.sg'
open(iout,file=filename,form= l unformatted',status='new')
c
c..... Convert array to Standard Grid form
index=0
do 30 i = l,ncol
do 30 j - l,nrow
index=index + 1
30 grid(i,nrow-j+l) = array(index)
c
c.....Write out Standard Grid
id = idroot(l:lentrue(idroot))//'; iter = '//numb(1:lentrue(numb))
call wrheader(iout,id,pgm,ncol,nrow,nz,xo,dx,yo,dy,iprj,cm,bl)
do 50 j=l,nrow
50 write(iout) dummy,(grid(i,j), i=l,ncol)
close(iout)
return
end
57
c *********************************************************************
c LENTRUE
c called by GETINT, OUTSG
c
integer function lentrue(string)
c Gives position of last non-blank, non-tab, non-null
c character in string,
c Returns 0 if no such beast in string
c Programmed by R.Simpson - U.S.G.S.
c
character*(*) string
character*! blank, tab, null
parameter (blank88 * f , tab=schar(9), null=char(0))
c
lentrue^O
c
do 100 i=len(string),l,-l
if(string(i:i).ne.blank.and.
& string(i:i).ne.tab.and.
& string(i:i).ne.null) then
lentrue^i
return
endif
100 continue
c
return
end
c
C
c LJUST
c called by GETINT, OUTSG
c
subroutine 1just(string)
c Left justifies a string by eliminating blanks, tabs, nulls
c at left end of string,
c Programmed by R.Simpson - U.S.G.S.
c
character*(*) string
c
ifirst-leftend(string)
c
if(ifirst.le.l) then
return
c
else
12=len(string)-(ifirst-l)
string(l:12)=string(ifirst:ifirst+12-l)
string(12+l:len(string))= f f
endif
c
return
end
58
c **************************************************************
c WRHEADER
c called by OUTSG
c
subroutine wrheader (unit , id ,pgm,ncol ,nrow,nz ,
& xo,dx,yo,dy,iproj,cm,bl)
c
character id*56, pgm*8
integer unit
c
write (uni t ) id , pgm , ncol ,nrow ,nz , xo , dx , yo , dy , ipro j , cm , bl
c
return
end
c LEFTEND
c called by LJUST
c
integer function leftend(string)
c Gives position of first non-blank, non-tab, non-null
c character in string.
c Returns 0 if no such beast in string.
c Programmed by R.Simpson - U.S.G.S.
c
character* (*) string
character*! blank, tab, null
parameter (blank58 ' ', tab=char(9), null=char(0))
c
leftend=0
c
do 100 i=l,len(string)
if (string(i :i) .ne. blank. and.
& string(iri) .ne. tab. and.
& string (iri).ne.null) then
leftend=i
return
endif
100 continue
c
return
end
c