[cig-commits] commit: change source code to directory src/
Mercurial
hg at geodynamics.org
Sat Apr 7 17:03:47 PDT 2012
changeset: 74:e7295294f654
user: Sylvain Barbot <sbarbot at caltech.edu>
date: Sun Apr 01 14:02:51 2012 -0700
files: .hgignore ctfft.f elastic3d.f90 examples/tutorials/run1-pbs.sh examples/tutorials/run1.sh examples/tutorials/run2.sh examples/tutorials/run3.sh examples/tutorials/run4.sh export.f90 fourier.f90 friction3d.f90 getdata.f getopt_m.f90 green.f90 include.f90 input.f90 kernel1.inc kernel11.inc kernel14.inc kernel14bis.inc kernel7.inc mkl_dfti.f90 proj.c relax.f90 src/ctfft.f src/elastic3d.f90 src/export.f90 src/fourier.f90 src/friction3d.f90 src/getdata.f src/getopt_m.f90 src/green.f90 src/include.f90 src/input.f90 src/kernel1.inc src/kernel11.inc src/kernel14.inc src/kernel14bis.inc src/kernel7.inc src/mkl_dfti.f90 src/proj.c src/relax.f90 src/types.f90 src/viscoelastic3d.f90 src/writegrd3.4.c src/writegrd4.2.c src/writevtk.c types.f90 viscoelastic3d.f90 writegrd3.4.c writegrd4.2.c writevtk.c wscript
description:
change source code to directory src/
diff -r 405d8f4fa05f -r e7295294f654 .hgignore
--- a/.hgignore Thu Mar 29 15:55:33 2012 -0700
+++ b/.hgignore Sun Apr 01 14:02:51 2012 -0700
@@ -1,6 +1,6 @@ syntax: glob
syntax: glob
-relax
+.waf-1.6.8-*
*~
*.o
*.mod
@@ -12,10 +12,10 @@ examples/.gmtcommands4
examples/.gmtcommands4
examples/.gmtdefaults4
examples/.DS_Store
-examples/output1
-examples/output2
-examples/output3
-examples/output4
+examples/tutorials/output1
+examples/tutorials/output2
+examples/tutorials/output3
+examples/tutorials/output4
examples/mojave/coulomb
latex/relax.aux
latex/relax.blg
diff -r 405d8f4fa05f -r e7295294f654 ctfft.f
--- a/ctfft.f Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,618 +0,0 @@
- subroutine ctfft (data,n,ndim,isign,iform,work,nwork) fft 1
-c cooley-tukey fast fourier transform in usasi basic fortran. fft 2
-c multi-dimensional transform, dimensions of arbitrary size, fft 3
-c complex or real data. n points can be transformed in time fft 4
-c proportional to n*log(n), whereas other methods take n**2 time. fft 5
-c furthermore, less error is built up. written by norman brenner fft 6
-c of mit lincoln laboratory, june 1968. fft 7
-c fft 8
-c dimension data(n(1),n(2),...),transform(n(1),n(2),...),n(ndim) fft 9
-c transform(k1,k2,...) = sum(data(j1,j2,...)*exp(isign*2*pi*sqrt(-1)fft 10
-c *((j1-1)*(k1-1)/n(1)+(j2-1)*(k2-1)/n(2)+...))), summed for all fft 11
-c j1 and k1 from 1 to n(1), j2 and k2 from 1 to n(2), etc. for all fft 12
-c ndim subscripts. ndim must be positive and each n(idim) may be fft 13
-c any integer. isign is +1 or -1. let ntot = n(1)*n(2)... fft 14
-c ...*n(ndim). then a -1 transform followed by a +1 one fft 15
-c (or vice versa) returns ntot times the original data. fft 16
-c iform = 1, 0 or -1, as data is complex, real or the fft 17
-c first half of a complex array. transform values are fft 18
-c returned to array data. they are complex, real or fft 19
-c the first half of a complex array, as iform = 1, -1 or 0. fft 20
-c the transform of a real array (iform = 0) dimensioned n(1) by n(2)fft 21
-c by ... will be returned in the same array, now considered to fft 22
-c be complex of dimensions n(1)/2+1 by n(2) by .... note that if fft 23
-c iform = 0 or -1, n(1) must be even, and enough room must be fft 24
-c reserved. the missing values may be obtained by complex conju- fft 25
-c gation. the reverse transformation, of a half complex array fft 26
-c dimensioned n(1)/2+1 by n(2) by ..., is accomplished setting iformfft 27
-c to -1. in the n array, n(1) must be the true n(1), not n(1)/2+1. fft 28
-c the transform will be real and returned to the input array. fft 29
-c work is a one-dimensional complex array used for working storage. fft 30
-c its length, nwork, need never be larger than the largest n(idim) fft 31
-c and frequently may be much smaller. fourt computes the minimum fft 32
-c length working storage required and checks that nwork is at least fft 33
-c as long. this minimum length is ccomputed as shown below. fft 34
-c fft 35
-c for example-- fft 36
-c dimension data(1960),work(10) fft 37
-c complex data,work fft 38
-c call fourt(data,1960,1,-1,+1,work,10) fft 39
-c fft 40
-c the multi-dimensional transform is broken down into one-dimen- fft 41
-c sional transforms of length n(idim). these are further broken fft 42
-c down into transforms of length ifact(if), where these are the fft 43
-c prime factors of n(idim). for example, n(1) = 1960, ifact(if) = fft 44
-c 2, 2, 2, 5, 7 and 7. the running time is proportional to ntot * fft 45
-c sum(ifact(if)), though factors of two and three will run espe- fft 46
-c cially fast. naive transform programs will run in time ntot**2. fft 47
-c arrays whose size ntot is prime will run much slower than those fft 48
-c with composite ntot. for example, ntot = n(1) = 1951 (a prime), fft 49
-c running time will be 1951*1951, while for ntot = 1960, it will fft 50
-c be 1960*(2+2+2+5+7+7), a speedup of eighty times. naive calcul- fft 51
-c ation will run both in the slower time. if an array is of fft 52
-c inconvenient length, simply add zeroes to pad it out. the resultsfft 53
-c will be interpolated according to the new length (see below). fft 54
-c fft 55
-c a fourier transform of length ifact(if) requires a work array fft 56
-c of that length. therefore, nwork must be as big as the largest fft 57
-c prime factor. further, work is needed for digit reversal-- fft 58
-c each n(idim) (but n(1)/2 if iform = 0 or -1) is factored symmetri-fft 59
-c cally, and nwork must be as big as the center factor. (to factor fft 60
-c symmetrically, separate pairs of identical factors to the flanks, fft 61
-c combining all leftovers in the center.) for example, n(1) = 1960 fft 62
-c =2*2*2*5*7*7=2*7*10*7*2, so nwork must at least max(7,10) = 10. fft 63
-c fft 64
-c an upper bound for the rms relative error is given by gentleman fft 65
-c and sande (3)-- 3 * 2**(-b) * sum(f**1.5), where 2**(-b) is the fft 66
-c smallest bit in the floating point fraction and the sum is over fft 67
-c the prime factors of ntot. fft 68
-c fft 69
-c if the input data are a time series, with index j representing fft 70
-c a time (j-1)*deltat, then the corresponding index k in the fft 71
-c transform represents the frequency (k-1)*2*pi/(n*deltat), which fft 72
-c by periodicity, is the same as frequency -(n-k+1)*2*pi/(n*deltat).fft 73
-c this is true for n = each n(idim) independently. fft 74
-c fft 75
-c references-- fft 76
-c 1. cooley, j.w. and tukey, j.w., an algorithm for the machine fft 77
-c calculation of complex fourier series. math. comp., 19, 90, fft 78
-c (april 1967), 297-301. fft 79
-c 2. rader, c., et al., what is the fast fourier transform, ieee fft 80
-c transactions on audio and electroacoustics, au-15, 2 (june 1967). fft 81
-c (special issue on the fast fourier transform and its applications)fft 82
-c 3. gentleman, w.m. and sande, g., fast fourier transforms-- fft 83
-c for fun and profit. 1966 fall joint comp. conf., spartan books, fft 84
-c washington, 1966. fft 85
-c 4. goertzel, g., an algorithm for the evaluation of finite fft 86
-c trigonometric series. am. math. mo., 65, (1958), 34-35. fft 87
-c 5. singleton, r.c., a method for computing the fast fourier fft 88
-c transform with auxiliary memory and limited high-speed storage. fft 89
-c in (2). fft 90
- dimension data(*), n(1), work(*), ifsym(32), ifcnt(10), ifact(32) fft 91
- if (iform) 10,10,40 fft 92
- 10 if (n(1)-2*(n(1)/2)) 20,40,20 fft 93
- 20 continue
-c20 write (6,30) iform,(n(idim),idim=1,ndim) fft 94
-c30 format ('error in fourt. iform = ',i2,'(real or half-complex)'
-c $' but n(1) is not even./14h dimensions = ',20i5) fft 96
- return fft 97
- 40 ntot=1 fft 98
- do 50 idim=1,ndim fft 99
- 50 ntot=ntot*n(idim) fft 100
- nrem=ntot fft 101
- if (iform) 60,70,70 fft 102
- 60 nrem=1 fft 103
- ntot=(ntot/n(1))*(n(1)/2+1) fft 104
-c loop over all dimensions. fft 105
- 70 do 230 jdim=1,ndim fft 106
- if (iform) 80,90,90 fft 107
- 80 idim=ndim+1-jdim fft 108
- go to 100 fft 109
- 90 idim=jdim fft 110
- nrem=nrem/n(idim) fft 111
- 100 ncurr=n(idim) fft 112
- if (idim-1) 110,110,140 fft 113
- 110 if (iform) 120,130,140 fft 114
- 120 call fixrl (data,n(1),nrem,isign,iform) fft 115
- ntot=(ntot/(n(1)/2+1))*n(1) fft 116
- 130 ncurr=ncurr/2 fft 117
- 140 if (ncurr-1) 190,190,150 fft 118
-c factor n(idim), the length of this dimension. fft 119
- 150 call factr (ncurr,ifact,nfact) fft 120
- ifmax=ifact(nfact) fft 121
-c arrange the factors symmetrically for simpler digit reversal. fft 122
- call smfac (ifact,nfact,isym,ifsym,nfsym,icent,ifcnt,nfcnt) fft 123
- ifmax=max0(ifmax,icent) fft 124
- if (ifmax-nwork) 180,180,160 fft 125
- 160 continue
-c 160 write (6,170) nwork,idim,ncurr,icent,(ifact(if),if=1,nfact) fft 126
-c 170 format (26h0error in fourt. nwork = ,i4,20h is too small for n(, fft 127
-c $i1,4h) = ,i5,17h, whose center = ,i4,31h, and whose prime factors fft 128
-c $are--/(1x,20i5)) fft 129
- return fft 130
- 180 nprev=ntot/(n(idim)*nrem) fft 131
-c digit reverse on symmetric factors, for example 2*7*6*7*2. fft 132
- call symrv (data,nprev,ncurr,nrem,ifsym,nfsym) fft 133
-c digit reverse the asymmetric center, for example, on 6 = 2*3. fft 134
- call asmrv (data,nprev*isym,icent,isym*nrem,ifcnt,nfcnt,work) fft 135
-c fourier transform on each factor, for example, on 2,7,2,3,7 and 2.fft 136
- call cool (data,nprev,ncurr,nrem,isign,ifact,work) fft 137
- 190 if (iform) 200,210,230 fft 138
- 200 nrem=nrem*n(idim) fft 139
- go to 230 fft 140
- 210 if (idim-1) 220,220,230 fft 141
- 220 call fixrl (data,n(1),nrem,isign,iform) fft 142
- ntot=ntot/n(1)*(n(1)/2+1) fft 143
- 230 continue fft 144
- return fft 145
- end fft 146-
- subroutine asmrv (data,nprev,n,nrem,ifact,nfact,work) asm 1
-c shuffle the data array by reversing the digits of one index. asm 2
-c the operation is the same as in symrv, except that the factors asm 3
-c need not be symmetrically arranged, i.e., generally ifact(if) not=asm 4
-c ifact(nfact+1-if). consequently, a work array of length n is asm 5
-c needed. asm 6
- dimension data(*), work(*), ifact(1) asm 7
- if (nfact-1) 60,60,10 asm 8
- 10 ip0=2 asm 9
- ip1=ip0*nprev asm 10
- ip4=ip1*n asm 11
- ip5=ip4*nrem asm 12
- do 50 i1=1,ip1,ip0 asm 13
- do 50 i5=i1,ip5,ip4 asm 14
- iwork=1 asm 15
- i4rev=i5 asm 16
- i4max=i5+ip4-ip1 asm 17
- do 40 i4=i5,i4max,ip1 asm 18
- work(iwork)=data(i4rev) asm 19
- work(iwork+1)=data(i4rev+1) asm 20
- ip3=ip4 asm 21
- do 30 if=1,nfact asm 22
- ip2=ip3/ifact(if) asm 23
- i4rev=i4rev+ip2 asm 24
- if (i4rev-ip3-i5) 40,20,20 asm 25
- 20 i4rev=i4rev-ip3 asm 26
- 30 ip3=ip2 asm 27
- 40 iwork=iwork+ip0 asm 28
- iwork=1 asm 29
- do 50 i4=i5,i4max,ip1 asm 30
- data(i4)=work(iwork) asm 31
- data(i4+1)=work(iwork+1) asm 32
- 50 iwork=iwork+ip0 asm 33
- 60 return asm 34
- end asm 35-
- subroutine cool (data,nprev,n,nrem,isign,ifact,work) coo 1
-c fourier transform of length n. in place cooley-tukey method, coo 2
-c digit-reversed to normal order, sande-tukey factoring (2). coo 3
-c dimension data(nprev,n,nrem) coo 4
-c complex data coo 5
-c data(i1,j2,i3) = sum(data(i1,i2,i3)*exp(isign*2*pi*i*((i2-1)* coo 6
-c (j2-1)/n))), summed over i2 = 1 to n for all i1 from 1 to nprev, coo 7
-c j2 from 1 to n and i3 from 1 to nrem. the factors of n are given coo 8
-c in any order in array ifact. factors of two are done in pairs coo 9
-c as much as possible (fourier transform of length four), factors ofcoo 10
-c three are done separately, and all factors five or higher coo 11
-c are done by goertzel's algorithm (4). coo 12
- dimension data(*), work(*), ifact(1) coo 13
- twopi=6.283185307*float(isign) coo 14
- ip0=2 coo 15
- ip1=ip0*nprev coo 16
- ip4=ip1*n coo 17
- ip5=ip4*nrem coo 18
- if=0 coo 19
- ip2=ip1 coo 20
- 10 if (ip2-ip4) 20,240,240 coo 21
- 20 if=if+1 coo 22
- ifcur=ifact(if) coo 23
- if (ifcur-2) 60,30,60 coo 24
- 30 if (4*ip2-ip4) 40,40,60 coo 25
- 40 if (ifact(if+1)-2) 60,50,60 coo 26
- 50 if=if+1 coo 27
- ifcur=4 coo 28
- 60 ip3=ip2*ifcur coo 29
- theta=twopi/float(ifcur) coo 30
- sinth=sin(theta/2.) coo 31
- rootr=-2.*sinth*sinth coo 32
-c cos(theta)-1, for accuracy. coo 33
- rooti=sin(theta) coo 34
- theta=twopi/float(ip3/ip1) coo 35
- sinth=sin(theta/2.) coo 36
- wstpr=-2.*sinth*sinth coo 37
- wstpi=sin(theta) coo 38
- wr=1. coo 39
- wi=0. coo 40
- do 230 i2=1,ip2,ip1 coo 41
- if (ifcur-4) 70,70,210 coo 42
- 70 if ((i2-1)*(ifcur-2)) 240,90,80 coo 43
- 80 w2r=wr*wr-wi*wi coo 44
- w2i=2.*wr*wi coo 45
- w3r=w2r*wr-w2i*wi coo 46
- w3i=w2r*wi+w2i*wr coo 47
- 90 i1max=i2+ip1-ip0 coo 48
- do 200 i1=i2,i1max,ip0 coo 49
- do 200 i5=i1,ip5,ip3 coo 50
- j0=i5 coo 51
- j1=j0+ip2 coo 52
- j2=j1+ip2 coo 53
- j3=j2+ip2 coo 54
- if (i2-1) 140,140,100 coo 55
- 100 if (ifcur-3) 130,120,110 coo 56
-c apply the phase shift factors coo 57
- 110 tempr=data(j3) coo 58
- data(j3)=w3r*tempr-w3i*data(j3+1) coo 59
- data(j3+1)=w3r*data(j3+1)+w3i*tempr coo 60
- tempr=data(j2) coo 61
- data(j2)=wr*tempr-wi*data(j2+1) coo 62
- data(j2+1)=wr*data(j2+1)+wi*tempr coo 63
- tempr=data(j1) coo 64
- data(j1)=w2r*tempr-w2i*data(j1+1) coo 65
- data(j1+1)=w2r*data(j1+1)+w2i*tempr coo 66
- go to 140 coo 67
- 120 tempr=data(j2) coo 68
- data(j2)=w2r*tempr-w2i*data(j2+1) coo 69
- data(j2+1)=w2r*data(j2+1)+w2i*tempr coo 70
- 130 tempr=data(j1) coo 71
- data(j1)=wr*tempr-wi*data(j1+1) coo 72
- data(j1+1)=wr*data(j1+1)+wi*tempr coo 73
- 140 if (ifcur-3) 150,160,170 coo 74
-c do a fourier transform of length two coo 75
- 150 tempr=data(j1) coo 76
- tempi=data(j1+1) coo 77
- data(j1)=data(j0)-tempr coo 78
- data(j1+1)=data(j0+1)-tempi coo 79
- data(j0)=data(j0)+tempr coo 80
- data(j0+1)=data(j0+1)+tempi coo 81
- go to 200 coo 82
-c do a fourier transform of length three coo 83
- 160 sumr=data(j1)+data(j2) coo 84
- sumi=data(j1+1)+data(j2+1) coo 85
- tempr=data(j0)-.5*sumr coo 86
- tempi=data(j0+1)-.5*sumi coo 87
- data(j0)=data(j0)+sumr coo 88
- data(j0+1)=data(j0+1)+sumi coo 89
- difr=rooti*(data(j2+1)-data(j1+1)) coo 90
- difi=rooti*(data(j1)-data(j2)) coo 91
- data(j1)=tempr+difr coo 92
- data(j1+1)=tempi+difi coo 93
- data(j2)=tempr-difr coo 94
- data(j2+1)=tempi-difi coo 95
- go to 200 coo 96
-c do a fourier transform of length four (from bit reversed order) coo 97
- 170 t0r=data(j0)+data(j1) coo 98
- t0i=data(j0+1)+data(j1+1) coo 99
- t1r=data(j0)-data(j1) coo 100
- t1i=data(j0+1)-data(j1+1) coo 101
- t2r=data(j2)+data(j3) coo 102
- t2i=data(j2+1)+data(j3+1) coo 103
- t3r=data(j2)-data(j3) coo 104
- t3i=data(j2+1)-data(j3+1) coo 105
- data(j0)=t0r+t2r coo 106
- data(j0+1)=t0i+t2i coo 107
- data(j2)=t0r-t2r coo 108
- data(j2+1)=t0i-t2i coo 109
- if (isign) 180,180,190 coo 110
- 180 t3r=-t3r coo 111
- t3i=-t3i coo 112
- 190 data(j1)=t1r-t3i coo 113
- data(j1+1)=t1i+t3r coo 114
- data(j3)=t1r+t3i coo 115
- data(j3+1)=t1i-t3r coo 116
- 200 continue coo 117
- go to 220 coo 118
-c do a fourier transform of length five or more coo 119
- 210 call goert (data(i2),nprev,ip2/ip1,ifcur,ip5/ip3,work,wr,wi,rootr,coo 120
- $rooti) coo 121
- 220 tempr=wr coo 122
- wr=wstpr*tempr-wstpi*wi+tempr coo 123
- 230 wi=wstpr*wi+wstpi*tempr+wi coo 124
- ip2=ip3 coo 125
- go to 10 coo 126
- 240 return coo 127
- end coo 128-
- subroutine factr (n,ifact,nfact) fac 1
-c factor n into its prime factors, nfact in number. for example, fac 2
-c for n = 1960, nfact = 6 and ifact(if) = 2, 2, 2, 5, 7 and 7. fac 3
- dimension ifact(1) fac 4
- if=0 fac 5
- npart=n fac 6
- do 50 id=1,n,2 fac 7
- idiv=id fac 8
- if (id-1) 10,10,20 fac 9
- 10 idiv=2 fac 10
- 20 iquot=npart/idiv fac 11
- if (npart-idiv*iquot) 40,30,40 fac 12
- 30 if=if+1 fac 13
- ifact(if)=idiv fac 14
- npart=iquot fac 15
- go to 20 fac 16
- 40 if (iquot-idiv) 60,60,50 fac 17
- 50 continue fac 18
- 60 if (npart-1) 80,80,70 fac 19
- 70 if=if+1 fac 20
- ifact(if)=npart fac 21
- 80 nfact=if fac 22
- return fac 23
- end fac 24-
- subroutine fixrl (data,n,nrem,isign,iform) fix 1
-c for iform = 0, convert the transform of a doubled-up real array, fix 2
-c considered complex, into its true transform. supply only the fix 3
-c first half of the complex transform, as the second half has fix 4
-c conjugate symmetry. for iform = -1, convert the first half fix 5
-c of the true transform into the transform of a doubled-up real fix 6
-c array. n must be even. fix 7
-c using complex notation and subscripts starting at zero, the fix 8
-c transformation is-- fix 9
-c dimension data(n,nrem) fix 10
-c zstp = exp(isign*2*pi*i/n) fix 11
-c do 10 i2=0,nrem-1 fix 12
-c data(0,i2) = conj(data(0,i2))*(1+i) fix 13
-c do 10 i1=1,n/4 fix 14
-c z = (1+(2*iform+1)*i*zstp**i1)/2 fix 15
-c i1cnj = n/2-i1 fix 16
-c dif = data(i1,i2)-conj(data(i1cnj,i2)) fix 17
-c temp = z*dif fix 18
-c data(i1,i2) = (data(i1,i2)-temp)*(1-iform) fix 19
-c 10 data(i1cnj,i2) = (data(i1cnj,i2)+conj(temp))*(1-iform) fix 20
-c if i1=i1cnj, the calculation for that value collapses into fix 21
-c a simple conjugation of data(i1,i2). fix 22
- dimension data(*) fix 23
- twopi=6.283185307*float(isign) fix 24
- ip0=2 fix 25
- ip1=ip0*(n/2) fix 26
- ip2=ip1*nrem fix 27
- if (iform) 10,70,70 fix 28
-c pack the real input values (two per column) fix 29
- 10 j1=ip1+1 fix 30
- data(2)=data(j1) fix 31
- if (nrem-1) 70,70,20 fix 32
- 20 j1=j1+ip0 fix 33
- i2min=ip1+1 fix 34
- do 60 i2=i2min,ip2,ip1 fix 35
- data(i2)=data(j1) fix 36
- j1=j1+ip0 fix 37
- if (n-2) 50,50,30 fix 38
- 30 i1min=i2+ip0 fix 39
- i1max=i2+ip1-ip0 fix 40
- do 40 i1=i1min,i1max,ip0 fix 41
- data(i1)=data(j1) fix 42
- data(i1+1)=data(j1+1) fix 43
- 40 j1=j1+ip0 fix 44
- 50 data(i2+1)=data(j1) fix 45
- 60 j1=j1+ip0 fix 46
- 70 do 80 i2=1,ip2,ip1 fix 47
- tempr=data(i2) fix 48
- data(i2)=data(i2)+data(i2+1) fix 49
- 80 data(i2+1)=tempr-data(i2+1) fix 50
- if (n-2) 200,200,90 fix 51
- 90 theta=twopi/float(n) fix 52
- sinth=sin(theta/2.) fix 53
- zstpr=-2.*sinth*sinth fix 54
- zstpi=sin(theta) fix 55
- zr=(1.-zstpi)/2. fix 56
- zi=(1.+zstpr)/2. fix 57
- if (iform) 100,110,110 fix 58
- 100 zr=1.-zr fix 59
- zi=-zi fix 60
- 110 i1min=ip0+1 fix 61
- i1max=ip0*(n/4)+1 fix 62
- do 190 i1=i1min,i1max,ip0 fix 63
- do 180 i2=i1,ip2,ip1 fix 64
- i2cnj=ip0*(n/2+1)-2*i1+i2 fix 65
- if (i2-i2cnj) 150,120,120 fix 66
- 120 if (isign*(2*iform+1)) 130,140,140 fix 67
- 130 data(i2+1)=-data(i2+1) fix 68
- 140 if (iform) 170,180,180 fix 69
- 150 difr=data(i2)-data(i2cnj) fix 70
- difi=data(i2+1)+data(i2cnj+1) fix 71
- tempr=difr*zr-difi*zi fix 72
- tempi=difr*zi+difi*zr fix 73
- data(i2)=data(i2)-tempr fix 74
- data(i2+1)=data(i2+1)-tempi fix 75
- data(i2cnj)=data(i2cnj)+tempr fix 76
- data(i2cnj+1)=data(i2cnj+1)-tempi fix 77
- if (iform) 160,180,180 fix 78
- 160 data(i2cnj)=data(i2cnj)+data(i2cnj) fix 79
- data(i2cnj+1)=data(i2cnj+1)+data(i2cnj+1) fix 80
- 170 data(i2)=data(i2)+data(i2) fix 81
- data(i2+1)=data(i2+1)+data(i2+1) fix 82
- 180 continue fix 83
- tempr=zr-.5 fix 84
- zr=zstpr*tempr-zstpi*zi+zr fix 85
- 190 zi=zstpr*zi+zstpi*tempr+zi fix 86
-c recursion saves time, at a slight loss in accuracy. if available,fix 87
-c use double precision to compute zr and zi. fix 88
- 200 if (iform) 270,210,210 fix 89
-c unpack the real transform values (two per column) fix 90
- 210 i2=ip2+1 fix 91
- i1=i2 fix 92
- j1=ip0*(n/2+1)*nrem+1 fix 93
- go to 250 fix 94
- 220 data(j1)=data(i1) fix 95
- data(j1+1)=data(i1+1) fix 96
- i1=i1-ip0 fix 97
- j1=j1-ip0 fix 98
- 230 if (i2-i1) 220,240,240 fix 99
- 240 data(j1)=data(i1) fix 100
- data(j1+1)=0. fix 101
- 250 i2=i2-ip1 fix 102
- j1=j1-ip0 fix 103
- data(j1)=data(i2+1) fix 104
- data(j1+1)=0. fix 105
- i1=i1-ip0 fix 106
- j1=j1-ip0 fix 107
- if (i2-1) 260,260,230 fix 108
- 260 data(2)=0. fix 109
- 270 return fix 110
- end fix 111-
- subroutine goert(data,nprev,iprod,ifact,irem,work,wminr,wmini, goe 1
- $ rootr,rooti) goe 2
-c phase-shifted fourier transform of length ifact by the goertzel goe 3
-c algorithm (4). ifact must be odd and at least 5. further speed goe 4
-c is gained by computing two transform values at the same time. goe 5
-c dimension data(nprev,iprod,ifact,irem) goe 6
-c data(i1,1,j3,i5) = sum(data(i1,1,i3,i5) * w**(i3-1)), summed goe 7
-c over i3 = 1 to ifact for all i1 from 1 to nprev, j3 from 1 to goe 8
-c ifact and i5 from 1 to irem. goe 9
-c w = wmin * exp(isign*2*pi*i*(j3-1)/ifact). goe 10
- dimension data(*), work(*) goe 11
- ip0=2 goe 12
- ip1=ip0*nprev goe 13
- ip2=ip1*iprod goe 14
- ip3=ip2*ifact goe 15
- ip5=ip3*irem goe 16
- if (wmini) 10,40,10 goe 17
-c apply the phase shift factors goe 18
- 10 wr=wminr goe 19
- wi=wmini goe 20
- i3min=1+ip2 goe 21
- do 30 i3=i3min,ip3,ip2 goe 22
- i1max=i3+ip1-ip0 goe 23
- do 20 i1=i3,i1max,ip0 goe 24
- do 20 i5=i1,ip5,ip3 goe 25
- tempr=data(i5) goe 26
- data(i5)=wr*tempr-wi*data(i5+1) goe 27
- 20 data(i5+1)=wr*data(i5+1)+wi*tempr goe 28
- tempr=wr goe 29
- wr=wminr*tempr-wmini*wi goe 30
- 30 wi=wminr*wi+wmini*tempr goe 31
- 40 do 90 i1=1,ip1,ip0 goe 32
- do 90 i5=i1,ip5,ip3 goe 33
-c straight summation for the first term goe 34
- sumr=0. goe 35
- sumi=0. goe 36
- i3max=i5+ip3-ip2 goe 37
- do 50 i3=i5,i3max,ip2 goe 38
- sumr=sumr+data(i3) goe 39
- 50 sumi=sumi+data(i3+1) goe 40
- work(1)=sumr goe 41
- work(2)=sumi goe 42
- wr=rootr+1. goe 43
- wi=rooti goe 44
- iwmin=1+ip0 goe 45
- iwmax=ip0*((ifact+1)/2)-1 goe 46
- do 80 iwork=iwmin,iwmax,ip0 goe 47
- twowr=wr+wr goe 48
- i3=i3max goe 49
- oldsr=0. goe 50
- oldsi=0. goe 51
- sumr=data(i3) goe 52
- sumi=data(i3+1) goe 53
- i3=i3-ip2 goe 54
- 60 tempr=sumr goe 55
- tempi=sumi goe 56
- sumr=twowr*sumr-oldsr+data(i3) goe 57
- sumi=twowr*sumi-oldsi+data(i3+1) goe 58
- oldsr=tempr goe 59
- oldsi=tempi goe 60
- i3=i3-ip2 goe 61
- if (i3-i5) 70,70,60 goe 62
-c in a fourier transform the w corresponding to the point at k goe 63
-c is the conjugate of that at ifact-k (that is, exp(twopi*i* goe 64
-c k/ifact) = conj(exp(twopi*i*(ifact-k)/ifact))). since the goe 65
-c main loop of goertzels algorithm is indifferent to the imaginary goe 66
-c part of w, it need be supplied only at the end. goe 67
- 70 tempr=-wi*sumi goe 68
- tempi=wi*sumr goe 69
- sumr=wr*sumr-oldsr+data(i3) goe 70
- sumi=wr*sumi-oldsi+data(i3+1) goe 71
- work(iwork)=sumr+tempr goe 72
- work(iwork+1)=sumi+tempi goe 73
- iwcnj=ip0*(ifact+1)-iwork goe 74
- work(iwcnj)=sumr-tempr goe 75
- work(iwcnj+1)=sumi-tempi goe 76
-c singleton's recursion, for accuracy and speed (5). goe 77
- tempr=wr goe 78
- wr=wr*rootr-wi*rooti+wr goe 79
- 80 wi=tempr*rooti+wi*rootr+wi goe 80
- iwork=1 goe 81
- do 90 i3=i5,i3max,ip2 goe 82
- data(i3)=work(iwork) goe 83
- data(i3+1)=work(iwork+1) goe 84
- 90 iwork=iwork+ip0 goe 85
- return goe 86
- end goe 87-
- subroutine smfac (ifact,nfact,isym,ifsym,nfsym,icent,ifcnt,nfcnt) smf 1
-c rearrange the prime factors of n into a square and a non- smf 2
-c square. n = isym*icent*isym, where icent is square-free. smf 3
-c isym = ifsym(1)*...*ifsym(nfsym), each a prime factor. smf 4
-c icent = ifcnt(1)*...*ifcnt(nfcnt), each a prime factor. smf 5
-c for example, n = 1960 = 14*10*14. then isym = 14, icent = 10, smf 6
-c nfsym = 2, nfcnt = 2, nfact = 6, ifsym(ifs) = 2, 7, ifcnt(ifc) = smf 7
-c 2, 5 and ifact(if) = 2, 7, 2, 5, 7, 2. smf 8
- dimension ifsym(1), ifcnt(1), ifact(1) smf 9
- isym=1 smf 10
- icent=1 smf 11
- ifs=0 smf 12
- ifc=0 smf 13
- if=1 smf 14
- 10 if (if-nfact) 20,40,50 smf 15
- 20 if (ifact(if)-ifact(if+1)) 40,30,40 smf 16
- 30 ifs=ifs+1 smf 17
- ifsym(ifs)=ifact(if) smf 18
- isym=ifact(if)*isym smf 19
- if=if+2 smf 20
- go to 10 smf 21
- 40 ifc=ifc+1 smf 22
- ifcnt(ifc)=ifact(if) smf 23
- icent=ifact(if)*icent smf 24
- if=if+1 smf 25
- go to 10 smf 26
- 50 nfsym=ifs smf 27
- nfcnt=ifc smf 28
- nfsm2=2*nfsym smf 29
- nfact=2*nfsym+nfcnt smf 30
- if (nfcnt) 80,80,60 smf 31
- 60 nfsm2=nfsm2+1 smf 32
- ifsym(nfsym+1)=icent smf 33
- do 70 ifc=1,nfcnt smf 34
- if=nfsym+ifc smf 35
- 70 ifact(if)=ifcnt(ifc) smf 36
- 80 if (nfsym) 110,110,90 smf 37
- 90 do 100 ifs=1,nfsym smf 38
- ifscj=nfsm2+1-ifs smf 39
- ifsym(ifscj)=ifsym(ifs) smf 40
- ifact(ifs)=ifsym(ifs) smf 41
- ifcnj=nfact+1-ifs smf 42
- 100 ifact(ifcnj)=ifsym(ifs) smf 43
- 110 nfsym=nfsm2 smf 44
- return smf 45
- end smf 46-
- subroutine symrv (data,nprev,n,nrem,ifact,nfact) sym 1
-c shuffle the data array by reversing the digits of one index. sym 2
-c dimension data(nprev,n,nrem) sym 3
-c replace data(i1,i2,i3) by data(i1,i2rev,i3) for all i1 from 1 to sym 4
-c nprev, i2 from 1 to n and i3 from 1 to nrem. i2rev-1 is the sym 5
-c integer whose digit representation in the multi-radix notation sym 6
-c of factors ifact(if) is the reverse of the representation of i2-1.sym 7
-c for example, if all ifact(if) = 2, i2-1 = 11001, i2rev-1 = 10011. sym 8
-c the factors must be symmetrically arranged, i.e., ifact(if) = sym 9
-c ifact(nfact+1-if). sym 10
- dimension data(*), ifact(1) sym 11
- if (nfact-1) 80,80,10 sym 12
- 10 ip0=2 sym 13
- ip1=ip0*nprev sym 14
- ip4=ip1*n sym 15
- ip5=ip4*nrem sym 16
- i4rev=1 sym 17
- do 70 i4=1,ip4,ip1 sym 18
- if (i4-i4rev) 20,40,40 sym 19
- 20 i1max=i4+ip1-ip0 sym 20
- do 30 i1=i4,i1max,ip0 sym 21
- do 30 i5=i1,ip5,ip4 sym 22
- i5rev=i4rev+i5-i4 sym 23
- tempr=data(i5)
- tempi=data(i5+1) sym 25
- data(i5)=data(i5rev) sym 26
- data(i5+1)=data(i5rev+1) sym 27
- data(i5rev)=tempr sym 28
- 30 data(i5rev+1)=tempi sym 29
- 40 ip3=ip4 sym 30
- do 60 if=1,nfact sym 31
- ip2=ip3/ifact(if) sym 32
- i4rev=i4rev+ip2 sym 33
- if (i4rev-ip3) 70,70,50 sym 34
- 50 i4rev=i4rev-ip3 sym 35
- 60 ip3=ip2 sym 36
- 70 continue sym 37
- 80 return sym 38
- end sym 39-
diff -r 405d8f4fa05f -r e7295294f654 elastic3d.f90
--- a/elastic3d.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,3421 +0,0 @@
-!-----------------------------------------------------------------------
-! Copyright 2007, 2008, 2009 Sylvain Barbot
-!
-! This file is part of RELAX
-!
-! RELAX 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 3 of the License, or
-! (at your option) any later version.
-!
-! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
-!-----------------------------------------------------------------------
-
-MODULE elastic3d
-
- USE types
- USE fourier
-
- IMPLICIT NONE
-
-#include "include.f90"
-
- REAL*8, PRIVATE, PARAMETER :: pi = 3.141592653589793115997963468544185161_8
- REAL*8, PRIVATE, PARAMETER :: pi2 = 6.28318530717958623199592693708837032318_8
- REAL*8, PRIVATE, PARAMETER :: pid2 = 1.57079632679489655799898173427209258079_8
- REAL*8, PRIVATE, PARAMETER :: DEG2RAD = 0.01745329251994329547437168059786927_8
-
- INTERFACE OPERATOR (.times.)
- MODULE PROCEDURE tensorscalarprod
- END INTERFACE
-
- INTERFACE OPERATOR (.minus.)
- MODULE PROCEDURE tensordiff
- END INTERFACE
-
- INTERFACE OPERATOR (.plus.)
- MODULE PROCEDURE tensorplus
- END INTERFACE
-
- INTERFACE OPERATOR (.sdyad.)
- MODULE PROCEDURE tensorsymmetricdyadprod
- END INTERFACE
-
- INTERFACE OPERATOR (.tdot.)
- MODULE PROCEDURE tensorvectordotprod
- END INTERFACE
-
-CONTAINS
-
- !------------------------------------------------------------
- !> function SIGN
- !! returns the sign of the input -1 for negtive, 0 for zero
- !! and +1 for positive arguments.
- !------------------------------------------------------------
- REAL*8 FUNCTION sign(x)
- REAL*8, INTENT(IN) :: x
-
- IF (x .gt. 0._8) THEN
- sign=1._8
- ELSE
- IF (x .lt. 0._8) THEN
- sign=-1._8
- ELSE
- sign=0._8
- END IF
- END IF
- END FUNCTION sign
-
- !------------------------------------------------------------
- !> function fix
- !! returns the closest integer scalar
- !
- ! sylvain barbot (08/25/07) - original form
- !------------------------------------------------------------
- INTEGER FUNCTION fix(number)
- REAL*8, INTENT(IN) :: number
-
- INTEGER :: c,f
- f=FLOOR(number)
- c=CEILING(number)
-
- IF ((number-f) .gt. 0.5_8) THEN
- fix=c
- ELSE
- fix=f
- END IF
-
- END FUNCTION fix
-
- !------------------------------------------------------------
- !> function SINH
- !! computes the hyperbolic sine
- !------------------------------------------------------------
- REAL*8 FUNCTION sinh(x)
- REAL*8, INTENT(IN) :: x
-
- IF (abs(x) .GT. 85._8) THEN
- sinh=sign(x)*exp(85._8)/2._8
- ELSE
- sinh=(exp(x)-exp(-x))/2._8
- END IF
- END FUNCTION sinh
-
- !------------------------------------------------------------
- !> function ASINH
- !! computes the inverse hyperbolic sine
- !------------------------------------------------------------
- REAL*8 FUNCTION asinh(x)
- REAL*8, INTENT(IN) :: x
- asinh=log(x+sqrt(x*x+1))
- END FUNCTION asinh
-
- !-----------------------------------------------------------------
- !> subroutine Neighbor
- !! computes the indices of neighbor samples (l points away)
- !! bracketing the current samples location i1,i2,i3 and
- !! assuming periodic boundary condition.
- !!
- !! i1m < i1 < i1p
- !! i2m < i2 < i2p
- !! i3m < i3 < i3p
- !-----------------------------------------------------------------
- SUBROUTINE neighbor(i1,i2,i3,sx1,sx2,sx3,l,i1m,i1p,i2m,i2p,i3m,i3p)
- INTEGER, INTENT(IN) :: i1,i2,i3,sx1,sx2,sx3,l
- INTEGER, INTENT(OUT) :: i1m,i1p,i2m,i2p,i3m,i3p
-
- i1m=mod(sx1+i1-1-l,sx1)+1
- i1p=mod(i1-1+l,sx1)+1
- i2m=mod(sx2+i2-1-l,sx2)+1
- i2p=mod(i2-1+l,sx2)+1
- i3m=mod(sx3+i3-1-l,sx3)+1
- i3p=mod(i3-1+l,sx3)+1
-
- END SUBROUTINE neighbor
-
- !---------------------------------------------------------------
- !> subroutine IsotropicStressStrain
- !! computes in place the isotropic stress tensor from a given
- !! strain tensor using Hooke's law stress-strain relationship.
- !
- ! sylvain barbot (10/14/07) - original form
- !---------------------------------------------------------------
- SUBROUTINE isotropicstressstrain(t,lambda,mu)
- TYPE(TENSOR), INTENT(INOUT) :: t
- REAL*8, INTENT(IN) :: lambda, mu
-
- REAL*8 :: epskk
-
- epskk=tensortrace(t)
-
- t = REAL(2._8*mu) .times. t
- t%s11=t%s11+lambda*epskk
- t%s22=t%s22+lambda*epskk
- t%s33=t%s33+lambda*epskk
-
- END SUBROUTINE isotropicstressstrain
-
- !------------------------------------------------------------
- !> function TensorDiff
- !! computes the difference between two tensors: t=t1-t2
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- TYPE(TENSOR) FUNCTION tensordiff(t1,t2)
- TYPE(TENSOR), INTENT(IN) :: t1,t2
-
- tensordiff=TENSOR(t1%s11-t2%s11, & ! 11
- t1%s12-t2%s12, & ! 12
- t1%s13-t2%s13, & ! 13
- t1%s22-t2%s22, & ! 22
- t1%s23-t2%s23, & ! 23
- t1%s33-t2%s33) ! 33
-
- END FUNCTION tensordiff
-
- !------------------------------------------------------------
- !> function TensorPlus
- !! computes the sum of two tensors: t=t1-t2
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- TYPE(TENSOR) FUNCTION tensorplus(t1,t2)
- TYPE(TENSOR), INTENT(IN) :: t1,t2
-
- tensorplus=TENSOR(t1%s11+t2%s11, & ! 11
- t1%s12+t2%s12, & ! 12
- t1%s13+t2%s13, & ! 13
- t1%s22+t2%s22, & ! 22
- t1%s23+t2%s23, & ! 23
- t1%s33+t2%s33) ! 33
-
- END FUNCTION tensorplus
-
- !------------------------------------------------------------
- !> function TensorScalarProd
- !! multiplies a tensor with a scalar
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- TYPE(TENSOR) FUNCTION tensorscalarprod(scalar,t)
- TYPE(TENSOR), INTENT(IN) :: t
- REAL*4, INTENT(IN) :: scalar
-
- tensorscalarprod=TENSOR(scalar*t%s11, & ! 11
- scalar*t%s12, & ! 12
- scalar*t%s13, & ! 13
- scalar*t%s22, & ! 22
- scalar*t%s23, & ! 23
- scalar*t%s33) ! 33
-
- END FUNCTION tensorscalarprod
-
- !------------------------------------------------------------
- !> function TensorSymmetricDyadProd
- !! computes the dyadic product of two vectors to obtain a
- !! symmetric second order tensor
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- TYPE(TENSOR) FUNCTION tensorsymmetricdyadprod(a,b)
- REAL*8, DIMENSION(3), INTENT(IN) :: a,b
-
- tensorsymmetricdyadprod=TENSOR( &
- a(1)*b(1), & ! 11
- (a(1)*b(2)+a(2)*b(1))/2._8, & ! 12
- (a(1)*b(3)+a(3)*b(1))/2._8, & ! 13
- a(2)*b(2), & ! 22
- (a(2)*b(3)+a(3)*b(2))/2._8, & ! 23
- a(3)*b(3) & ! 33
- )
-
- END FUNCTION tensorsymmetricdyadprod
-
- !------------------------------------------------------------
- !> function TensorVectorDotProd
- !! compute the dot product T.v where T is a second-order
- !! tensor and v is a vector.
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- FUNCTION tensorvectordotprod(t,v)
- TYPE(TENSOR), INTENT(IN) :: t
- REAL*8, DIMENSION(3), INTENT(IN) :: v
- REAL*8, DIMENSION(3) :: tensorvectordotprod
-
- tensorvectordotprod= &
- (/ t%s11*v(1)+t%s12*v(2)+t%s13*v(3), &
- t%s12*v(1)+t%s22*v(2)+t%s23*v(3), &
- t%s13*v(1)+t%s23*v(2)+t%s33*v(3) /)
-
- END FUNCTION tensorvectordotprod
-
- !------------------------------------------------------------
- !> function TensorVectorDotProd
- !! compute the dot product T.v where T is a second-order
- !! tensor and v is a vector.
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- FUNCTION tensordeviatoric(t)
- TYPE(TENSOR), INTENT(IN) :: t
- TYPE(TENSOR) :: tensordeviatoric
-
- REAL*4 :: diag
-
- diag=REAL(tensortrace(t)/3._8)
-
- tensordeviatoric%s11=t%s11-diag
- tensordeviatoric%s12=t%s12
- tensordeviatoric%s13=t%s13
- tensordeviatoric%s22=t%s22-diag
- tensordeviatoric%s23=t%s23
- tensordeviatoric%s33=t%s33-diag
-
- END FUNCTION tensordeviatoric
-
- !------------------------------------------------------------
- !> function TensorTrace
- !! computes the trace of a second order tensor
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- REAL*8 FUNCTION tensortrace(t)
- TYPE(TENSOR), INTENT(IN) :: t
-
- tensortrace=t%s11+t%s22+t%s33
-
- END FUNCTION tensortrace
-
- !------------------------------------------------------------
- !> function TensorNorm
- !! computes the Frobenius norm of a second order tensor
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- REAL*8 FUNCTION tensornorm(t)
- TYPE(TENSOR), INTENT(IN) :: t
-
- tensornorm=SQRT(( &
- t%s11**2+2._8*t%s12**2+2._8*t%s13**2+ &
- t%s22**2+2._8*t%s23**2+ &
- t%s33**2)/2._8)
-
- END FUNCTION tensornorm
-
- !------------------------------------------------------------
- !> function TensorDecomposition
- !! writes a tensor t as the product of a norm and a direction
- !!
- !! t = gamma * R
- !!
- !! where gamma is a scalar, the norm of t, and R is a unitary
- !! tensor. t is assumed to be a deviatoric tensor.
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- SUBROUTINE tensordecomposition(t,gamma,R)
- TYPE(TENSOR), INTENT(IN) :: t
- TYPE(TENSOR), INTENT(OUT) :: R
- REAL*8, INTENT(OUT) :: gamma
-
- gamma=tensornorm(t)
-
- R%s11=t%s11/gamma
- R%s12=t%s12/gamma
- R%s13=t%s13/gamma
- R%s22=t%s22/gamma
- R%s23=t%s23/gamma
- R%s33=t%s33/gamma
-
- END SUBROUTINE tensordecomposition
-
-
- !------------------------------------------------------------
- !> function TensorForbeniusNorm
- !! computes the Frobenius norm of a second order tensor
- !
- ! sylvain barbot (07/09/07) - original form
- !------------------------------------------------------------
- REAL*8 FUNCTION tensorfrobeniusnorm(t)
- TYPE(TENSOR), INTENT(IN) :: t
-
- tensorfrobeniusnorm=SQRT( &
- t%s11**2+2._8*t%s12**2+2._8*t%s13**2+ &
- t%s22**2+2._8*t%s23**2+ &
- t%s33**2)
-
- END FUNCTION tensorfrobeniusnorm
-
- !------------------------------------------------------------
- !> function VectorFieldNormMax
- !! computes the maximum value of the norm of a vector field
- !------------------------------------------------------------
- SUBROUTINE vectorfieldnormmax(v1,v2,v3,sx1,sx2,sx3,maximum,location)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: v1,v2,v3
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v1,v2,v3
-#endif
- REAL*8, INTENT(OUT) :: maximum
- INTEGER, INTENT(OUT), DIMENSION(3) :: location
-
- INTEGER :: i1,i2,i3
- REAL*8 :: norm
-
- maximum=-1._8
- DO i3=1,sx3
- DO i2=1,sx2
- DO i1=1,sx1
- norm=SQRT(v1(i1,i2,i3)**2+v2(i1,i2,i3)**2+v3(i1,i2,i3)**2)
- IF (norm .GT. maximum) THEN
- maximum=norm
- location=(/ i1,i2,i3 /)
- END IF
- END DO
- END DO
- END DO
-
- END SUBROUTINE vectorfieldnormmax
-
- !------------------------------------------------------------
- !> function TensorMean
- !! computesthe mean of the norm of a tensor field
- !------------------------------------------------------------
- REAL*8 FUNCTION tensormean(t)
- TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: t
-
- INTEGER :: i1,i2,i3,sx1,sx2,sx3
- sx1=SIZE(t,1)
- sx2=SIZE(t,2)
- sx3=SIZE(t,3)
-
- DO i3=1,sx3
- DO i2=1,sx2
- DO i1=1,sx1
- tensormean=tensormean+tensornorm(t(i1,i2,i3))
- END DO
- END DO
- END DO
- tensormean=tensormean/DBLE(sx1*sx2*sx3)
-
- END FUNCTION tensormean
-
- !------------------------------------------------------------
- !> function TensorAmplitude
- !! computes the integral of the norm of a tensor field
- !------------------------------------------------------------
- REAL*8 FUNCTION tensoramplitude(t,dx1,dx2,dx3)
- TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: t
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
-
- INTEGER :: i1,i2,i3,sx1,sx2,sx3
- sx1=SIZE(t,1)
- sx2=SIZE(t,2)
- sx3=SIZE(t,3)
-
- tensoramplitude=0._8
- DO i3=1,sx3
- DO i2=1,sx2
- DO i1=1,sx1
- tensoramplitude=tensoramplitude &
- +tensornorm(t(i1,i2,i3))
- END DO
- END DO
- END DO
- tensoramplitude=tensoramplitude*DBLE(dx1*dx2*dx3)
-
- END FUNCTION tensoramplitude
-
- !------------------------------------------------------------
- !> function TensorMeanTrace
- !! computesthe mean of the norm of a tensor field
- !------------------------------------------------------------
- REAL*8 FUNCTION tensormeantrace(t)
- TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: t
-
- INTEGER :: i1,i2,i3,sx1,sx2,sx3
- sx1=SIZE(t,1)
- sx2=SIZE(t,2)
- sx3=SIZE(t,3)
-
- DO i3=1,sx3
- DO i2=1,sx2
- DO i1=1,sx1
- tensormeantrace= &
- tensormeantrace+tensortrace(t(i1,i2,i3))
- END DO
- END DO
- END DO
- tensormeantrace=tensormeantrace/DBLE(sx1*sx2*sx3)
-
- END FUNCTION tensormeantrace
-
- !------------------------------------------------------------
- !> sinc function
- !! computes sin(pi*x)/(pi*x)
- !
- ! sylvain barbot (04-14-07) - original form
- !------------------------------------------------------------
- FUNCTION sinc(x)
- REAL*8 :: sinc
- REAL*8, INTENT(IN) :: x
- IF (x /= 0) THEN
- sinc=sin(pi*x)/(pi*x)
- ELSE
- sinc=1._8
- END IF
- END FUNCTION sinc
-
- !-------------------------------------------------------------------------
- !> function gauss computes the normalized gaussian function
- !
- ! Sylvain Barbot (06-29-07)
- !-------------------------------------------------------------------------
- FUNCTION gauss(x,sigma)
- REAL*8 :: gauss
- REAL*8, INTENT(IN) :: x,sigma
-
- gauss=exp(-0.5_8*(x/sigma)**2)/sqrt(pi2)/sigma
- END FUNCTION gauss
-
- !-------------------------------------------------------------------------
- !> function gaussp computes the normalized gaussian derivative
- !
- ! Sylvain Barbot (06-29-07)
- !-------------------------------------------------------------------------
- FUNCTION gaussp(x,sigma)
- REAL*8 :: gaussp
- REAL*8, INTENT(IN) :: x,sigma
-
- gaussp=-x*exp(-0.5_8*(x/sigma)**2)/sqrt(pi2)/sigma**3
- END FUNCTION gaussp
-
- !-------------------------------------------------------------------------
- !> function omega computes raised-cosine taper in the space domain
- !
- ! Sylvain Barbot (06-29-07)
- !-------------------------------------------------------------------------
- FUNCTION omega(x,beta)
- REAL*8 :: omega
- REAL*8, INTENT(IN) :: x,beta
-
- IF (abs(x) .le. (1._8-2._8*beta)/(1._8-beta)/2._8) THEN
- omega=1._8
- ELSE
- IF (abs(x) .lt. 1._8/(1-beta)/2._8) THEN
- omega=cos(pi*((1._8-beta)*abs(x)-0.5_8+beta)/2._8/beta)**2
- ELSE
- omega=0._8
- END IF
- END IF
- END FUNCTION omega
-
- !-------------------------------------------------------------------------
- !> function omegap computes raised-cosine taper derivative
- !! in the space domain
- !
- ! Sylvain Barbot (06-29-07)
- !-------------------------------------------------------------------------
- FUNCTION omegap(x,beta)
- REAL*8 :: omegap
- REAL*8, INTENT(IN) :: x,beta
-
- omegap=0
- IF (abs(x) .gt. (1._8-2._8*beta)/(1._8-beta)/2._8) THEN
- IF (abs(x) .lt. 1._8/(1-beta)/2._8) THEN
- omegap=-DSIGN(1._8,x)*pi*(1._8-beta)/2._8/beta* &
- sin(pi*((1._8-beta)*abs(x)-0.5_8+beta)/beta)
- END IF
- END IF
- END FUNCTION omegap
-
- !-------------------------------------------------------------------------
- !> tapered step function (raised-cosine) of unit area in the Fourier domain
- !!
- !! INPUT
- !! @param k wavenumber
- !! @param beta roll-off parameter 0<beta<0.5
- !! no smoothing for beta close to 0
- !! string smoothing for beta close to 0.5
- !
- ! sylvain barbot (04-14-07) - original form
- !-------------------------------------------------------------------------
- FUNCTION omegak(k,beta)
- REAL*8 :: omegak
- REAL*8, INTENT(IN) :: k, beta
- REAL*8 :: gamma,denom,om1,om2
-
- gamma=(1._8-beta)
- denom=(gamma-(4._8*beta**2._8/gamma)*k**2._8)*2._8
- om1=sinc(k/gamma)
- om2=(1._8-2._8*beta)*sinc(((1._8-2._8*beta)/gamma)*k)
- omegak=(om1+om2)/denom
-
- END FUNCTION omegak
-
- !----------------------------------------------------------------
- !> subroutine TensorStructure
- !! constructs a vertically-stratified tensor field.
- !! The structure is defined by its interfaces: changes can be
- !! gradual or discontinuous.
- !
- ! sylvain barbot (10/25/08) - original form
- !----------------------------------------------------------------
- SUBROUTINE tensorstructure(vstruct,layers,dx3)
- TYPE(TENSOR_LAYER_STRUCT), INTENT(IN), DIMENSION(:) :: layers
- TYPE(TENSOR_LAYER_STRUCT), INTENT(OUT), DIMENSION(:) :: vstruct
- REAL*8, INTENT(IN) :: dx3
-
- INTEGER :: nv,k,i3s,i3e=1,i3,sx3
- REAL*8 :: z,z0,z1
- TYPE(TENSOR) :: t0,t1,t
-
- nv =SIZE(layers,1)
- sx3=SIZE(vstruct,1)
-
- IF (0 .ge. nv) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("invalid tensor structure. exiting.")')
- STOP 1
- END IF
-
- ! initialization
- vstruct(:)%z=0 ! depth is not used
- vstruct(:)%t=tensor(0._4,0._4,0._4,0._4,0._4,0._4) ! default
-
- z0=fix(layers(1)%z/dx3)*dx3
- DO k=1,nv
- ! project model on multiples of sampling size 'dx3'
- ! to avoid aliasing problems
- z1=fix(layers(k)%z/dx3)*dx3
-
- IF (z1 .lt. z0) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("invalid mechanical structure.")')
- WRITE (0,'("depths must be increasing. exiting.")')
- STOP 1
- END IF
-
- IF (z1 .eq. z0) THEN
- ! discontinuous interface in the elastic structure
- z0=z1
-
- t1=layers(k)%t
-
- i3e=fix(z1/dx3+1)
- ELSE
- ! interpolate linearly between current and previous value
-
- t1=layers(k)%t
-
- i3s=fix(z0/dx3)+1
- i3e=MIN(fix(z1/dx3+1),sx3)
- DO i3=i3s,i3e
- z=(i3-1._8)*dx3
-
- t=REAL(1._8/(z1-z0)) .times. &
- ((REAL(z-z0) .times. t1) .plus. (REAL(z1-z) .times. t0))
-
- vstruct(i3)%t=t
-
- END DO
- END IF
-
- z0=z1
- t0=t1
-
- END DO
-
- ! downward-continue the last layer
- IF (fix(z1/dx3) .lt. sx3-1) THEN
- vstruct(i3e:sx3)%t=t1
- END IF
-
- END SUBROUTINE tensorstructure
-
-
- !----------------------------------------------------------------
- !> subroutine ViscoElasticStructure
- !! constructs a vertically-stratified viscoelastic structure.
- !! The structure is defined by its interfaces: changes can be
- !! gradual or discontinuous.
- !!
- !! EXAMPLE INPUTS:
- !!
- !! 1- elastic plate over linear viscous half-space
- !! 1
- !! 1 1.0 1.0 1.0
- !!
- !! 2- elastic plate over powerlaw viscous half-space (n=3)
- !! 1
- !! 1 1.0 1.0 3.0
- !!
- !! 3- elastic plate over viscous half-space with depth-dependent
- !! viscosity
- !! 2
- !! 1 01.0 1.0 1.0
- !! 2 10.0 6.0 1.0
- !!
- !! in this last example, the grid does not have to reach down
- !! to x3=10.
- !!
- !! \author sylvain barbot (08/07/07) - original form
- !----------------------------------------------------------------
- SUBROUTINE viscoelasticstructure(vstruct,layers,dx3)
- TYPE(LAYER_STRUCT), INTENT(IN), DIMENSION(:) :: layers
- TYPE(LAYER_STRUCT), INTENT(OUT), DIMENSION(:) :: vstruct
- REAL*8, INTENT(IN) :: dx3
-
- INTEGER :: nv,k,i3s,i3e=1,i3,sx3
- REAL*8 :: z,z0,z1, &
- power,power0,power1, &
- gamma,gamma0,gamma1, &
- friction,friction0,friction1, &
- cohesion,cohesion0,cohesion1
-
-
- nv =SIZE(layers,1)
- sx3=SIZE(vstruct,1)
-
- IF (0 .ge. nv) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("invalid elastic structure. exiting.")')
- STOP 1
- END IF
-
- ! initialization
- vstruct(:)%z=0 ! depth is not used
- vstruct(:)%gammadot0=0 ! default is inviscid
- vstruct(:)%friction=0.6 ! default is friction=0.6
- vstruct(:)%cohesion=0 ! default is no cohesion
- vstruct(:)%stressexponent=layers(1)%stressexponent ! default
-
- z0=fix(layers(1)%z/dx3)*dx3
- DO k=1,nv
- ! project model on multiples of sampling size 'dx3'
- ! to avoid aliasing problems
- z1=fix(layers(k)%z/dx3)*dx3
-
- IF (z1 .lt. z0) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("invalid mechanical structure. exiting.")')
- STOP 1
- END IF
-
- IF (z1 .eq. z0) THEN
- ! discontinuous interface in the elastic structure
- z0=z1
- gamma1=layers(k)%gammadot0
- power1 =layers(k)%stressexponent
- friction1=layers(k)%friction
- cohesion1=layers(k)%cohesion
-
- i3e=fix(z1/dx3+1)
- ELSE
- ! interpolate between current and previous value
- gamma1=layers(k)%gammadot0
- power1 =layers(k)%stressexponent
- friction1=layers(k)%friction
- cohesion1=layers(k)%cohesion
-
- i3s=fix(z0/dx3)+1
- i3e=MIN(fix(z1/dx3+1),sx3)
- DO i3=i3s,i3e
- z=(i3-1._8)*dx3
- gamma=((z-z0)*gamma1+(z1-z)*gamma0)/(z1-z0)
- power=((z-z0)*power1+(z1-z)*power0)/(z1-z0)
- friction=((z-z0)*friction1+(z1-z)*friction0)/(z1-z0)
- cohesion=((z-z0)*cohesion1+(z1-z)*cohesion0)/(z1-z0)
-
- vstruct(i3)%gammadot0=gamma
- vstruct(i3)%stressexponent =power
- vstruct(i3)%friction=friction
- vstruct(i3)%cohesion=cohesion
- END DO
- END IF
-
- z0=z1
- gamma0=gamma1
- power0=power1
- friction0=friction1
- cohesion0=cohesion1
-
- END DO
-
- ! downward-continue the last layer
- IF (fix(z1/dx3) .lt. sx3-1) THEN
- vstruct(i3e:sx3)%gammadot0=REAL(gamma1)
- vstruct(i3e:sx3)%stressexponent =REAL(power1)
- vstruct(i3e:sx3)%friction=REAL(friction1)
- vstruct(i3e:sx3)%cohesion=REAL(cohesion1)
- END IF
-
- END SUBROUTINE viscoelasticstructure
-
-
- !------------------------------------------------------------------
- !> function OptimalFilter
- !! load predefined Finite Impulse Response (FIR) filters of various
- !! lengths and select the most appropriate ones based on the
- !! computational grid size. result is filter kernels always smaller
- !! than available computational length.
- !! this is useful in the special cases of infinite faults where
- !! deformation is essentially two-dimensional, despite the actual
- !! three-dimensional computation. in the direction of symmetry,
- !! no strain occurs and high accuracy derivative estimates are not
- !! needed.
- !
- ! Sylvain Barbot (03/05/08) - original form
- !------------------------------------------------------------------
- SUBROUTINE optimalfilter(ker1,ker2,ker3,len1,len2,len3,sx1,sx2,sx3)
- REAL*8, DIMENSION(16), INTENT(OUT) :: ker1,ker2,ker3
- INTEGER, INTENT(OUT) :: len1,len2,len3
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
-
- ! load FIR differentiator filter
- ! variables 'fir1', 'fir7', 'fir14'
- INCLUDE 'kernel1.inc'
- INCLUDE 'kernel7.inc'
- INCLUDE 'kernel14bis.inc'
-
- ! choose best differentiator kernels
- SELECT CASE(sx1)
- CASE (2:4)
- ! use centered finite difference
- len1=1
- ker1(1)=fir1(1)
- CASE (5:14)
- len1=7
- ker1(1:len1)=fir7(1:len1)
- CASE (15:)
- len1=1
- ker1(1:len1)=fir1(1:len1)
- CASE DEFAULT
- WRITE_DEBUG_INFO
- WRITE (0,'("optimalfilter: invalid dimension. exiting.")')
- STOP 2
- END SELECT
-
- ! choose best differentiator kernels
- SELECT CASE(sx2)
- CASE (2:4)
- ! use centered finite difference
- len2=1
- ker2(1)=fir1(1)
- CASE (5:14)
- len2=7
- ker2(1:len2)=fir7(1:len2)
- CASE (15:)
- len2=1
- ker2(1:len2)=fir1(1:len2)
- CASE DEFAULT
- WRITE_DEBUG_INFO
- WRITE (0,'("optimalfilter: invalid dimension. exiting.")')
- STOP 2
- END SELECT
-
- ! choose best differentiator kernels
- SELECT CASE(sx3)
- CASE (5:14)
- len3=7
- ker3(1:len3)=fir7(1:len3)
- CASE (15:)
- len3=1
- ker3(1:len3)=fir1(1:len3)
- CASE DEFAULT
- WRITE_DEBUG_INFO
- WRITE (0,'("optimalfilter: invalid dimension. exiting.")')
- STOP 2
- END SELECT
-
- END SUBROUTINE optimalfilter
-
- !-----------------------------------------------------------------
- !> subroutine StressUpdate
- !! computes the 3-d stress tensor sigma_ij' from the current
- !! deformation field. Strain is the second order tensor
- !!
- !! \f[ \epsilon_{ij} = \frac{1}{2} ( u_{i,j} + u_{j,i} ) \f]
- !!
- !! The displacement derivatives are approximated numerically by the
- !! application of a differentiator space-domain finite impulse
- !! response filter. Coefficients of the filter can be obtained with
- !! the MATLAB command line
- !!
- !!\verbatim
- !! firpm(14, ...
- !! [0 7.0e-1 8.000000e-1 8.500000e-1 9.000000e-1 1.0e+0],...
- !! [0 7.0e-1 5.459372e-1 3.825260e-1 2.433534e-1 0.0e+0]*pi,...
- !! 'differentiator');
- !!\endverbatim
- !!
- !! The kernel is odd and antisymmetric and only half the numbers
- !! are stored in this code. Kernels of different sizes are readilly
- !! available in the 'kernelX.inc' files. Stress tensor field is
- !! obtained by application of Hooke's law
- !!
- !! \f[ \sigma' = - C' : E \f]
- !!
- !! or in indicial notation
- !!
- !!
- !! \f[ \sigma_{ij}' = -\lambda'*\delta_{ij}*\epsilon_{kk} - 2*\mu'*\epsilon_{ij}\f]
- !!
- !! where C' is the heterogeneous elastic moduli tensor and lambda'
- !! and mu' are the inhomogeneous lame parameters
- !!
- !! \f[ C' = C(x) - C_0 \f]
- !!
- !! For isotropic materials
- !!
- !! \f[ \mu'(x) = \mu(x) - \mu_0 \f]
- !! \f[ \lambda'(x) = \lambda(x) - \lambda_0 \f]
- !!
- !! Optionally, the surface traction sigma_i3 can be sampled.
- !!
- !! \author sylvain barbot (10/10/07) - original form
- !! - optional sample of normal stress
- !! (02/12/09) - OpemMP parallel implementation
- !-----------------------------------------------------------------
- SUBROUTINE stressupdate(v1,v2,v3,lambda,mu,dx1,dx2,dx3,sx1,sx2,sx3,sig)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: dx1,dx2,dx3,lambda,mu
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: v1,v2,v3
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v1,v2,v3
-#endif
- TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: sig
-
- TYPE(TENSOR) :: t
- INTEGER :: i1,i2,i3,i3p,i3m,len1,len2,len3
- REAL*8 :: px3
- REAL*8, DIMENSION(16) :: ker1,ker2,ker3
-
- ! load FIR differentiator filter
- CALL optimalfilter(ker1,ker2,ker3,len1,len2,len3,sx1,sx2,sx3)
- ker1=ker1/dx1; ker2=ker2/dx2; ker3=ker3/dx3;
-
- ! no periodicity in the 3rd direction
- ! use a simple finite difference scheme
- DO i3=1,sx3
-
- IF ((i3 .gt. len3) .and. (i3 .lt. (sx3-len3+1))) &
- CYCLE
-
- IF (i3 .eq. 1) THEN
- ! right-centered finite difference
- px3=dx3; i3p=2; i3m=1
- ELSE
- IF (i3 .eq. sx3) THEN
- ! left-centered finite difference
- px3=dx3; i3p=sx3; i3m=sx3-1
- ELSE
- ! centered finite difference
- px3=dx3*2._8; i3m=i3-1; i3p=i3+1
- END IF
- END IF
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL localstrain_ani(t,i3m,i3p,px3)
- CALL isotropicstressstrain(t,lambda,mu)
- sig(i1,i2,i3)=sig(i1,i2,i3) .plus. t
- END DO
- END DO
- END DO
-
- ! intermediate depth treated isotropically
-!$omp parallel do private(i1,i2,t)
- DO i3=len3+1,sx3-len3
- DO i2=1,sx2
- DO i1=1,sx1
- ! Finite Impulse Response filter
- !CALL localstrain_fir(t)
- CALL localstrain_fir2(t,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,v1,v2,v3,sx1,sx2,sx3)
- CALL isotropicstressstrain(t,lambda,mu)
- sig(i1,i2,i3)=sig(i1,i2,i3) .plus. t
- END DO
- END DO
- END DO
-!$omp end parallel do
-
- CONTAINS
-
- !---------------------------------------------------------------
- !> LocalStrain_FIR2
- !! implements a finite impulse response filter (FIR) to estimate
- !! derivatives and strain components. the compatibility with the
- !! OpenMP parallel execution requires that all variable be
- !! tractable from the calling routine.
- !!
- !! \author sylvain barbot (10/10/07) - original form
- ! (03/05/08) - implements 3 filters
- ! (02/12/09) - compatibility with OpenMP (scope)
- !---------------------------------------------------------------
- SUBROUTINE localstrain_fir2(e,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,v1,v2,v3,sx1,sx2,sx3)
- TYPE(TENSOR), INTENT(OUT) :: e
- INTEGER, INTENT(IN) :: len1,len2,len3,i1,i2,i3,sx1,sx2,sx3
- REAL*8, INTENT(IN), DIMENSION(len1) :: ker1
- REAL*8, INTENT(IN), DIMENSION(len2) :: ker2
- REAL*8, INTENT(IN), DIMENSION(len3) :: ker3
- REAL*4, INTENT(IN), DIMENSION(:,:,:) :: v1,v2,v3
-
- INTEGER :: l,i1m,i2m,i3m,i1p,i2p,i3p
-
- e=TENSOR(0._4,0._4,0._4,0._4,0._4,0._4)
-
- DO l=1,len1
- ! neighbor samples with periodic boundary conditions
- i1m=mod(sx1+i1-1-l,sx1)+1
- i1p=mod(i1-1+l,sx1)+1
-
- e%s11=e%s11+(v1(i1p,i2,i3)-v1(i1m,i2,i3))*ker1(l)
- e%s12=e%s12+(v2(i1p,i2,i3)-v2(i1m,i2,i3))*ker1(l)
- e%s13=e%s13+(v3(i1p,i2,i3)-v3(i1m,i2,i3))*ker1(l)
- END DO
-
- DO l=1,len2
- ! neighbor samples with periodic boundary conditions
- i2m=mod(sx2+i2-1-l,sx2)+1
- i2p=mod(i2-1+l,sx2)+1
-
- e%s12=e%s12+(v1(i1,i2p,i3)-v1(i1,i2m,i3))*ker2(l)
- e%s22=e%s22+(v2(i1,i2p,i3)-v2(i1,i2m,i3))*ker2(l)
- e%s23=e%s23+(v3(i1,i2p,i3)-v3(i1,i2m,i3))*ker2(l)
- END DO
-
- DO l=1,len3
- ! neighbor samples in semi-infinite solid
- i3m=i3-l
- i3p=i3+l
-
- e%s13=e%s13+(v1(i1,i2,i3p)-v1(i1,i2,i3m))*ker3(l)
- e%s23=e%s23+(v2(i1,i2,i3p)-v2(i1,i2,i3m))*ker3(l)
- e%s33=e%s33+(v3(i1,i2,i3p)-v3(i1,i2,i3m))*ker3(l)
- END DO
-
- e%s12=e%s12/2._8
- e%s13=e%s13/2._8
- e%s23=e%s23/2._8
-
- END SUBROUTINE localstrain_fir2
-
- !---------------------------------------------------------------
- !> LocalStrain_FIR
- !! implements a finite impulse response filter (FIR) to estimate
- !! derivatives and strain components.
- !!
- !! \author sylvain barbot (10/10/07) - original form
- !! (03/05/08) - implements 3 filters
- !---------------------------------------------------------------
- SUBROUTINE localstrain_fir(e)
- TYPE(TENSOR), INTENT(OUT) :: e
-
- INTEGER :: l,i1m,i2m,i3m,i1p,i2p,i3p
-
- e=TENSOR(0._4,0._4,0._4,0._4,0._4,0._4)
-
- DO l=1,len1
- ! neighbor samples with periodic boundary conditions
- i1m=mod(sx1+i1-1-l,sx1)+1
- i1p=mod(i1-1+l,sx1)+1
-
- e%s11=e%s11+(v1(i1p,i2,i3)-v1(i1m,i2,i3))*ker1(l)
- e%s12=e%s12+(v2(i1p,i2,i3)-v2(i1m,i2,i3))*ker1(l)
- e%s13=e%s13+(v3(i1p,i2,i3)-v3(i1m,i2,i3))*ker1(l)
- END DO
-
- DO l=1,len2
- ! neighbor samples with periodic boundary conditions
- i2m=mod(sx2+i2-1-l,sx2)+1
- i2p=mod(i2-1+l,sx2)+1
-
- e%s12=e%s12+(v1(i1,i2p,i3)-v1(i1,i2m,i3))*ker2(l)
- e%s22=e%s22+(v2(i1,i2p,i3)-v2(i1,i2m,i3))*ker2(l)
- e%s23=e%s23+(v3(i1,i2p,i3)-v3(i1,i2m,i3))*ker2(l)
- END DO
-
- DO l=1,len3
- ! neighbor samples in semi-infinite solid
- i3m=i3-l
- i3p=i3+l
-
- e%s13=e%s13+(v1(i1,i2,i3p)-v1(i1,i2,i3m))*ker3(l)
- e%s23=e%s23+(v2(i1,i2,i3p)-v2(i1,i2,i3m))*ker3(l)
- e%s33=e%s33+(v3(i1,i2,i3p)-v3(i1,i2,i3m))*ker3(l)
- END DO
-
- e%s12=e%s12/2._8
- e%s13=e%s13/2._8
- e%s23=e%s23/2._8
-
- END SUBROUTINE localstrain_fir
-
- !---------------------------------------------------------------
- !> LocalStrain_ANI
- !! implements a different finite impulse response filter (FIR)
- !! in each direction (ANIsotropy) to estimate derivatives and
- !! strain components.
- !
- ! sylvain barbot (10/10/07) - original form
- ! (03/05/09) - implements 3 filters
- !---------------------------------------------------------------
- SUBROUTINE localstrain_ani(e,i3m,i3p,px3)
- TYPE(TENSOR), INTENT(OUT) :: e
- INTEGER, INTENT(IN) :: i3m, i3p
- REAL*8, INTENT(IN) :: px3
-
- INTEGER :: l,i1m,i2m,i1p,i2p,foo,dum
-
- e=TENSOR(0._4,0._4,0._4,0._4,0._4,0._4)
-
- DO l=1,len1
- ! neighbor samples with periodic boundary conditions
- i1m=mod(sx1+i1-1-l,sx1)+1
- i1p=mod(i1-1+l,sx1)+1
-
- e%s11=e%s11+(v1(i1p,i2,i3)-v1(i1m,i2,i3))*ker1(l)
- e%s12=e%s12+(v2(i1p,i2,i3)-v2(i1m,i2,i3))*ker1(l)
- e%s13=e%s13+(v3(i1p,i2,i3)-v3(i1m,i2,i3))*ker1(l)
- END DO
-
- DO l=1,len2
- ! neighbor samples with periodic boundary conditions
- i2m=mod(sx2+i2-1-l,sx2)+1
- i2p=mod(i2-1+l,sx2)+1
-
- e%s12=e%s12+(v1(i1,i2p,i3)-v1(i1,i2m,i3))*ker2(l)
- e%s22=e%s22+(v2(i1,i2p,i3)-v2(i1,i2m,i3))*ker2(l)
- e%s23=e%s23+(v3(i1,i2p,i3)-v3(i1,i2m,i3))*ker2(l)
- END DO
-
- ! finite difference in the 3rd direction
- e%s13=e%s13 + (v1(i1,i2,i3p)-v1(i1,i2,i3m))/px3
- e%s23=e%s23 + (v2(i1,i2,i3p)-v2(i1,i2,i3m))/px3
- e%s33=(v3(i1,i2,i3p)-v3(i1,i2,i3m))/px3
-
- e%s12=e%s12/2._8
- e%s13=e%s13/2._8
- e%s23=e%s23/2._8
-
- END SUBROUTINE localstrain_ani
-
- END SUBROUTINE stressupdate
-
- !-----------------------------------------------------------------
- !> subroutine EquivalentBodyForce
- !! computes and updates the equivalent body-force
- !!
- !! f = - div.( C : E^i )
- !!
- !! and the equivalent surface traction
- !!
- !! t = n . C : E^i
- !!
- !! with n = (0,0,-1). In indicial notations
- !!
- !! f_i = - (C_ijkl E^i_kl),j
- !!
- !! and
- !!
- !! t_1 = n_j C_ijkl E^i_kl
- !!
- !! where f is the equivalent body-force, t is the equivalent surface
- !! traction, C is the elastic moduli tensor and E^i is the moment
- !! density tensor tensor.
- !!
- !! Divergence is computed with a mixed numerical scheme including
- !! centered finite-difference (in the vertical direction) and
- !! finite impulse response differentiator filter for derivatives
- !! estimates. see function 'stress' for further explanations.
- !!
- !! \author sylvain barbot (07/09/07) - original form
- !! (10/09/07) - upgrade the finite difference scheme
- !! to a finite impulse response filter
- !! (02/12/09) - OpenMP parallel implementation
- !-----------------------------------------------------------------
- SUBROUTINE equivalentbodyforce(sig,dx1,dx2,dx3,sx1,sx2,sx3, &
- c1,c2,c3,t1,t2,t3,mask)
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
-#ifdef ALIGN_DATA
- REAL*4, INTENT(INOUT), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
- REAL*4, INTENT(INOUT), DIMENSION(sx1+2,sx2) :: t1,t2,t3
-#else
- REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
- REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2) :: t1,t2,t3
-#endif
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- REAL*4, INTENT(IN), DIMENSION(sx3), OPTIONAL :: mask
-
- INTEGER :: i1,i2,i3,i3m,i3p,len1,len2,len3
- REAL*8 :: f1,f2,f3,px3
- REAL*8, DIMENSION(16) :: ker1,ker2,ker3
-
- CALL optimalfilter(ker1,ker2,ker3,len1,len2,len3,sx1,sx2,sx3)
- ker1=ker1/dx1; ker2=ker2/dx2; ker3=ker3/dx3
-
- ! equivalent surface traction
- DO i2=1,sx2
- DO i1=1,sx1
- t1(i1,i2)=t1(i1,i2)+sig(i1,i2,1)%s13
- t2(i1,i2)=t2(i1,i2)+sig(i1,i2,1)%s23
- t3(i1,i2)=t3(i1,i2)+sig(i1,i2,1)%s33
- END DO
- END DO
-
- ! no periodicity in the 3rd direction
- ! use a simple finite difference scheme in the 3rd direction
-!$omp parallel
-!$omp do private(i1,i2,f1,f2,f3,px3,i3m,i3p)
- DO i3=1,sx3
-
- IF ((i3 .gt. len3) .and. (i3 .lt. (sx3-len3+1))) &
- CYCLE
-
- IF (PRESENT(mask)) THEN
- IF (mask(i3) .EQ. 0) THEN
- CYCLE
- END IF
- END IF
-
- IF (i3 .eq. 1) THEN
- ! right-centered finite difference
- px3=dx3; i3p=2; i3m=1
- ELSE
- IF (i3 .eq. sx3) THEN
- ! left-centered finite difference
- px3=dx3; i3p=sx3; i3m=sx3-1
- ELSE
- ! centered finite difference
- px3=dx3*2._8; i3m=i3-1; i3p=i3+1
- END IF
- END IF
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL localdivergence_ani(f1,f2,f3,i3m,i3p,px3, &
- i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,sig,sx1,sx2,sx3)
-
- c1(i1,i2,i3)=c1(i1,i2,i3)-REAL(f1)
- c2(i1,i2,i3)=c2(i1,i2,i3)-REAL(f2)
- c3(i1,i2,i3)=c3(i1,i2,i3)-REAL(f3)
-
- END DO
- END DO
- END DO
-!$omp end do nowait
-
- ! intermediate depth treated isotropically
-!$omp do private(i1,i2,f1,f2,f3)
- DO i3=len3+1,sx3-len3
-
- IF (PRESENT(mask)) THEN
- IF (mask(i3) .EQ. 0) THEN
- CYCLE
- END IF
- END IF
-
- DO i2=1,sx2
- DO i1=1,sx1
- ! Finite Impulse Response filter
- !CALL localdivergence_fir(f1,f2,f3)
- CALL localdivergence_fir2(f1,f2,f3,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,sig,sx1,sx2,sx3)
-
- c1(i1,i2,i3)=c1(i1,i2,i3)-REAL(f1)
- c2(i1,i2,i3)=c2(i1,i2,i3)-REAL(f2)
- c3(i1,i2,i3)=c3(i1,i2,i3)-REAL(f3)
- END DO
- END DO
- END DO
-!$omp end do
-!$omp end parallel
-
- CONTAINS
-
- !---------------------------------------------------------------
- ! LocalDivergence_FIR
- ! implements a finite impulse response filter (FIR) to estimate
- ! the divergence of second-order tensor.
- !
- ! ATTENTION - calls to this routine can cause memory leak.
- !
- ! sylvain barbot (10/10/07) - original form
- ! (03/05/08) - implements 3 filters
- ! (02/11/09) - compatibility with OpenMP
- !---------------------------------------------------------------
- SUBROUTINE localdivergence_fir2(f1,f2,f3,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,sig,sx1,sx2,sx3)
- REAL*8, INTENT(OUT) :: f1,f2,f3
- INTEGER, INTENT(IN) :: len1,len2,len3,i1,i2,i3,sx1,sx2,sx3
- REAL*8, INTENT(IN), DIMENSION(len1) :: ker1
- REAL*8, INTENT(IN), DIMENSION(len2) :: ker2
- REAL*8, INTENT(IN), DIMENSION(len3) :: ker3
- TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: sig
-
- INTEGER :: l,i1m,i1p,i2m,i2p,i3m,i3p
-
- f1=0._8; f2=0._8; f3=0._8
-
- DO l=1,len1
- ! neighbor samples with periodic boundary conditions
- i1m=mod(sx1+i1-1-l,sx1)+1
- i1p=mod(i1-1+l,sx1)+1
-
- f1=f1+(sig(i1p,i2,i3)%s11-sig(i1m,i2,i3)%s11)*ker1(l)
- f2=f2+(sig(i1p,i2,i3)%s12-sig(i1m,i2,i3)%s12)*ker1(l)
- f3=f3+(sig(i1p,i2,i3)%s13-sig(i1m,i2,i3)%s13)*ker1(l)
- END DO
-
- DO l=1,len2
- ! neighbor samples with periodic boundary conditions
- i2m=mod(sx2+i2-1-l,sx2)+1
- i2p=mod(i2-1+l,sx2)+1
-
- f1=f1+(sig(i1,i2p,i3)%s12-sig(i1,i2m,i3)%s12)*ker2(l)
- f2=f2+(sig(i1,i2p,i3)%s22-sig(i1,i2m,i3)%s22)*ker2(l)
- f3=f3+(sig(i1,i2p,i3)%s23-sig(i1,i2m,i3)%s23)*ker2(l)
- END DO
-
- DO l=1,len3
- ! neighbor samples in semi-infinite solid
- i3m=i3-l
- i3p=i3+l
-
- f1=f1+(sig(i1,i2,i3p)%s13-sig(i1,i2,i3m)%s13)*ker3(l)
- f2=f2+(sig(i1,i2,i3p)%s23-sig(i1,i2,i3m)%s23)*ker3(l)
- f3=f3+(sig(i1,i2,i3p)%s33-sig(i1,i2,i3m)%s33)*ker3(l)
- END DO
-
- END SUBROUTINE localdivergence_fir2
-
- !---------------------------------------------------------------
- ! LocalDivergence_FIR
- ! implements a finite impulse response filter (FIR) to estimate
- ! the divergence of second-order tensor.
- !
- ! ATTENTION - calls to this routine can cause memory leak.
- !
- ! sylvain barbot (10/10/07) - original form
- ! (03/05/08) - implements 3 filters
- !---------------------------------------------------------------
- SUBROUTINE localdivergence_fir(f1,f2,f3)
- REAL*8, INTENT(OUT) :: f1,f2,f3
-
- INTEGER :: l,i1m,i1p,i2m,i2p,i3m,i3p
-
- f1=0._8; f2=0._8; f3=0._8
-
- DO l=1,len1
- ! neighbor samples with periodic boundary conditions
- i1m=mod(sx1+i1-1-l,sx1)+1
- i1p=mod(i1-1+l,sx1)+1
-
- f1=f1+(sig(i1p,i2,i3)%s11-sig(i1m,i2,i3)%s11)*ker1(l)
- f2=f2+(sig(i1p,i2,i3)%s12-sig(i1m,i2,i3)%s12)*ker1(l)
- f3=f3+(sig(i1p,i2,i3)%s13-sig(i1m,i2,i3)%s13)*ker1(l)
- END DO
-
- DO l=1,len2
- ! neighbor samples with periodic boundary conditions
- i2m=mod(sx2+i2-1-l,sx2)+1
- i2p=mod(i2-1+l,sx2)+1
-
- f1=f1+(sig(i1,i2p,i3)%s12-sig(i1,i2m,i3)%s12)*ker2(l)
- f2=f2+(sig(i1,i2p,i3)%s22-sig(i1,i2m,i3)%s22)*ker2(l)
- f3=f3+(sig(i1,i2p,i3)%s23-sig(i1,i2m,i3)%s23)*ker2(l)
- END DO
-
- DO l=1,len3
- ! neighbor samples in semi-infinite solid
- i3m=i3-l
- i3p=i3+l
-
- f1=f1+(sig(i1,i2,i3p)%s13-sig(i1,i2,i3m)%s13)*ker3(l)
- f2=f2+(sig(i1,i2,i3p)%s23-sig(i1,i2,i3m)%s23)*ker3(l)
- f3=f3+(sig(i1,i2,i3p)%s33-sig(i1,i2,i3m)%s33)*ker3(l)
- END DO
-
- END SUBROUTINE localdivergence_fir
-
- !---------------------------------------------------------------
- ! LocalDivergence_ANI
- ! implements a finite impulse response filter (FIR) in the
- ! horizontal direction and a finite-difference scheme in the
- ! vertical direction to estimate the divergence of second-order
- ! tensor.
- ! Finite difference scheme is left-centered, right-centered or
- ! symmetric, depending on input positions (i3m,i3p) and spacing
- ! (px3).
- !
- ! sylvain barbot (10/10/07) - original form
- ! (03/05/08) - implements 3 filters
- ! (02/12/09) - compatibility with OpenMP
- !---------------------------------------------------------------
- SUBROUTINE localdivergence_ani(f1,f2,f3,i3m,i3p,px3,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,sig,sx1,sx2,sx3)
- REAL*8, INTENT(OUT) :: f1,f2,f3
- INTEGER, INTENT(IN) :: i3m,i3p,i1,i2,i3,len1,len2,len3,sx1,sx2,sx3
- REAL*8, INTENT(IN), DIMENSION(len1) :: ker1
- REAL*8, INTENT(IN), DIMENSION(len2) :: ker2
- REAL*8, INTENT(IN), DIMENSION(len3) :: ker3
- REAL*8, INTENT(IN) :: px3
- TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: sig
-
- INTEGER :: l,i1m,i1p,i2m,i2p,foo,dum
-
- f1=0._8; f2=0._8; f3=0._8
-
- ! differentiator filter in the horizontal direction
- DO l=1,len1
- ! neighbor samples with periodic boundary conditions
- i1m=mod(sx1+i1-1-l,sx1)+1
- i1p=mod(i1-1+l,sx1)+1
-
- f1=f1+(sig(i1p,i2,i3)%s11-sig(i1m,i2,i3)%s11)*ker1(l)
- f2=f2+(sig(i1p,i2,i3)%s12-sig(i1m,i2,i3)%s12)*ker1(l)
- f3=f3+(sig(i1p,i2,i3)%s13-sig(i1m,i2,i3)%s13)*ker1(l)
- END DO
-
- DO l=1,len2
- ! neighbor samples with periodic boundary conditions
- i2m=mod(sx2+i2-1-l,sx2)+1
- i2p=mod(i2-1+l,sx2)+1
-
- f1=f1+(sig(i1,i2p,i3)%s12-sig(i1,i2m,i3)%s12)*ker2(l)
- f2=f2+(sig(i1,i2p,i3)%s22-sig(i1,i2m,i3)%s22)*ker2(l)
- f3=f3+(sig(i1,i2p,i3)%s23-sig(i1,i2m,i3)%s23)*ker2(l)
- END DO
-
- ! finite difference in the 3-direction
- f1=f1+( sig(i1,i2,i3p)%s13-sig(i1,i2,i3m)%s13 )/px3
- f2=f2+( sig(i1,i2,i3p)%s23-sig(i1,i2,i3m)%s23 )/px3
- f3=f3+( sig(i1,i2,i3p)%s33-sig(i1,i2,i3m)%s33 )/px3
-
- END SUBROUTINE localdivergence_ani
-
- !-------------------------------------------------------------------
- ! subroutine LocalDivergence_CFD
- ! estimate the divergence of the stress tensor by means of simple
- ! finite difference schemes. In the horizontal direction, numerical
- ! scheme is always centered finite difference. because of the
- ! surface and bottom boundary condition, scheme in the vertical
- ! direction changes from right-centered at the top, to center in the
- ! middle, to left-centered finite difference at the bottom.
- !-------------------------------------------------------------------
- SUBROUTINE localdivergence_cfd(f1,f2,f3,i3m,i3p,px3)
- REAL*8, INTENT(OUT) :: f1,f2,f3
- REAL*8, INTENT(IN) :: px3
- INTEGER, INTENT(IN) :: i3m, i3p
-
- INTEGER :: i1m,i1p,i2m,i2p
-
- ! neighbor samples
- i1m=mod(sx1+i1-2,sx1)+1
- i1p=mod(i1,sx1)+1
- i2m=mod(sx2+i2-2,sx2)+1
- i2p=mod(i2,sx2)+1
-
- f1= ( sig(i1p,i2,i3)%s11-sig(i1m,i2,i3)%s11 )/dx1/2._8 &
- +( sig(i1,i2p,i3)%s12-sig(i1,i2m,i3)%s12 )/dx2/2._8 &
- +( sig(i1,i2,i3p)%s13-sig(i1,i2,i3m)%s13 )/px3
- f2= ( sig(i1p,i2,i3)%s12-sig(i1m,i2,i3)%s12 )/dx1/2._8 &
- +( sig(i1,i2p,i3)%s22-sig(i1,i2m,i3)%s22 )/dx2/2._8 &
- +( sig(i1,i2,i3p)%s23-sig(i1,i2,i3m)%s23 )/px3
- f3= ( sig(i1p,i2,i3)%s13-sig(i1m,i2,i3)%s13 )/dx1/2._8 &
- +( sig(i1,i2p,i3)%s23-sig(i1,i2m,i3)%s23 )/dx2/2._8 &
- +( sig(i1,i2,i3p)%s33-sig(i1,i2,i3m)%s33 )/px3
-
- END SUBROUTINE localdivergence_cfd
-
- END SUBROUTINE equivalentbodyforce
-
-
- !---------------------------------------------------------------------
- !> function SourceSpectrum
- !! computes the equivalent body-forces for a buried dislocation,
- !! with strike-slip and dip-slip components,
- !! slip s, width W, length L in a rigidity mu
- !!
- !! \author sylvain barbot (06-25-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE sourcespectrum(mu,s,x,y,d, &
- L,W,strike,dip,rake,beta,dx1,dx2,dx3,f1,f2,f3)
- REAL*8, INTENT(IN) :: mu,s,x,y,d,L,W,strike,dip,rake,&
- beta,dx1,dx2,dx3
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: f1,f2,f3
-
- INTEGER :: i1,i2,i3,sx1,sx2,sx3
- REAL*8 :: k1,k2,k3,k1s,k2s,k3s,k1i,k3i, &
- cstrike,sstrike,cdip,sdip,cr,sr,k2r
- COMPLEX*8 :: cbuf1,cbuf2,cbuf3,source,image,&
- shift,scale,aperture,up,down
- COMPLEX*8, PARAMETER :: i=CMPLX(0._8,pi2)
-
- sx1=SIZE(f2,1)-2
- sx2=SIZE(f2,2)
- sx3=SIZE(f2,3)
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
- cr=cos(rake)
- sr=sin(rake)
- scale=i*mu*s*L*W
-
- DO i3=1,sx3
- CALL wavenumber3(i3,sx3,dx3,k3)
- down=exp(-i*k3*(L/2._8+d))
- up=conjg(down)
- DO i2=1,sx2
- CALL wavenumber2(i2,sx2,dx2,k2)
- DO i1=1,sx1/2+1
- CALL wavenumber1(i1,sx1,dx1,k1)
-
- !rotate the wavenumbers
- k2r= cstrike*k1-sstrike*k2
- k1s= cdip*k2r-sdip*k3
- k2s= sstrike*k1+cstrike*k2
- k3s= sdip*k2r+cdip*k3
- k1i= cdip*k2r+sdip*k3
- k3i=-sdip*k2r+cdip*k3
-
- !integrate at depth and along strike with raised cosine taper
- !and shift sources to x,y,z coordinate
- shift=exp(-i*(x*k1+y*k2))
- aperture=scale*omegak(W*k2s,beta)
- source=omegak(L*k3s,beta)*aperture*shift*down
- image =omegak(L*k3i,beta)*aperture*shift*up
-
- !convolve source and image with a 1-D gaussian
- source=source*exp(-(pi*dx1*k1s)**2)
- image = image*exp(-(pi*dx1*k1i)**2)
-
- cbuf1= cdip*cstrike*( &
- -(cr*k2s+sr*k3s)*source-(cr*k2s-sr*k3i)*image) &
- +cr*sstrike*(-k1s*source-k1i*image) &
- -sr*sdip*cstrike*(-k1s*source-k1i*image)
- !change -sr*sdip back to +sr*sdip above and below
- cbuf2=-cdip*sstrike*( &
- -(cr*k2s+sr*k3s)*source-(cr*k2s-sr*k3i)*image) &
- +cr*cstrike*(-k1s*source-k1i*image) &
- -sr*sdip*sstrike*(-k1s*source-k1i*image)
- !change -sdip back to +sdip here
- cbuf3=-sdip*((-sr*k3s-cr*k2s)*source &
- +(-sr*k3i+cr*k2s)*image) &
- +sr*cdip*(-k1s*source+k1i*image)
-
- f1(2*i1-1:2*i1,i2,i3)=&
- f1(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf1),AIMAG(cbuf1)/)
- f2(2*i1-1:2*i1,i2,i3)=&
- f2(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf2),AIMAG(cbuf2)/)
- f3(2*i1-1:2*i1,i2,i3)=&
- f3(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf3),AIMAG(cbuf3)/)
- END DO
- END DO
- END DO
-
- END SUBROUTINE sourcespectrum
-
-
- !---------------------------------------------------------------------
- !> function SourceSpectrumHalfSpace
- !! computes the equivalent body-forces for a buried dislocation,
- !! with strike-slip and dip-slip components,
- !! slip s, width W, length L in a rigidity mu; sources are not imaged
- !!
- !! \author sylvain barbot (06-25-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE sourcespectrumhalfspace(mu,s,x,y,d, &
- L,W,strike,dip,rake,beta,dx1,dx2,dx3,f1,f2,f3)
- REAL*8, INTENT(IN) :: mu,s,x,y,d,L,W,strike,dip,rake,&
- beta,dx1,dx2,dx3
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: f1,f2,f3
-
- INTEGER :: i1,i2,i3,sx1,sx2,sx3
- REAL*8 :: k1,k2,k3,k1s,k2s,k3s, &
- cstrike,sstrike,cdip,sdip,cr,sr,k2r
- COMPLEX*8 :: cbuf1,cbuf2,cbuf3,source,&
- shift,scale,aperture,down
- COMPLEX*8, PARAMETER :: i=CMPLX(0._8,pi2)
-
- sx1=SIZE(f2,1)-2
- sx2=SIZE(f2,2)
- sx3=SIZE(f2,3)
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
- cr=cos(rake)
- sr=sin(rake)
- scale=i*mu*s*L*W
-
- DO i3=1,sx3
- CALL wavenumber3(i3,sx3,dx3,k3)
- down=exp(-i*k3*(L/2._8+d))
- DO i2=1,sx2
- CALL wavenumber2(i2,sx2,dx2,k2)
- DO i1=1,sx1/2+1
- CALL wavenumber1(i1,sx1,dx1,k1)
- !rotate the wavenumbers
- k2r= cstrike*k1-sstrike*k2
- k1s= cdip*k2r-sdip*k3
- k2s= sstrike*k1+cstrike*k2
- k3s= sdip*k2r+cdip*k3
-
- !convolve source and image with a 1-D gaussian
- !integrate at depth and along strike with raised cosine taper
- !and shift sources to x,y,z coordinate
- shift=exp(-i*(x*k1+y*k2))
- aperture=scale*omegak(W*k2s,beta)*exp(-(pi*dx1*k1s)**2)
- source=(omegak(L*k3s,beta)*aperture)*shift*down
-
- cbuf1= cdip*cstrike*( &
- -(cr*k2s+sr*k3s)*source) &
- +cr*sstrike*(-k1s*source) &
- -sr*sdip*cstrike*(-k1s*source)
- cbuf2=-cdip*sstrike*( &
- -(cr*k2s+sr*k3s)*source) &
- +cr*cstrike*(-k1s*source) &
- -sr*sdip*sstrike*(-k1s*source)
- cbuf3=-sdip*((-sr*k3s-cr*k2s)*source) &
- +sr*cdip*(-k1s*source)
-
- f1(2*i1-1:2*i1,i2,i3)=&
- f1(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf1),AIMAG(cbuf1)/)
- f2(2*i1-1:2*i1,i2,i3)=&
- f2(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf2),AIMAG(cbuf2)/)
- f3(2*i1-1:2*i1,i2,i3)=&
- f3(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf3),AIMAG(cbuf3)/)
- END DO
- END DO
- END DO
-
- END SUBROUTINE sourcespectrumhalfspace
-
- !---------------------------------------------------------------------
- !> function Source computes the equivalent body-forces
- !! in the space domain for a buried dislocation with strike-slip
- !! and dip-slip components, slip s, width W, length L in a rigidity mu
- !!
- !! Default (strike=0, dip=0, rake=0) is a vertical left-lateral
- !! strike-slip fault along the x2 axis. Default fault slip is
- !! represented with the double-couple equivalent body forces:
- !!
- !!\verbatim
- !!
- !! x1
- !! |
- !! | ^ f2
- !! | |<-----
- !! +---+------+---- x2
- !! ----->|
- !! v f1
- !!
- !!\endverbatim
- !!
- !! \author sylvain barbot (06-29-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE source(mu,s,x,y,z,L,W,strike,dip,rake, &
- beta,sx1,sx2,sx3,dx1,dx2,dx3,f1,f2,f3,t1,t2,t3)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: mu,s,x,y,z,L,W,strike,dip,rake, &
- beta,dx1,dx2,dx3
-#ifdef ALIGN_DATA
- REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
- REAL*4, DIMENSION(sx1+2,sx2), INTENT(INOUT) :: t1,t2,t3
-#else
- REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
- REAL*4, DIMENSION(sx1,sx2), INTENT(INOUT) :: t1,t2,t3
-#endif
-
- INTEGER :: i1,i2,i3
- REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
- cstrike,sstrike,cdip,sdip,cr,sr,x2r, &
- sourc,image,scale,temp1,temp2,temp3, &
- dblcp,cplei,dipcs,dipci,xr,yr,zr,Wp,Lp
- REAL(8), DIMENSION(3) :: n,b
- TYPE(TENSOR) :: m
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
- cr=cos(rake)
- sr=sin(rake)
- scale=-mu*s
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta)/2._8
- Lp=L*(1._8+2._8*beta)/2._8
-
- ! rotate centre coordinates of source and images
- x2r= cstrike*x -sstrike*y
- xr = cdip *x2r-sdip *z
- yr = sstrike*x +cstrike*y
- zr = sdip *x2r+cdip *z
-
- ! equivalent surface traction
- i3=1
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
- dx1,dx2,dx3,x1,x2,x3)
-
- IF ((ABS(x1-x).GT.MAX(Lp,Wp)).OR.(ABS(x2-y).GT.MAX(Lp,Wp))) CYCLE
-
- x2r= cstrike*x1-sstrike*x2
- x1s= cdip*x2r-sdip*x3
- x1i= cdip*x2r+sdip*x3
- IF ((ABS(x1s-xr).GT.7.01*dx1).AND.(ABS(x1i-xr).GT.7.01*dx1)) CYCLE
- x2s= sstrike*x1+cstrike*x2
- x3s= sdip*x2r+cdip*x3
- x3i=-sdip*x2r+cdip*x3
-
- ! integrate at depth and along strike with raised cosine taper
- ! and shift sources to x,y,z coordinate
- temp1=gauss(x1s-xr,dx1)
- temp2=omega((x2s-yr)/W,beta)
- temp3=omega((x3s-zr)/L,beta)
- sourc=temp1*temp2*temp3
-
- ! add image
- temp1=gauss(x1i-xr,dx1)
- temp3=omega((x3i+zr)/L,beta)
- sourc=sourc+temp1*temp2*temp3
-
- ! surface normal vector components
- n(1)=+cdip*cstrike*sourc
- n(2)=-cdip*sstrike*sourc
- n(3)=-sdip*sourc
-
- ! burger vector (strike-slip)
- b(1)=sstrike*cr
- b(2)=cstrike*cr
-
- ! burger vector (dip-slip)
- b(1)=b(1)+cstrike*sdip*sr
- b(2)=b(2)-sstrike*sdip*sr
- b(3)= +cdip*sr
-
- ! principal stress (symmetric deviatoric second-order tensor)
- m=n .sdyad. (mu*s*b)
-
- ! surface tractions
- t1(i1,i2)=t1(i1,i2)+m%s13
- t2(i1,i2)=t2(i1,i2)+m%s23
- t3(i1,i2)=t3(i1,i2)+m%s33
-
- END DO
- END DO
-
- ! equivalent body-force density
-!$omp parallel do private(i1,i2,x1,x2,x3,x2r,x1s,x1i,x2s,x3s,x3i,temp1,temp2,temp3), &
-!$omp private(sourc,dblcp,dipcs,image,cplei,dipci)
- DO i3=1,sx3/2
- CALL shiftedcoordinates(1,1,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
- IF ((abs(x3-z).gt.Lp) .and. (abs(x3+z).gt.Lp)) CYCLE
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
- IF ((ABS(x1-x) .GT. MAX(Wp,Lp)) .OR. (abs(x2-y) .GT. MAX(Wp,Lp))) CYCLE
-
- x2r= cstrike*x1-sstrike*x2
- x1s= cdip*x2r-sdip*x3
- x1i= cdip*x2r+sdip*x3
- IF ((ABS(x1s-xr) .GT. 7.01_8*dx1) .AND. (ABS(x1i-xr) .GT. 7.01_8*dx1)) CYCLE
- x2s= sstrike*x1+cstrike*x2
- x3s= sdip*x2r+cdip*x3
- x3i=-sdip*x2r+cdip*x3
-
- !integrate at depth and along strike with raised cosine taper
- !and shift sources to x,y,z coordinate
- temp1=gauss(x1s-xr,dx1)
- temp2=omega((x2s-yr)/W,beta)
- temp3=omega((x3s-zr)/L,beta)
- sourc=scale *gaussp(x1s-xr,dx1) &
- *temp2 &
- *temp3
- dblcp=scale/W*temp1 &
- *omegap((x2s-yr)/W,beta) &
- *temp3
- dipcs=scale/L*temp1 &
- *temp2 &
- *omegap((x3s-zr)/L,beta)
-
- temp1=gauss(x1i-xr,dx1)
- temp3=omega((x3i+zr)/L,beta)
- image=scale *gaussp(x1i-xr,dx1) &
- *temp2 &
- *temp3
- cplei=scale/W*temp1 &
- *omegap((x2s-yr)/W,beta) &
- *temp3
- dipci=scale/L*temp1 &
- *temp2 &
- *omegap((x3i+zr)/L,beta)
-
- ! strike-slip component
-
- IF (2.01_8*DEG2RAD .GT. dip) THEN
- ! use method of images for subvertical faults
- f1(i1,i2,i3)=f1(i1,i2,i3) &
- +cr*sstrike*(sourc+image) &
- +cr*cdip*cstrike*(dblcp+cplei)
- f2(i1,i2,i3)=f2(i1,i2,i3) &
- +cr*cstrike*(sourc+image) &
- -cr*cdip*sstrike*(dblcp+cplei)
- f3(i1,i2,i3)=f3(i1,i2,i3) &
- -cr*sdip*(dblcp-cplei)
- ELSE
- ! dipping faults do not use method of image
- f1(i1,i2,i3)=f1(i1,i2,i3) &
- +cr*sstrike*(sourc) &
- +cr*cdip*cstrike*(dblcp)
- f2(i1,i2,i3)=f2(i1,i2,i3) &
- +cr*cstrike*(sourc) &
- -cr*cdip*sstrike*(dblcp)
- f3(i1,i2,i3)=f3(i1,i2,i3) &
- -cr*sdip*(dblcp)
- END IF
-
- ! dip-slip component
-
- f1(i1,i2,i3)=f1(i1,i2,i3) &
- +cdip*sr*cstrike*dipcs &
- +sdip*sr*cstrike*sourc
- f2(i1,i2,i3)=f2(i1,i2,i3) &
- -cdip*sr*sstrike*dipcs &
- -sdip*sr*sstrike*sourc
- f3(i1,i2,i3)=f3(i1,i2,i3) &
- +cdip*sr*sourc &
- -sdip*sr*dipcs
-
- END DO
- END DO
- END DO
-!$omp end parallel do
-
- END SUBROUTINE source
-
- !---------------------------------------------------------------------
- !> function TensileSource
- !! computes the equivalent body-forces in the space domain for a buried
- !! tensile crack with opening s, width W, length L and Lame parameters
- !! lambda, mu.
- !!
- !! Default (strike=0, dip=0) is a vertical opening along the x2 axis.
- !! Default fault opening is represented with the double-couple
- !! equivalent body forces:
- !!
- !!\verbatim
- !!
- !! x1 f1
- !! | ^^^^^^^
- !! | |||||||
- !! | -f2 <--+-------+--> f2
- !! | |||||||
- !! | vvvvvvv
- !! | -f1
- !! |
- !! +----------------------------- x2
- !!
- !!\endverbatim
- !!
- !! The eigenstrain/potency tensor for a point source is
- !!
- !!\verbatim
- !!
- !! | 1 0 0 |
- !! E^i = | 0 0 0 |
- !! | 0 0 0 |
- !!
- !!\endverbatim
- !!
- !! and the corresponding moment density for a point source is
- !!
- !!\verbatim
- !!
- !! | lambda+2*mu 0 0 |
- !! m = C : E^i = | 0 lambda 0 |
- !! | 0 0 lambda |
- !!
- !!\endverbatim
- !!
- !! Moment density is integrated along the planar surface
- !!
- !! \f[ box(x2) \delta(x1) box(x3) \f]
- !!
- !! where box(x) and delta(x) are the boxcar and the dirac delta
- !! functions, respectively. We use a tapered boxcar, omega_beta(x) and
- !! approximate the delta function by a small gaussian function.
- !! Finally, the equivalent body force is the divergence of the moment
- !! density tensor
- !!
- !! \f[ f_i = - ( m_{ij} )_{,j} \f]
- !!
- !! derivatives are performed analytically on the gaussian and
- !! omega_beta functions.
- !!
- !! \author sylvain barbot (05-09-08) - original form
- !---------------------------------------------------------------------
- SUBROUTINE tensilesource(lambda,mu,s,x,y,z,L,W,strike,dip, &
- beta,sx1,sx2,sx3,dx1,dx2,dx3,f1,f2,f3)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: lambda,mu,s,x,y,z,L,W,strike,dip,&
- beta,dx1,dx2,dx3
-#ifdef ALIGN_DATA
- REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
-#else
- REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
-#endif
-
- INTEGER :: i1,i2,i3
- REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
- cstrike,sstrike,cdip,sdip,x2r,&
- sourc,image,scale1,scale2,temp1,temp2,temp3, &
- dblcp,cplei,dipcs,dipci,xr,yr,zr,Wp,Lp
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta)/2._8
- Lp=L*(1._8+2._8*beta)/2._8
-
- ! rotate centre coordinates of source and images
- x2r= cstrike*x -sstrike*y
- xr = cdip *x2r-sdip *z
- yr = sstrike*x +cstrike*y
- zr = sdip *x2r+cdip *z
- scale1=-s*(lambda+2._8*mu)
- scale2=-s*lambda
-
- DO i3=1,sx3
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
- IF ((abs(x3-z).gt.Lp) .and. (abs(x3+z).gt.Lp)) CYCLE
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
- IF ((abs(x1-x).gt.Wp) .or. (abs(x2-y).gt.Wp)) CYCLE
-
- x2r= cstrike*x1-sstrike*x2
- x1s= cdip*x2r-sdip*x3
- x1i= cdip*x2r+sdip*x3
- IF ((abs(x1s-xr).gt.7.01*dx1).and.(abs(x1i-xr).gt.7.01*dx1)) CYCLE
- x2s= sstrike*x1+cstrike*x2
- x3s= sdip*x2r+cdip*x3
- x3i=-sdip*x2r+cdip*x3
-
- !integrate at depth and along strike with raised cosine taper
- !and shift sources to x,y,z coordinate
- temp1=gauss(x1s-xr,dx1)
- temp2=omega((x2s-yr)/W,beta)
- temp3=omega((x3s-zr)/L,beta)
- sourc=scale1 *gaussp(x1s-xr,dx1) &
- *temp2 &
- *temp3
- dblcp=scale2/W*temp1 &
- *omegap((x2s-yr)/W,beta) &
- *temp3
- dipcs=scale2/L*temp1 &
- *temp2 &
- *omegap((x3s-zr)/L,beta)
-
- temp1=gauss(x1i-xr,dx1)
- temp3=omega((x3i+zr)/L,beta)
- image=scale1 *gaussp(x1i-xr,dx1) &
- *temp2 &
- *temp3
- cplei=scale2/W*temp1 &
- *omegap((x2s-yr)/W,beta) &
- *temp3
- dipci=scale2/L*temp1 &
- *temp2 &
- *omegap((x3i+zr)/L,beta)
-
- ! force moments in original coordinate system
-
- f1(i1,i2,i3)=f1(i1,i2,i3) &
- +cstrike*cdip*(sourc+image) &
- +sstrike*(dblcp+cplei) &
- +cstrike*sdip*(dipcs+dipci)
- f2(i1,i2,i3)=f2(i1,i2,i3) &
- -sstrike*cdip*(sourc+image) &
- +cstrike*(dblcp+cplei) &
- -sstrike*sdip*(dipcs+dipci)
- f3(i1,i2,i3)=f3(i1,i2,i3) &
- -sdip*(sourc-image) &
- +cdip*(dipcs-dipci)
-
- END DO
- END DO
- END DO
-
- END SUBROUTINE tensilesource
-
- !---------------------------------------------------------------------
- !! function MogiSource
- !! computes the equivalent body-forces in the space domain for a buried
- !! dilatation point source.
- !!
- !! The point-source opening o with at position xs in the half space is
- !! associated with eigenstrain
- !!
- !! \f[ E^i = o \frac{1}{3} I \delta(x-x_s) \f]
- !!
- !! where I is the diagonal tensor and delta is the Dirac delta function
- !! (or in index notation E^i_{ij} = o delta_{ij} / 3 delta(xs) ) and
- !! with the moment density
- !!
- !! \f[ m = C : E^i = K o I \delta(x-x_s) \f]
- !!
- !! The equivalent body-force density is
- !!
- !! \f[ f = - \nabla \cdot m = K o \nabla \delta(x-x_s) \f]
- !!
- !! where nabla is the gradient operator. Default source opening is
- !! represented with the isotropic equivalent body-force density:
- !!
- !!\verbatim
- !!
- !! x1
- !! | f1
- !! | ^
- !! | f2 | f2
- !! +---<--+-->---- x2
- !! |
- !! v f1
- !!
- !! x3
- !! | f3
- !! | ^
- !! | f2 | f2
- !! +---<--+-->---- x2
- !! |
- !! v f3
- !!
- !!\endverbatim
- !!
- !! \author sylvain barbot (03-24-09) - original form
- !---------------------------------------------------------------------
- SUBROUTINE mogisource(lambda,mu,o,xs,ys,zs,sx1,sx2,sx3,dx1,dx2,dx3,f1,f2,f3)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: lambda,mu,o,xs,ys,zs,dx1,dx2,dx3
-#ifdef ALIGN_DATA
- REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
-#else
- REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
-#endif
-
- INTEGER :: i1,i2,i3
- REAL*8 :: x1,x2,x3,source1,source2,source3, &
- image1,image2,image3,scale,temp1,temp2,temp3,Wp,Lp
-
- scale=-(lambda+2._8*mu/3._8)*o ! -kappa*o
-
- ! effective dimensions
- Wp=6._8*MAX(dx1,dx2,dx3)
- Lp=6._8*MAX(dx1,dx2,dx3)
-
- DO i3=1,sx3
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
- IF ((abs(x3-zs).gt.Lp) .and. (abs(x3+zs).gt.Lp)) CYCLE
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
- IF ((abs(x1-xs).gt.Wp) .or. (abs(x2-ys).gt.Wp)) CYCLE
-
- temp1=gauss(x1-xs,dx1)
- temp2=gauss(x2-ys,dx2)
- temp3=gauss(x3-zs,dx3)
-
- source1=scale*gaussp(x1-xs,dx1)*temp2*temp3
- source2=scale*temp1*gaussp(x2-ys,dx2)*temp3
- source3=scale*temp1*temp2*gaussp(x3-zs,dx3)
-
- temp3=gauss(x3+zs,dx3)
-
- image1=scale*gaussp(x1-xs,dx1)*temp2*temp3
- image2=scale*temp1*gaussp(x2-ys,dx2)*temp3
- image3=scale*temp1*temp2*gaussp(x3+zs,dx3)
-
- ! equivalent body-force density
- f1(i1,i2,i3)=f1(i1,i2,i3)+(source1+image1)
- f2(i1,i2,i3)=f2(i1,i2,i3)+(source2+image2)
- f3(i1,i2,i3)=f3(i1,i2,i3)+(source3-image3)
-
- END DO
- END DO
- END DO
-
- END SUBROUTINE mogisource
-
- !---------------------------------------------------------------------
- !> subroutine Traction
- !! assigns the traction vector at the surface.
- !!
- !! \author sylvain barbot (07-19-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE traction(mu,e,sx1,sx2,dx1,dx2,t,Dt,t3,rate)
- TYPE(EVENT_STRUC), INTENT(IN) :: e
- INTEGER, INTENT(IN) :: sx1,sx2
- REAL*8, INTENT(IN) :: mu,dx1,dx2,t,Dt
-#ifdef ALIGN_DATA
- REAL*4, DIMENSION(sx1+2,sx2), INTENT(INOUT) :: t3
-#else
- REAL*4, DIMENSION(sx1,sx2), INTENT(INOUT) :: t3
-#endif
- LOGICAL, INTENT(IN), OPTIONAL :: rate
-
- INTEGER :: i,i1,i2,i3
- LOGICAL :: israte
- REAL*8 :: period,phi,amp,L,W,Lp,Wp,x1,x2,x3,x,y,beta
-
- REAL*8, PARAMETER :: pi=3.141592653589793115997963468544185161_8
-
- IF (PRESENT(rate)) THEN
- israte=rate
- ELSE
- israte=.FALSE.
- END IF
-
- ! loop over traction sources
- DO i=1,e%nl
-
- x=e%l(i)%x
- y=e%l(i)%y
-
- L=e%l(i)%length
- W=e%l(i)%width
-
- beta=e%l(i)%beta
-
- ! effective tapered dimensions
- Lp=L*(1._8+2._8*beta)/2._8
- Wp=W*(1._8+2._8*beta)/2._8
-
- i3=1
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,1, &
- dx1,dx2,1.d8,x1,x2,x3)
-
- IF ((ABS(x1-x).GT.MAX(Lp,Wp)).OR.(ABS(x2-y).GT.MAX(Lp,Wp))) CYCLE
-
- amp=omega((x1-x)/L,beta)* &
- omega((x2-y)/W,beta)* &
- mu*e%l(i)%slip
-
- IF (israte) THEN
- ! surface tractions rate
- period=e%l(i)%period
- phi=e%l(i)%phase
-
- t3(i1,i2)=t3(i1,i2)-amp*(sin(2*pi*(t+Dt)/period+phi)-sin(2*pi*t/period+phi))
- ELSE
- IF (e%l(i)%period .LE. 0) THEN
- ! surface tractions
- t3(i1,i2)=t3(i1,i2)-amp
- END IF
- END IF
- END DO
- END DO
- END DO
-
- END SUBROUTINE traction
-
- !---------------------------------------------------------------------
- !! function MomentDensityShear
- !! computes the inelastic irreversible moment density in the space
- !! domain corresponding to a buried dislocation with strike-slip and
- !! dip-slip components (pure shear). A fault along a surface of normal
- !! n_i with a burger vector s_i, is associated with the eigenstrain
- !!
- !! E^i_ij = 1/2 ( n_i s_j + s_i n_j )
- !!
- !! In a heterogeneous medium of elastic moduli tensor C_ijkl, the
- !! corresponding moment density tensor is
- !!
- !! m_ij = C_ijkl E^i_kl
- !!
- !! where C = C(x) is a function of space. Equivalent body forces
- !! representing the set of dislocations can be obtained by evaluating
- !! the divergence of the moment density tensor
- !!
- !! f_i = - ( m_ji ),j
- !!
- !! using the function "EquivalentBodyForce" in this module.
- !!
- !! The default dislocation extends in the x2 direction, with a normal
- !! in the x1 direction. Using the following angular convention,
- !!
- !!\verbatim
- !!
- !! x1 ! x1
- !! n theta | ! n phi |
- !! \ ____| ! \ ____|
- !! \ | ! \ |
- !! \ | ! \ |
- !! -----\+------ x2 ! -----\+------ x3
- !! (x3 down) ! (x2 up)
- !!
- !!\endverbatim
- !!
- !! where theta is the strike and phi is the dip (internal convention),
- !! and introducting the rotation matrices
- !!
- !!\verbatim
- !!
- !! | cos(theta) sin(theta) 0 |
- !! R1 = | -sin(theta) cos(theta) 0 |
- !! | 0 0 1 |
- !!
- !! | cos(phi) 0 sin(phi) |
- !! R2 = | 0 1 0 |
- !! | -sin(phi) 0 cos(phi) |
- !!
- !!\endverbatim
- !!
- !! a normal vector n of arbitrary orientation and the corresponding
- !! strike-slip and dip-slip vector, s and d respectively, are
- !!
- !!\verbatim
- !!
- !! | 1 | | 0 | | 0 |
- !! n = R1 R2 | 0 |, s = R1 R2 | 1 |, d = R1 R2 | 0 |
- !! | 0 | | 0 | | 1 |
- !!
- !!\endverbatim
- !!
- !! vector n, s and d are orthogonal and the corresponding moment
- !! density second order tensor is deviatoric. The method of images is
- !! used to avoid tapering of the fault at the surface.
- !!
- !! \author sylvain barbot (03-02-08) - original form
- !---------------------------------------------------------------------
- SUBROUTINE momentdensityshear(mu,slip,x,y,z,L,W,strike,dip,rake, &
- beta,sx1,sx2,sx3,dx1,dx2,dx3,sig)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: mu,slip,x,y,z,L,W,strike,dip,rake,&
- beta,dx1,dx2,dx3
- TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: sig
-
- INTEGER :: i1,i2,i3
- REAL*4 :: rmu
- REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
- cstrike,sstrike,cdip,sdip,cr,sr,x2r,&
- aperture,temp1,temp2,temp3,xr,yr,zr,Wp,Lp,dum
- REAL*8, DIMENSION(3) :: n,s
- TYPE(TENSOR) :: Ei
-
- rmu=2._4*REAL(mu,4)
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
- cr=cos(rake)
- sr=sin(rake)
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta)/2._8
- Lp=L*(1._8+2._8*beta)/2._8
-
- ! rotate centre coordinates of source and images
- x2r= cstrike*x -sstrike*y
- xr = cdip *x2r-sdip *z
- yr = sstrike*x +cstrike*y
- zr = sdip *x2r+cdip *z
-
- DO i3=1,sx3
- x3=DBLE(i3-1)*dx3
- IF (abs(x3-z) .gt. Lp) CYCLE
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
- dx1,dx2,dx3,x1,x2,dum)
-
- IF ((abs(x1-x).gt.Wp) .or. (abs(x2-y).gt.Wp)) CYCLE
-
- x2r= cstrike*x1-sstrike*x2
- x1s= cdip*x2r-sdip*x3
- x1i= cdip*x2r+sdip*x3
- IF ((abs(x1s-xr).gt.7.01*dx1).and.(abs(x1i-xr).gt.7.01*dx1)) CYCLE
- x2s= sstrike*x1+cstrike*x2
- x3s= sdip*x2r+cdip*x3
- x3i=-sdip*x2r+cdip*x3
-
- ! integrate at depth and along strike with raised cosine taper
- ! and shift sources to x,y,z coordinate
- temp1=gauss(x1s-xr,dx1)
- temp2=omega((x2s-yr)/W,beta)
- temp3=omega((x3s-zr)/L,beta)
- aperture=temp1*temp2*temp3
-
- ! add image
- temp1=gauss(x1i-xr,dx1)
- temp3=omega((x3i+zr)/L,beta)
- aperture=aperture+temp1*temp2*temp3
-
- ! surface normal vector components
- n(1)=+cdip*cstrike*aperture
- n(2)=-cdip*sstrike*aperture
- n(3)=-sdip*aperture
-
- ! strike-slip component
- s(1)=sstrike*cr
- s(2)=cstrike*cr
-
- ! dip-slip component
- s(1)=s(1)+cstrike*sdip*sr
- s(2)=s(2)-sstrike*sdip*sr
- s(3)= +cdip*sr
-
- ! eigenstrain (symmetric deviatoric second-order tensor)
- Ei=n .sdyad. (slip*s)
-
- ! moment density (pure shear)
- sig(i1,i2,i3)=sig(i1,i2,i3) .plus. (rmu .times. Ei)
-
- END DO
- END DO
- END DO
-
- END SUBROUTINE momentdensityshear
-
- !---------------------------------------------------------------------
- !> function MomentDensityTensile
- !! computes the inelastic irreversible moment density in the space
- !! domain corresponding to a buried dislocation with opening (open
- !! crack). A fault along a surface of normal n_i with a burger vector
- !! s_i, is associated with the eigenstrain
- !!
- !! \f[ E^i_{ij} = \frac{1}{2} ( n_i s_j + s_i n_j ) \f]
- !!
- !! The eigenstrain/potency tensor for a point source opening crack is
- !!
- !!\verbatim
- !!
- !! | 1 0 0 |
- !! E^i = | 0 0 0 |
- !! | 0 0 0 |
- !!
- !!\endverbatim
- !!
- !! In a heterogeneous medium of elastic moduli tensor C_ijkl, the
- !! corresponding moment density tensor is
- !!
- !! \f[ m_{ij} = C_{ijkl} E^i_{kl} = \lambda E^i_{kk} \delta_{ij} + 2 \mu E^i_{ij} \f]
- !!
- !! where C = C(x) is a function of space. (We use isotropic elastic
- !! solid, and heterogeneous elastic moduli tensor simplifies to
- !! mu=mu(x) and lambda = lambda(x).) The moment density for a point
- !! source opening crack is
- !!
- !!\verbatim
- !!
- !! | lambda+2*mu 0 0 |
- !! m(x) = | 0 lambda 0 |
- !! | 0 0 lambda |
- !!
- !!\endverbatim
- !!
- !! Moment density m(x) is integrated along the planar surface
- !!
- !! box(x2) delta (x1) box(x3)
- !!
- !! where box(x) and delta(x) are the boxcar and the dirac delta
- !! functions, respectively. Equivalent body forces representing the
- !! set of dislocations can be obtained by evaluating the divergence
- !! of the moment density tensor
- !!
- !! \f[ f_i = - ( m_{ji} ),j \f]
- !!
- !! The corresponding equivalent surface traction is simply
- !!
- !! \f[ t_i = m_{ij} n_j \f]
- !!
- !! Both equivalent body forces and equivalent surface traction are
- !! computed using the function "EquivalentBodyForce" in this module.
- !!
- !! The default dislocation extends in the x2 direction, with a normal
- !! in the x1 direction. Using the following angular convention,
- !!
- !!\verbatim
- !!
- !! x1 ! x1
- !! n theta | ! n phi |
- !! \ ____| ! \ ____|
- !! \ | ! \ |
- !! \ | ! \ |
- !! -----\+------ x2 ! -----\+------ x3
- !! (x3 down) ! (x2 up)
- !!
- !!\endverbatim
- !!
- !! where theta is the strike and phi is the dip, in internal
- !! convention. (Internal angular convention does not correspond to
- !! usual angular convention of geology and conversion between the two
- !! standard is necessary.) Introducting the rotation matrices,
- !!
- !!\verbatim
- !!
- !! | cos(theta) sin(theta) 0 |
- !! R1 = | -sin(theta) cos(theta) 0 |
- !! | 0 0 1 |
- !!
- !! | cos(phi) 0 sin(phi) |
- !! R2 = | 0 1 0 |
- !! | -sin(phi) 0 cos(phi) |
- !!
- !!\endverbatim
- !!
- !! a normal vector n of arbitrary orientation and the corresponding
- !! slip vector s are
- !!
- !!\verbatim
- !!
- !! | 1 | | 1 |
- !! n = R1 R2 | 0 |, s = n = R1 R2 | 0 |
- !! | 0 | | 0 |
- !!
- !!\endverbatim
- !!
- !! The method of images is used to avoid tapering of the fault at
- !! the surface.
- !!
- !! \author sylvain barbot (03-02-08) - original form
- !---------------------------------------------------------------------
- SUBROUTINE momentdensitytensile(lambda,mu,slip,x,y,z,L,W,strike,dip,rake, &
- beta,sx1,sx2,sx3,dx1,dx2,dx3,sig)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: lambda,mu,slip,x,y,z,L,W,strike,dip,rake,&
- beta,dx1,dx2,dx3
- TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: sig
-
- INTEGER :: i1,i2,i3
- REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
- cstrike,sstrike,cdip,sdip,cr,sr,x2r,&
- aperture,temp1,temp2,temp3,xr,yr,zr,Wp,Lp,dum
- REAL*8, DIMENSION(3) :: n
- TYPE(TENSOR) :: Ei
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
- cr=cos(rake)
- sr=sin(rake)
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta)/2._8
- Lp=L*(1._8+2._8*beta)/2._8
-
- ! rotate centre coordinates of source and images
- x2r= cstrike*x -sstrike*y
- xr = cdip *x2r-sdip *z
- yr = sstrike*x +cstrike*y
- zr = sdip *x2r+cdip *z
-
- DO i3=1,sx3
- x3=DBLE(i3-1)*dx3
- IF (abs(x3-z) .gt. Lp) CYCLE
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
- dx1,dx2,dx3,x1,x2,dum)
-
- IF ((abs(x1-x).gt.Wp) .or. (abs(x2-y).gt.Wp)) CYCLE
-
- x2r= cstrike*x1-sstrike*x2
- x1s= cdip*x2r-sdip*x3
- x1i= cdip*x2r+sdip*x3
- IF ((abs(x1s-xr).gt.7.01*dx1).and.(abs(x1i-xr).gt.7.01*dx1)) CYCLE
- x2s= sstrike*x1+cstrike*x2
- x3s= sdip*x2r+cdip*x3
- x3i=-sdip*x2r+cdip*x3
-
- ! integrate at depth and along strike with raised cosine taper
- ! and shift sources to x,y,z coordinate
- temp1=gauss(x1s-xr,dx1)
- temp2=omega((x2s-yr)/W,beta)
- temp3=omega((x3s-zr)/L,beta)
- aperture=temp1*temp2*temp3
-
- ! add image
- temp1=gauss(x1i-xr,dx1)
- temp3=omega((x3i+zr)/L,beta)
- aperture=aperture+temp1*temp2*temp3
-
- ! surface normal vector components
- n(1)=+cdip*cstrike*aperture
- n(2)=-cdip*sstrike*aperture
- n(3)=-sdip*aperture
-
- ! eigenstrain (symmetric second-order tensor)
- Ei=n .sdyad. (slip*n)
-
- ! moment density (isotropic Hooke's law)
- CALL isotropicstressstrain(Ei,lambda,mu)
- sig(i1,i2,i3)=sig(i1,i2,i3) .plus. Ei
-
- END DO
- END DO
- END DO
-
- END SUBROUTINE momentdensitytensile
-
- !---------------------------------------------------------------------
- !! function MomentDensityMogi
- !! computes the inelastic irreversible moment density in the space
- !! domain corresponding to a buried Mogi source.
- !! The Mogi source is associated with the eigenstrain
- !!
- !! \f[ E^i_{ij} = o \frac{1}{3} \delta_{ij} \f]
- !!
- !! In a heterogeneous medium of elastic moduli tensor C_ijkl, the
- !! corresponding moment density tensor is
- !!
- !! \f[ m_{ij} = C_{ijkl} E^i_{kl} \f]
- !!
- !! where C = C(x) is a function of space. Equivalent body forces
- !! representing the set of dislocations can be obtained by evaluating
- !! the divergence of the moment density tensor
- !!
- !! \f[ f_i = - ( m_{ji} ),j \f]
- !!
- !! using the function "EquivalentBodyForce" in this module.
- !!
- !! \author sylvain barbot (03-24-09) - original form
- !---------------------------------------------------------------------
- SUBROUTINE momentdensitymogi(lambda,mu,o,xs,ys,zs,sx1,sx2,sx3,dx1,dx2,dx3,sig)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: lambda,mu,o,xs,ys,zs,dx1,dx2,dx3
- TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: sig
-
- INTEGER :: i1,i2,i3
- REAL*8 :: x1,x2,x3,Wp,Lp,dum,kappa,gamma,gammai
- TYPE(TENSOR) :: m
-
- kappa=lambda+2._8/3._8*mu
-
- ! effective tapered dimensions
- Wp=6._8*MAX(dx1,dx2,dx3)
- Lp=6._8*MAX(dx1,dx2,dx3)
-
- DO i3=1,sx3
- x3=DBLE(i3-1)*dx3
- IF (abs(x3-zs) .gt. Lp) CYCLE
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
- dx1,dx2,dx3,x1,x2,dum)
-
- IF ((abs(x1-xs).gt.Wp) .or. (abs(x2-ys).gt.Wp)) CYCLE
-
- ! amplitude of eigenstrain
- gamma =o*gauss(x1-xs,dx1)*gauss(x2-ys,dx2)*gauss(x3-zs,dx3)
-
- ! add image
- gammai=o*gauss(x1-xs,dx1)*gauss(x2-ys,dx2)*gauss(x3+zs,dx3)
-
- ! amplitude of moment density
- gamma=kappa*gamma
- gammai=kappa*gammai
-
- ! eigenstrain (diagonal second-order tensor)
- m=TENSOR(gamma,0,0,gamma,0,gamma)
-
- ! moment density (pure shear)
- sig(i1,i2,i3)=sig(i1,i2,i3) .plus. m
-
- END DO
- END DO
- END DO
-
- END SUBROUTINE momentdensitymogi
-
- !---------------------------------------------------------------------
- !> function Plane
- !! computes the three components, n1, n2 and n3, of the normal vector
- !! corresponding to a rectangular surface of finite size. The plane
- !! is defined by its orientation (strike and dip) and dimension.
- !!
- !!\verbatim
- !!
- !! W
- !! +-------------+
- !! | |
- !! L | + | - - - > along strike direction
- !! | (x,y,z) |
- !! +-------------|
- !! |
- !! v
- !! down-dip direction
- !!
- !!\endverbatim
- !!
- !! in the default orientation, for which strike=0 and dip=0, the plane
- !! is vertical along the x2 axis, such as n2(x) = n3(x) = 0 for all x.
- !! internal angular conventions are as follows:
- !!
- !!\verbatim
- !!
- !! n x1 n x1
- !! \ | \ |
- !! \ | \ |
- !! 90 - strike \ | 90 - dip \ |
- !! ( \| ( \|
- !! ----------+------ x2 ----------+------ x3
- !! (x3 down) (x2 up)
- !!
- !!\endverbatim
- !!
- !! edges of the rectangle are tapered.
- !!
- !! \author sylvain barbot (09-15-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE plane(x,y,z,L,W,strike,dip, &
- beta,sx1,sx2,sx3,dx1,dx2,dx3,n1,n2,n3)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: x,y,z,L,W,strike,dip,beta,dx1,dx2,dx3
-#ifdef ALIGN_DATA
- REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: n1,n2,n3
-#else
- REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(INOUT) :: n1,n2,n3
-#endif
-
- INTEGER :: i1,i2,i3
- REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
- cstrike,sstrike,cdip,sdip,x2r,&
- temp1,temp2,temp3,sourc,image,xr,yr,zr,Wp,Lp,dum
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta)/2._8
- Lp=L*(1._8+2._8*beta)/2._8
-
- ! rotate centre coordinates of source and images
- x2r= cstrike*x -sstrike*y
- xr = cdip *x2r-sdip *z
- yr = sstrike*x +cstrike*y
- zr = sdip *x2r+cdip *z
-
- DO i3=1,sx3
- x3=DBLE(i3-1)*dx3
- IF ((abs(x3-z).gt.Lp) .and. (abs(x3+z).gt.Lp)) CYCLE
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
- dx1,dx2,dx3,x1,x2,dum)
- IF ((abs(x1-x).gt.Wp) .or. (abs(x2-y).gt.Wp)) CYCLE
-
- x2r= cstrike*x1-sstrike*x2
- x1s= cdip*x2r-sdip*x3
- x1i= cdip*x2r+sdip*x3
- IF ((abs(x1s-xr).gt.7.01*dx1).and.(abs(x1i-xr).gt.7.01*dx1)) CYCLE
- x2s= sstrike*x1+cstrike*x2
- x3s= sdip*x2r+cdip*x3
- x3i=-sdip*x2r+cdip*x3
-
- !integrate at depth and along strike with raised cosine taper
- !and shift sources to x,y,z coordinate
- temp1=gauss(x1s-xr,dx1)
- temp2=omega((x2s-yr)/W,beta)
- temp3=omega((x3s-zr)/L,beta)
- sourc=temp1*temp2*temp3
-
- temp1=gauss(x1i-xr,dx1)
- temp3=omega((x3i+zr)/L,beta)
- image=temp1*temp2*temp3
-
- ! surface normal vector components
- n1(i1,i2,i3)=n1(i1,i2,i3)+cdip*cstrike*(sourc+image)
- n2(i1,i2,i3)=n2(i1,i2,i3)-cdip*sstrike*(sourc+image)
- n3(i1,i2,i3)=n3(i1,i2,i3)-sdip*(sourc+image)
-
- END DO
- END DO
- END DO
-
- END SUBROUTINE plane
-
- !---------------------------------------------------------------------
- !> function MonitorStressField
- !! samples a stress field along a specified planar surface.
- !!
- !! \author sylvain barbot (10-16-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE monitorstressfield(x,y,z,L,W,strike,dip,beta, &
- sx1,sx2,sx3,dx1,dx2,dx3,sig,patch)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: x,y,z,L,W,strike,dip,beta,dx1,dx2,dx3
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- TYPE(SLIPPATCH_STRUCT), ALLOCATABLE, DIMENSION(:,:), INTENT(OUT) :: patch
-
- INTEGER :: px2,px3,j2,j3,status
- REAL*8 :: x1,x2,x3,xr,yr,zr,Wp,Lp, &
- cstrike,sstrike,cdip,sdip
- TYPE(TENSOR) :: lsig
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta) ! horizontal dimension for vertical fault
- Lp=L*(1._8+2._8*beta) ! depth for a vertical fault
-
- px3=fix(Lp/dx3)
- px2=fix(Wp/dx2)
-
- ALLOCATE(patch(px2+1,px3+1),STAT=status)
- IF (status>0) STOP "could not allocate the slip patches for export"
-
- DO j3=1,px3+1
- DO j2=1,px2+1
-
- CALL ref2local(x,y,z,xr,yr,zr)
-
- ! no translation in out of plane direction
- yr=REAL(yr)+REAL((DBLE(j2)-DBLE(px2)/2._8-1._8)*dx2)
- zr=REAL(zr)+REAL((DBLE(j3)-DBLE(px3)/2._8-1._8)*dx3)
-
- CALL local2ref(xr,yr,zr,x1,x2,x3)
-
- ! discard out-of-bound locations
- IF ( (x1 .gt. DBLE(sx1/2-1)*dx1) .or. (x1 .lt. -DBLE(sx1/2)*dx1) &
- .or. (x2 .gt. DBLE(sx2/2-1)*dx2) .or. (x2 .lt. -DBLE(sx2/2)*dx2) &
- .or. (x3 .gt. DBLE(sx3-1)*dx3) .or. (x3 .lt. 0._8) ) THEN
- lsig=TENSOR(0._8,0._8,0._8,0._8,0._8,0._8)
- ELSE
- CALL sampletensor(x1,x2,x3,dx1,dx2,dx3,sx1,sx2,sx3,sig,lsig)
- END IF
-
- patch(j2,j3)=SLIPPATCH_STRUCT(x1,x2,x3,yr,zr,0._8,0._8,0._8,lsig)
-
- END DO
- END DO
-
- CONTAINS
-
- !--------------------------------------------------------------
- !> subroutine sample
- !! interpolates the value of a discretized 3-dimensional field
- !! at a subpixel location. method consists in correlating the
- !! 3D field with a delta function filter. the delta function is
- !! approximated with a narrow normalized gaussian.
- !!
- !! \author sylvain barbot (10-17-07) - original form
- !--------------------------------------------------------------
- SUBROUTINE sampletensor(x1,x2,x3,dx1,dx2,dx3,sx1,sx2,sx3,sig,lsig)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: x1,x2,x3,dx1,dx2,dx3
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- TYPE(TENSOR), INTENT(OUT) :: lsig
-
- INTEGER :: i1,i2,i3,i,j,k,l1,l2,l3,i1p,i2p,i3p
- INTEGER, PARAMETER :: RANGE=2
- REAL*8 :: sum,weight,x,y,z
- REAL*8, PARAMETER :: EPS=1e-2
-
- sum=0._8
- lsig=TENSOR(0._8,0._8,0._8,0._8,0._8,0._8)
-
- ! closest sample
- CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i,j,k)
- ! rounded coordinates of closest sample
- CALL shiftedcoordinates(i,j,k,sx1,sx2,2*sx3,dx1,dx2,dx3,x,y,z)
-
- ! no interpolation for node points
- IF ( (abs(x-x1) .lt. EPS*dx1) .and. &
- (abs(y-x2) .lt. EPS*dx2) .and. &
- (abs(z-x3) .lt. EPS*dx3) ) THEN
- lsig=sig(i,j,k)
- RETURN
- END IF
-
- DO l3=-RANGE,+RANGE
- ! no periodicity in the 3-direction
- IF ((k+l3 .le. 0) .or. (k+l3 .gt. sx3)) CYCLE
-
- IF (l3 .ge. 0) THEN
- i3p=mod(k-1+l3,sx3)+1
- ELSE
- i3p=mod(sx3+k-1+l3,sx3)+1
- END IF
-
- DO l2=-RANGE,+RANGE
- IF (l2 .ge. 0) THEN
- i2p=mod(j-1+l2,sx2)+1
- ELSE
- i2p=mod(sx2+j-1+l2,sx2)+1
- END IF
-
- DO l1=-RANGE,+RANGE
- IF (l1 .ge. 0) THEN
- i1p=mod(i-1+l1,sx1)+1
- ELSE
- i1p=mod(sx1+i-1+l1,sx1)+1
- END IF
-
- weight=sinc(((x+l1*dx1)-x1)/dx1)*dx1 &
- *sinc(((y+l2*dx2)-x2)/dx2)*dx2 &
- *sinc(((z+l3*dx3)-x3)/dx3)*dx3
-
- !weight=gauss((x+l1*dx1)-x1,dx1)*dx1 &
- ! *gauss((y+l2*dx2)-x2,dx2)*dx2 &
- ! *gauss((z+l3*dx3)-x3,dx3)*dx3
-
- lsig=lsig.plus.(REAL(weight).times.sig(i1p,i2p,i3p))
- sum =sum +weight
-
- END DO
- END DO
- END DO
- IF (sum .gt. 1e-6) lsig=REAL(1._8/sum).times.lsig
-
- END SUBROUTINE sampletensor
-
- !-----------------------------------------------
- ! subroutine ref2local
- ! convert reference Cartesian coordinates into
- ! the rotated, local fault coordinates system.
- !-----------------------------------------------
- SUBROUTINE ref2local(x,y,z,xp,yp,zp)
- REAL*8, INTENT(IN) :: x,y,z
- REAL*8, INTENT(OUT) :: xp,yp,zp
-
- REAL*8 :: x2
-
- x2 = cstrike*x -sstrike*y
- xp = cdip *x2 -sdip *z
- yp = sstrike*x +cstrike*y
- zp = sdip *x2 +cdip *z
-
- END SUBROUTINE ref2local
-
- !-----------------------------------------------
- ! subroutine local2ref
- ! converts a set of coordinates from the rotated
- ! fault-aligned coordinate system into the
- ! reference, Cartesian coordinates system.
- !-----------------------------------------------
- SUBROUTINE local2ref(xp,yp,zp,x,y,z)
- REAL*8, INTENT(IN) :: xp,yp,zp
- REAL*8, INTENT(OUT) :: x,y,z
-
- REAL*8 :: x2p
-
- x2p= cdip*xp+sdip*zp
- x = cstrike*x2p+sstrike*yp
- y = -sstrike*x2p+cstrike*yp
- z = -sdip*xp +cdip*zp
-
- END SUBROUTINE local2ref
-
- END SUBROUTINE monitorstressfield
-
- !---------------------------------------------------------------------
- !> function MonitorField
- !! samples a scalar field along a specified planar surface.
- !!
- !! \author sylvain barbot (10-16-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE monitorfield(x,y,z,L,W,strike,dip,beta, &
- sx1,sx2,sx3,dx1,dx2,dx3,slip,patch)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: x,y,z,L,W,strike,dip,beta,dx1,dx2,dx3
-#ifdef ALIGN_DATA
- REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(IN) :: slip
-#else
- REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(IN) :: slip
-#endif
- TYPE(SLIPPATCH_STRUCT), ALLOCATABLE, DIMENSION(:,:), INTENT(OUT) :: patch
-
- INTEGER :: px2,px3,j2,j3,status
- REAL*8 :: x1,x2,x3,xr,yr,zr,Wp,Lp, &
- cstrike,sstrike,cdip,sdip,value
- TYPE(TENSOR) :: sig0
-
- sig0=TENSOR(0._8,0._8,0._8,0._8,0._8,0._8)
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta) ! horizontal dimension for vertical fault
- Lp=L*(1._8+2._8*beta) ! depth for a vertical fault
-
- px3=fix(Lp/dx3)
- px2=fix(Wp/dx2)
-
- ALLOCATE(patch(px2+1,px3+1),STAT=status)
- IF (status>0) STOP "could not allocate the slip patches for export"
-
- DO j3=1,px3+1
- DO j2=1,px2+1
-
- CALL ref2local(x,y,z,xr,yr,zr)
-
- ! no translation in out of plane direction
- yr=REAL(yr)+REAL((DBLE(j2)-DBLE(px2)/2._8-1._8)*dx2)
- zr=REAL(zr)+REAL((DBLE(j3)-DBLE(px3)/2._8-1._8)*dx3)
-
- CALL local2ref(xr,yr,zr,x1,x2,x3)
-
- ! discard out-of-bound locations
- IF ( (x1 .gt. DBLE(sx1/2-1)*dx1) .or. (x1 .lt. -DBLE(sx1/2)*dx1) &
- .or. (x2 .gt. DBLE(sx2/2-1)*dx2) .or. (x2 .lt. -DBLE(sx2/2)*dx2) &
- .or. (x3 .gt. DBLE(sx3-1)*dx3) .or. (x3 .lt. 0._8) ) THEN
- value=0._8
- ELSE
- CALL sample(x1,x2,x3,dx1,dx2,dx3,sx1,sx2,sx3,slip,value)
- END IF
-
- patch(j2,j3)=SLIPPATCH_STRUCT(x1,x2,x3,yr,zr,value,0._8,0._8,sig0)
-
- END DO
- END DO
-
- CONTAINS
-
- !--------------------------------------------------------------
- !> subroutine sample
- !! interpolates the value of a discretized 3-dimensional field
- !! at a subpixel location. method consists in correlating the
- !! 3D field with a delta function filter. the delta function is
- !! approximated with a narrow normalized gaussian.
- !!
- !! \author sylvain barbot (10-17-07) - original form
- !--------------------------------------------------------------
- SUBROUTINE sample(x1,x2,x3,dx1,dx2,dx3,sx1,sx2,sx3,field,value)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: x1,x2,x3,dx1,dx2,dx3
- REAL*8, INTENT(OUT) :: value
-#ifdef ALIGN_DATA
- REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(IN) :: field
-#else
- REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(IN) :: field
-#endif
-
- INTEGER :: i1,i2,i3,i,j,k,l1,l2,l3,i1p,i2p,i3p
- INTEGER, PARAMETER :: RANGE=2
- REAL*8 :: sum,weight,x,y,z
- REAL*8, PARAMETER :: EPS=1e-2
-
- sum=0._8
- value=0._8
-
- ! closest sample
- CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i,j,k)
- ! rounded coordinates of closest sample
- CALL shiftedcoordinates(i,j,k,sx1,sx2,2*sx3,dx1,dx2,dx3,x,y,z)
-
- ! no interpolation for node points
- IF ( (abs(x-x1) .lt. EPS*dx1) .and. &
- (abs(y-x2) .lt. EPS*dx2) .and. &
- (abs(z-x3) .lt. EPS*dx3) ) THEN
- value=field(i,j,k)
- RETURN
- END IF
-
- DO l3=-RANGE,+RANGE
- ! no periodicity in the 3-direction
- IF ((k+l3 .le. 0) .or. (k+l3 .gt. sx3)) CYCLE
-
- IF (l3 .ge. 0) THEN
- i3p=mod(k-1+l3,sx3)+1
- ELSE
- i3p=mod(sx3+k-1+l3,sx3)+1
- END IF
-
- DO l2=-RANGE,+RANGE
- IF (l2 .ge. 0) THEN
- i2p=mod(j-1+l2,sx2)+1
- ELSE
- i2p=mod(sx2+j-1+l2,sx2)+1
- END IF
-
- DO l1=-RANGE,+RANGE
- IF (l1 .ge. 0) THEN
- i1p=mod(i-1+l1,sx1)+1
- ELSE
- i1p=mod(sx1+i-1+l1,sx1)+1
- END IF
-
- weight=sinc(((x+l1*dx1)-x1)/dx1)*dx1 &
- *sinc(((y+l2*dx2)-x2)/dx2)*dx2 &
- *sinc(((z+l3*dx3)-x3)/dx3)*dx3
-
- !weight=gauss((x+l1*dx1)-x1,dx1)*dx1 &
- ! *gauss((y+l2*dx2)-x2,dx2)*dx2 &
- ! *gauss((z+l3*dx3)-x3,dx3)*dx3
-
- value=value+weight*field(i1p,i2p,i3p)
- sum =sum +weight
-
- END DO
- END DO
- END DO
- IF (sum .gt. 1e-6) value=value/sum
-
- END SUBROUTINE sample
-
- !-----------------------------------------------
- ! subroutine ref2local
- ! convert reference Cartesian coordinates into
- ! the rotated, local fault coordinates system.
- !-----------------------------------------------
- SUBROUTINE ref2local(x,y,z,xp,yp,zp)
- REAL*8, INTENT(IN) :: x,y,z
- REAL*8, INTENT(OUT) :: xp,yp,zp
-
- REAL*8 :: x2
-
- x2 = cstrike*x -sstrike*y
- xp = cdip *x2 -sdip *z
- yp = sstrike*x +cstrike*y
- zp = sdip *x2 +cdip *z
-
- END SUBROUTINE ref2local
-
- !-----------------------------------------------
- ! subroutine local2ref
- ! converts a set of coordinates from the rotated
- ! fault-aligned coordinate system into the
- ! reference, Cartesian coordinates system.
- !-----------------------------------------------
- SUBROUTINE local2ref(xp,yp,zp,x,y,z)
- REAL*8, INTENT(IN) :: xp,yp,zp
- REAL*8, INTENT(OUT) :: x,y,z
-
- REAL*8 :: x2p
-
- x2p= cdip*xp+sdip*zp
- x = cstrike*x2p+sstrike*yp
- y = -sstrike*x2p+cstrike*yp
- z = -sdip*xp +cdip*zp
-
- END SUBROUTINE local2ref
-
- END SUBROUTINE monitorfield
-
- !-----------------------------------------------------------------
- ! subroutine FieldAdd
- ! computes in place the sum of two scalar fields
- !
- ! u = c1 * u + c2 * v
- !
- ! the function is useful to add fields of different sizes.
- !
- ! sylvain barbot (07/27/07) - original form
- !-----------------------------------------------------------------
- SUBROUTINE fieldadd(u,v,sx1,sx2,sx3,c1,c2)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: u
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v
- REAL*4, INTENT(IN), OPTIONAL :: c1,c2
-
- IF (PRESENT(c1)) THEN
- IF (PRESENT(c2)) THEN
- u=c1*u+c2*v
- ELSE
- u=c1*u+v
- END IF
- ELSE
- IF (PRESENT(c2)) THEN
- u=u+c2*v
- ELSE
- u=u+v
- END IF
- END IF
-
- END SUBROUTINE fieldadd
-
- !-----------------------------------------------------------------
- ! subroutine FieldRep
- !
- ! u = c1 * v
- !
- ! the function is useful to add fields of different sizes.
- !
- ! sylvain barbot (07/27/07) - original form
- !-----------------------------------------------------------------
- SUBROUTINE fieldrep(u,v,sx1,sx2,sx3,c1)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: u
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v
- REAL*4, INTENT(IN), OPTIONAL :: c1
-
- IF (PRESENT(c1)) THEN
- u=u+c1*v
- ELSE
- u=v
- END IF
-
- END SUBROUTINE fieldrep
-
- !-----------------------------------------------------------------
- ! subroutine SliveAdd
- ! computes in place the sum of two scalar fields
- !
- ! u = c1 * u + c2 * v
- !
- ! the function is useful to add fields of different sizes.
- !
- ! sylvain barbot (10/24/08) - original form
- !-----------------------------------------------------------------
- SUBROUTINE sliceadd(u,v,sx1,sx2,sx3,index,c1,c2)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,index
- REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2) :: u
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v
- REAL*4, INTENT(IN), OPTIONAL :: c1,c2
-
- IF (PRESENT(c1)) THEN
- IF (PRESENT(c2)) THEN
- u=c1*u+c2*v(:,:,index)
- ELSE
- u=c1*u+v(:,:,index)
- END IF
- ELSE
- IF (PRESENT(c2)) THEN
- u=u+c2*v(:,:,index)
- ELSE
- u=u+v(:,:,index)
- END IF
- END IF
-
- END SUBROUTINE sliceadd
-
- !-----------------------------------------------------------------
- !> subroutine TensorFieldAdd
- !! computes the linear combination of two tensor fields
- !!
- !! t1 = c1 * t1 + c2 * t2
- !!
- !! where t1 and t2 are two tensor fields and c1 and c2 are scalars.
- !! only tensor field t1 is modified.
- !
- ! sylvain barbot (07/27/07) - original form
- !-----------------------------------------------------------------
- SUBROUTINE tensorfieldadd(t1,t2,sx1,sx2,sx3,c1,c2)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: t1
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: t2
- REAL*4, INTENT(IN), OPTIONAL :: c1,c2
-
- INTEGER :: i1,i2,i3
-
- IF (PRESENT(c1)) THEN
- IF (PRESENT(c2)) THEN
- IF (0._4 .eq. c1) THEN
- IF (0._4 .eq. c2) THEN
- DO 05 i3=1,sx3; DO 05 i2=1,sx2; DO 05 i1=1,sx1
- t1(i1,i2,i3)=TENSOR(0._4,0._4,0._4,0._4,0._4,0._4)
-05 CONTINUE
- ELSE
- DO 10 i3=1,sx3; DO 10 i2=1,sx2; DO 10 i1=1,sx1
- t1(i1,i2,i3)=c2 .times. t2(i1,i2,i3)
-10 CONTINUE
- END IF
- ELSE
- DO 20 i3=1,sx3; DO 20 i2=1,sx2; DO 20 i1=1,sx1
- t1(i1,i2,i3)=(c1 .times. t1(i1,i2,i3)) .plus. &
- (c2 .times. t2(i1,i2,i3))
-20 CONTINUE
- END IF
- ELSE
- DO 30 i3=1,sx3; DO 30 i2=1,sx2; DO 30 i1=1,sx1
- t1(i1,i2,i3)=(c1 .times. t1(i1,i2,i3)) .plus. t2(i1,i2,i3)
-30 CONTINUE
- END IF
- ELSE
- IF (PRESENT(c2)) THEN
- DO 40 i3=1,sx3; DO 40 i2=1,sx2; DO 40 i1=1,sx1
- t1(i1,i2,i3)=t1(i1,i2,i3) .plus. (c2 .times. t2(i1,i2,i3))
-40 CONTINUE
- ELSE
- DO 50 i3=1,sx3; DO 50 i2=1,sx2; DO 50 i1=1,sx1
- t1(i1,i2,i3)=t2(i1,i2,i3) .plus. t2(i1,i2,i3)
-50 CONTINUE
- END IF
- END IF
-
- END SUBROUTINE tensorfieldadd
-
-
- !-----------------------------------------------------------------
- ! subroutine TensorIntegrate
- ! computes a numercial integration with numerical viscosity
- !
- ! T^(n+1)_i = (T^n_(i-1)+T^n_(i+1))/2 + dt * S^n_i
- !
- ! instead of
- !
- ! T^(n+1)_i = T^n_i + dt * S^n_i
- !
- ! implementation is just generalized for a 3-dimensional field.
- !
- ! sylvain barbot (07/27/07) - original form
- !-----------------------------------------------------------------
- SUBROUTINE tensorintegrate(T,S,sx1,sx2,sx3,dt)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: T
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: S
- REAL*8, INTENT(IN) :: dt
-
- INTEGER :: i1,i2,i3,i1m,i2m,i3m,i1p,i2p,i3p
-
- DO i3=1,sx3
- i3m=mod(sx3+i3-2,sx3)+1
- i3p=mod(i3,sx3)+1
- DO i2=1,sx2
- i2m=mod(sx2+i2-2,sx2)+1
- i2p=mod(i2,sx2)+1
- DO i1=1,sx1
- i1m=mod(sx1+i1-2,sx1)+1
- i1p=mod(i1,sx1)+1
-
- T(i1,i2,i3)=( &
- (1._4/6._4) .times. (T(i1m,i2,i3) .plus. T(i1p,i2,i3) &
- .plus. T(i1,i2m,i3) .plus. T(i1,i2p,i3) &
- .plus. T(i1,i2,i3m) .plus. T(i1,i2,i3p))) &
- .plus. &
- (REAL(dt) .times. S(i1,i2,i3))
- END DO
- END DO
- END DO
-
- END SUBROUTINE tensorintegrate
-
- !---------------------------------------------------------------------
- !> subroutine coordinates computes the xi coordinates from the
- !! array index and sampling interval
- !---------------------------------------------------------------------
- SUBROUTINE coordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
- INTEGER, INTENT(IN) :: i1,i2,i3,sx1,sx2,sx3
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- REAL*8, INTENT(OUT) :: x1,x2,x3
-
- x1=DBLE(i1-sx1/2-1)*dx1
- x2=DBLE(i2-sx2/2-1)*dx2
- x3=DBLE(i3-sx3/2-1)*dx3
- END SUBROUTINE coordinates
-
- !---------------------------------------------------------------------
- !> subroutine ShiftedCoordinates
- !! computes the xi coordinates from the array index and sampling
- !! interval assuming data is order like fftshift.
- !!
- !! \author sylvain barbot (07/31/07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
- INTEGER, INTENT(IN) :: i1,i2,i3,sx1,sx2,sx3
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- REAL*8, INTENT(OUT) :: x1,x2,x3
-
- IF (i1 .LE. sx1/2) THEN
- x1=DBLE(i1-1)*dx1
- ELSE
- x1=DBLE(i1-sx1-1)*dx1
- END IF
- IF (i2 .LE. sx2/2) THEN
- x2=DBLE(i2-1)*dx2
- ELSE
- x2=DBLE(i2-sx2-1)*dx2
- END IF
- IF (i3 .LE. sx3/2) THEN
- x3=DBLE(i3-1)*dx3
- ELSE
- x3=DBLE(i3-sx3-1)*dx3
- END IF
-
- END SUBROUTINE shiftedcoordinates
-
- !----------------------------------------------------------------------
- !> subroutine ShiftedIndex
- !! returns the integer index corresponding to the specified coordinates
- !! assuming the data are ordered following fftshift. input coordinates
- !! are assumed bounded -sx/2 <= x <= sx/2-1. out of bound input
- !! purposefully triggers a fatal error. in the x3 direction, coordinates
- !! are assumed bounded by 0 <= x3 <= (sx3-1)*dx3
- !!
- !! CALLED BY:
- !! monitorfield/sample
- !!
- !! \author sylvain barbot (07/31/07) - original form
- !----------------------------------------------------------------------
- SUBROUTINE shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
- REAL*8, INTENT(IN) :: x1,x2,x3,dx1,dx2,dx3
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- INTEGER, INTENT(OUT) :: i1,i2,i3
-
- IF (x1 .gt. DBLE(sx1/2-1)*dx1) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("x1=",ES9.2E2,"; boundary at x1=",ES9.2E2)') x1, DBLE(sx1/2)*dx1
- STOP "ShiftedIndex:invalid x1 coordinates (x1 too large)"
- END IF
- IF (x1 .lt. -DBLE(sx1/2)*dx1 ) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("x1=",ES9.2E2,"; boundary at x1=",ES9.2E2)') x1, -DBLE(sx1/2)*dx1
- STOP "ShiftedIndex:coordinates out of range (-x1 too large)"
- END IF
- IF (x2 .gt. DBLE(sx2/2-1)*dx2) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("x2=",ES9.2E2,"; boundary at x2=",ES9.2E2)') x2, DBLE(sx2/2)*dx2
- STOP "ShiftedIndex:invalid x2 coordinates (x2 too large)"
- END IF
- IF (x2 .lt. -DBLE(sx2/2)*dx2 ) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("x2=",ES9.2E2,"; boundary at x2=",ES9.2E2)') x2, -DBLE(sx2/2)*dx2
- STOP "ShiftedIndex:coordinates out of range (-x2 too large)"
- END IF
- IF (x3 .gt. DBLE(sx3-1)*dx3) THEN
- WRITE_DEBUG_INFO
- STOP "ShiftedIndex:invalid x3 coordinates (x3 too large)"
- END IF
- IF (x3 .lt. 0 ) THEN
- WRITE (0,'("x3=",ES9.2E2)') x3
- STOP "ShiftedIndex:coordinates out of range (x3 negative)"
- END IF
-
- i1=MOD(sx1+fix(x1/dx1),sx1)+1
- i2=MOD(sx2+fix(x2/dx2),sx2)+1
- i3=fix(x3/dx3)+1
-
- END SUBROUTINE shiftedindex
-
- !-----------------------------------------------------------------
- ! subroutine ExportSlice
- ! computes the value of a scalar field at a horizontal plane.
- ! the field if shifted such as the (0,0) coordinate is in the
- ! middle of the array at (sx1/2+1,sx2/2+1).
- !
- ! sylvain barbot (07/09/07) - original form
- !-----------------------------------------------------------------
- SUBROUTINE exportslice(field,odepth,dx1,dx2,dx3,s)
- REAL*4, INTENT(IN), DIMENSION(:,:,:) :: field
- REAL*8, INTENT(IN) :: dx1,dx2,dx3,odepth
- REAL*4, INTENT(OUT), DIMENSION(:,:) :: s
-
- INTEGER :: i1,i2,i3,sx1,sx2,sx3
- REAL*8 :: k3
- COMPLEX*8, PARAMETER :: i=CMPLX(0._8,pi2)
- COMPLEX*8 :: sum,exp3
- REAL*4 :: exp1,exp2
-
- sx1=SIZE(field,1)-2
- sx2=SIZE(field,2)
- sx3=SIZE(field,3)
-
- s=0
- DO i3=1,sx3
- CALL wavenumber3(i3,sx3,dx3,k3)
- exp3=exp(i*k3*odepth)
- DO i2=1,sx2
- DO i1=1,sx1/2+1
- sum=CMPLX(field(2*i1-1,i2,i3),field(2*i1,i2,i3))*exp3
- s(2*i1-1:2*i1,i2)=s(2*i1-1:2*i1,i2)+(/REAL(sum),AIMAG(sum)/)
- END DO
- END DO
- END DO
- s=s/(sx3*dx3)
-
- !fftshift
- DO i2=1,sx2
- IF (i2 < sx2/2+1) THEN
- exp2= (i2-1._4)
- ELSE
- exp2=-(sx2-i2+1._4)
- END IF
- DO i1=1,sx1/2+1
- exp1=i1-1._4
- sum=CMPLX(s(2*i1-1,i2),s(2*i1,i2))*((-1._4)**(exp1+exp2))
- s(2*i1-1:2*i1,i2)=(/REAL(sum),AIMAG(sum)/)
- END DO
- END DO
- CALL fft2(s,sx1,sx2,dx1,dx2,FFT_INVERSE)
-
- END SUBROUTINE exportslice
-
- !-----------------------------------------------------------------
- !> subroutine ExportSpatial
- !! transfer a horizontal layer from array 'data' to smaller array
- !! 'p' and shift center position so that coordinates (0,0) are in
- !! center of array 'p'. optional parameter 'doflip' generates
- !! output compatible with grd binary format.
- !
- ! sylvain barbot (07/09/07) - original form
- ! (03/19/08) - compatibility with grd output
- !-----------------------------------------------------------------
- SUBROUTINE exportspatial(data,sx1,sx2,p,doflip)
- INTEGER, INTENT(IN) :: sx1,sx2
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2) :: data
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2) :: data
-#endif
- REAL*4, INTENT(OUT), DIMENSION(:,:) :: p
- LOGICAL, INTENT(IN), OPTIONAL :: doflip
-
- INTEGER :: i1,i2,i1s,i2s
- LOGICAL :: flip
-
- IF (PRESENT(doflip)) THEN
- flip=doflip
- ELSE
- flip=.false.
- END IF
-
- DO i2=1,sx2
- IF (i2 .LE. sx2/2) THEN
- i2s=sx2/2+i2
- ELSE
- i2s=i2-sx2/2
- END IF
- DO i1=1,sx1
- IF (i1 .LE. sx1/2) THEN
- i1s=sx1/2+i1
- ELSE
- i1s=i1-sx1/2
- END IF
-
- IF (flip) THEN
- p(i2s,sx1-i1s+1)=data(i1,i2)
- ELSE
- p(i1s,i2s)=data(i1,i2)
- END IF
-
- END DO
- END DO
-
- END SUBROUTINE exportspatial
-
-END MODULE elastic3d
diff -r 405d8f4fa05f -r e7295294f654 examples/tutorials/run1-pbs.sh
--- a/examples/tutorials/run1-pbs.sh Thu Mar 29 15:55:33 2012 -0700
+++ b/examples/tutorials/run1-pbs.sh Sun Apr 01 14:02:51 2012 -0700
@@ -25,7 +25,7 @@ fi
# qsub ./run1-pbs.sh
#
-mpiexec -n 8 relax <<EOF
+mpiexec -n 8 ../../build/relax <<EOF
# use '#' character to include comments in your input file
# grid size (sx1,sx2,sx3)
256 256 256
diff -r 405d8f4fa05f -r e7295294f654 examples/tutorials/run1.sh
--- a/examples/tutorials/run1.sh Thu Mar 29 15:55:33 2012 -0700
+++ b/examples/tutorials/run1.sh Sun Apr 01 14:02:51 2012 -0700
@@ -66,4 +66,4 @@ if [ ! -e $WDIR ]; then
mkdir $WDIR
fi
-OMP_NUM_THREADS=4 ../relax $* < run1.input | tee $WDIR/in.param
+OMP_NUM_THREADS=4 ../../build/relax $* < run1.input | tee $WDIR/in.param
diff -r 405d8f4fa05f -r e7295294f654 examples/tutorials/run2.sh
--- a/examples/tutorials/run2.sh Thu Mar 29 15:55:33 2012 -0700
+++ b/examples/tutorials/run2.sh Sun Apr 01 14:02:51 2012 -0700
@@ -23,4 +23,4 @@ if [ ! -e $WDIR ]; then
mkdir $WDIR
fi
-OMP_NUM_THREADS=2 time ../relax --no-proj-output $* < run2.input | tee $WDIR/in.param
+OMP_NUM_THREADS=2 time ../../build/relax --no-proj-output $* < run2.input | tee $WDIR/in.param
diff -r 405d8f4fa05f -r e7295294f654 examples/tutorials/run3.sh
--- a/examples/tutorials/run3.sh Thu Mar 29 15:55:33 2012 -0700
+++ b/examples/tutorials/run3.sh Sun Apr 01 14:02:51 2012 -0700
@@ -86,4 +86,4 @@ if [ ! -e $WDIR ]; then
mkdir $WDIR
fi
-time ../relax --no-proj-output --no-stress-output $* < run3.input | tee $WDIR/in.param
+time ../../build/relax --no-proj-output --no-stress-output $* < run3.input | tee $WDIR/in.param
diff -r 405d8f4fa05f -r e7295294f654 examples/tutorials/run4.sh
--- a/examples/tutorials/run4.sh Thu Mar 29 15:55:33 2012 -0700
+++ b/examples/tutorials/run4.sh Sun Apr 01 14:02:51 2012 -0700
@@ -43,4 +43,4 @@ if [ ! -e $WDIR ]; then
mkdir $WDIR
fi
-time ../relax --no-stress-output --no-proj-output $* < run4.input | tee $WDIR/in.param
+time ../../build/relax --no-stress-output --no-proj-output $* < run4.input | tee $WDIR/in.param
diff -r 405d8f4fa05f -r e7295294f654 export.f90
--- a/export.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,2480 +0,0 @@
-!-----------------------------------------------------------------------
-! Copyright 2007, 2008, 2009 Sylvain Barbot
-!
-! This file is part of RELAX
-!
-! RELAX 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 3 of the License, or
-! (at your option) any later version.
-!
-! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
-!-----------------------------------------------------------------------
-
-#include "include.f90"
-
-MODULE export
-
- USE elastic3d
- USE viscoelastic3d
- USE friction3d
-
- IMPLICIT NONE
-
- PRIVATE xyzwrite
- PRIVATE geoxyzwrite
-
-CONTAINS
-
- !-------------------------------------------------------------------
- ! routine ReportTime
- ! writes the times of exports
- !
- ! sylvain barbot (04/29/09) - original form
- !-------------------------------------------------------------------
- SUBROUTINE reporttime(i,t,repfile)
- INTEGER, INTENT(IN) :: i
- CHARACTER(80), INTENT(IN) :: repfile
- REAL*8, INTENT(IN) :: t
-
- INTEGER :: iostatus
-
- IF (0 .eq. i) THEN
- OPEN (UNIT=15,FILE=repfile,IOSTAT=iostatus,FORM="FORMATTED")
- ELSE
- OPEN (UNIT=15,FILE=repfile,POSITION="APPEND",&
- IOSTAT=iostatus,FORM="FORMATTED")
- END IF
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', repfile
- STOP "could not open file for export"
- END IF
-
- WRITE (15,'(ES11.3E2)') t
-
- CLOSE(15)
-
- END SUBROUTINE reporttime
-
- SUBROUTINE report(i,t,file1,file2,file3,sx1,sx2,repfile)
- INTEGER, INTENT(IN) :: i,sx1,sx2
- CHARACTER(80), INTENT(IN) :: file1,file2,file3,repfile
- REAL*8, INTENT(IN) :: t
-
- INTEGER :: iostatus, ind1,ind2,ind3
-
- IF (0 .eq. i) THEN
- OPEN (UNIT=15,FILE=repfile,IOSTAT=iostatus,FORM="FORMATTED")
- ELSE
- OPEN (UNIT=15,FILE=repfile,POSITION="APPEND",&
- IOSTAT=iostatus,FORM="FORMATTED")
- END IF
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', repfile
- STOP "could not open file for export"
- END IF
-
- ind1=INDEX(file1," ")
- ind2=INDEX(file2," ")
- ind3=INDEX(file3," ")
- WRITE (15,'(I3.3,2I6," ",f13.4," ",a," ",a," ",a)') i,sx1,sx2,t,&
- file1(1:ind1-1),file2(1:ind2-1),file3(1:ind3-1)
-
- CLOSE(15)
-
- END SUBROUTINE report
-
- SUBROUTINE export2d(data,sx1,sx2,filename)
- INTEGER, INTENT(IN) :: sx1,sx2
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2) :: data
- CHARACTER(80), INTENT(IN) :: filename
-
- INTEGER :: iostatus,i1,i2
- CHARACTER(15) :: form
- CHARACTER(5) :: digit
-
- WRITE (digit,'(I5.5)') sx1
- form="("//digit//"ES11.3E2)"
-
- OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- STOP "could not open file for export"
- END IF
-
- WRITE (15,form) ((data(i1,i2), i1=1,sx1), i2=1,sx2)
- CLOSE(15)
-
- END SUBROUTINE export2d
-
- !------------------------------------------------------------------
- ! subroutine geoxyzwrite
- !
- ! sylvain barbot (22/05/10) - original form
- !------------------------------------------------------------------
- SUBROUTINE geoxyzwrite(x,y,z,sx1,sx2,filename)
- INTEGER, INTENT(IN) :: sx1,sx2
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2) :: z
- REAL*8, INTENT(IN), DIMENSION(sx1,sx2) :: x,y
- CHARACTER(80), INTENT(IN) :: filename
-
- INTEGER :: iostatus,i1,i2
-
- OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) STOP "could not open file for proj export"
-
- DO i2=1,sx2
- DO i1=1,sx1
- WRITE (15,'(ES15.8E1,ES15.8E1,ES11.3E2)'), &
- x(i1,i2),y(i1,i2),z(i1,i2)
- END DO
- END DO
- CLOSE(15)
-
- END SUBROUTINE geoxyzwrite
-
- !------------------------------------------------------------------
- ! subroutine xyzwrite
- !
- ! sylvain barbot (06/10/09) - original form
- !------------------------------------------------------------------
- SUBROUTINE xyzwrite(data,sx1,sx2,dx1,dx2,filename)
- INTEGER, INTENT(IN) :: sx1,sx2
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2) :: data
- CHARACTER(80), INTENT(IN) :: filename
- REAL*8 :: dx1,dx2
-
- INTEGER :: iostatus,i1,i2
-
- OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) STOP "could not open file for export"
-
- DO i2=1,sx2
- DO i1=1,sx1
- !x1=(mod(sx1/2+i1-1,sx1)-sx1/2)*dx1
- !x2=(mod(sx2/2+i2-1,sx2)-sx2/2)*dx2
- WRITE (15,'(ES11.3E2,ES11.3E2,ES11.3E2)'), &
- DBLE(i2-1-sx2/2)*dx2,DBLE(i1-1-sx1/2)*dx1,data(i1,i2)
- END DO
- END DO
- CLOSE(15)
-
- END SUBROUTINE xyzwrite
-
-#ifdef PROJ
- !------------------------------------------------------------------
- !> subroutine ExportStressPROJ
- !! export a map view of stress with coordinates in
- !! longitude/latitude. Text format output is the GMT-compatible
- !! .xyz file format where data in each file is organized as follows
- !!
- !! longitude latitude s11
- !! longitude latitude s12
- !! longitude latitude s13
- !! longitude latitude s22
- !! longitude latitude s23
- !! longitude latitude s33
- !!
- !! this is an interface to exportproj.
- !!
- !! \author sylvain barbot (05/22/10) - original form
- !------------------------------------------------------------------
- SUBROUTINE exportstressproj(sig,sx1,sx2,sx3,dx1,dx2,dx3,oz, &
- x0,y0,lon0,lat0,zone,scale,wdir,index)
- INTEGER, INTENT(IN) :: index,sx1,sx2,sx3,zone
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- REAL*8, INTENT(IN) :: oz,dx1,dx2,dx3,x0,y0,lon0,lat0,scale
- CHARACTER(80), INTENT(IN) :: wdir
-
- REAL*4, DIMENSION(:,:), ALLOCATABLE :: t1,t2,t3
- INTEGER :: iostatus,i,j,k,l
-
- ALLOCATE(t1(sx1+2,sx2),t2(sx1+2,sx2),t3(sx1+2,sx2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate memory for grid export"
-
- k=fix(oz/dx3)+1
- DO j=1,sx2
- DO i=1,sx1
-#ifdef ALIGN_DATA
- l=(j-1)*(sx1+2)+i
-#else
- l=(j-1)*sx1+i
-#endif
- t1(l,1)=sig(i,j,k)%s11
- t2(l,1)=sig(i,j,k)%s12
- t3(l,1)=sig(i,j,k)%s13
- END DO
- END DO
-
- CALL exportproj(t1,t2,t3,sx1,sx2,1,dx1,dx2,dx3,0._8, &
- x0,y0,lon0,lat0,zone,scale,wdir,index,convention=4)
-
- DO j=1,sx2
- DO i=1,sx1
-#ifdef ALIGN_DATA
- l=(j-1)*(sx1+2)+i
-#else
- l=(j-1)*sx1+i
-#endif
- t1(l,1)=sig(i,j,k)%s22
- t2(l,1)=sig(i,j,k)%s23
- t3(l,1)=sig(i,j,k)%s33
- END DO
- END DO
-
- CALL exportproj(t1,t2,t3,sx1,sx2,1,dx1,dx2,dx3,0._8, &
- x0,y0,lon0,lat0,zone,scale,wdir,index,convention=5)
-
- DEALLOCATE(t1,t2,t3)
-
- END SUBROUTINE exportstressproj
-
- !------------------------------------------------------------------
- !> subroutine ExportPROJ
- !! export a map view of displacements with coordinates in
- !! longitude/latitude. Text format output is the GMT-compatible
- !! .xyz file format where data in each file is organized as follows
- !!
- !! longitude latitude u1,
- !! longitude latitude u2 and
- !! longitude latitude -u3
- !!
- !! for index-geo-north.xyz,
- !! index-geo-east.xyz and
- !! index-geo-up.xyz, respectively.
- !!
- !! \author sylvain barbot (05/22/10) - original form
- !------------------------------------------------------------------
- SUBROUTINE exportproj(c1,c2,c3,sx1,sx2,sx3,dx1,dx2,dx3,oz, &
- x0,y0,lon0,lat0,zone,scale,wdir,i,convention)
- INTEGER, INTENT(IN) :: i,sx1,sx2,sx3,zone
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
-#endif
- REAL*8, INTENT(IN) :: oz,dx1,dx2,dx3,x0,y0,lon0,lat0,scale
- CHARACTER(80), INTENT(IN) :: wdir
- INTEGER, INTENT(IN), OPTIONAL :: convention
-
- INTEGER :: iostatus,i1,i2,pos,conv
- CHARACTER(3) :: digit
- REAL*4, DIMENSION(:,:), ALLOCATABLE :: t1,t2,t3
- REAL*8, DIMENSION(:,:), ALLOCATABLE :: x,y
- CHARACTER(80) :: file1,file2,file3
- REAL*8 :: lon1,lat1
-
- IF (PRESENT(convention)) THEN
- conv=convention
- ELSE
- conv=1
- END IF
-
- lon1=lon0
- lat1=lat0
-
- ALLOCATE(t1(sx1,sx2),t2(sx1,sx2),t3(sx1,sx2), &
- x(sx1,sx2),y(sx1,sx2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate memory for export"
-
- CALL exportspatial(c1(:,:,int(oz/dx3)+1),sx1,sx2,t1)
- CALL exportspatial(c2(:,:,int(oz/dx3)+1),sx1,sx2,t2)
- CALL exportspatial(c3(:,:,int(oz/dx3)+1),sx1,sx2,t3)
- t3=-t3
-
- ! grid coordinates (x=easting, y=northing)
- DO i2=1,sx2
- DO i1=1,sx1
- y(i1,i2)=(i1-sx1/2)*(dx1*scale)+x0
- x(i1,i2)=(i2-sx2/2)*(dx2*scale)+y0
- END DO
- END DO
- CALL proj(x,y,sx1*sx2,lon1,lat1,zone)
-
- pos=INDEX(wdir," ")
- WRITE (digit,'(I3.3)') i
- SELECT CASE(conv)
- CASE (1) ! cumulative displacement
- file1=wdir(1:pos-1) // "/" // digit // "-geo-north.xyz"
- file2=wdir(1:pos-1) // "/" // digit // "-geo-east.xyz"
- file3=wdir(1:pos-1) // "/" // digit // "-geo-up.xyz"
- CASE (2) ! postseismic displacement
- file1=wdir(1:pos-1) // "/" // digit // "-relax-geo-north.xyz"
- file2=wdir(1:pos-1) // "/" // digit // "-relax-geo-east.xyz"
- file3=wdir(1:pos-1) // "/" // digit // "-relax-geo-up.xyz"
- CASE (3) ! equivalent body forces
- file1=wdir(1:pos-1) // "/" // digit // "-eqbf-geo-north.xyz"
- file2=wdir(1:pos-1) // "/" // digit // "-eqbf-geo-east.xyz"
- file3=wdir(1:pos-1) // "/" // digit // "-eqbf-geo-up.xyz"
- CASE (4) ! equivalent body forces
- file1=wdir(1:pos-1) // "/" // digit // "-geo-s11.xyz"
- file2=wdir(1:pos-1) // "/" // digit // "-geo-s12.xyz"
- file3=wdir(1:pos-1) // "/" // digit // "-geo-s13.xyz"
- CASE (5) ! equivalent body forces
- file1=wdir(1:pos-1) // "/" // digit // "-geo-s22.xyz"
- file2=wdir(1:pos-1) // "/" // digit // "-geo-s23.xyz"
- file3=wdir(1:pos-1) // "/" // digit // "-geo-s33.xyz"
- END SELECT
-
- CALL geoxyzwrite(x,y,t1,sx1,sx2,file1)
- CALL geoxyzwrite(x,y,t2,sx1,sx2,file2)
- CALL geoxyzwrite(x,y,t3,sx1,sx2,file3)
-
- DEALLOCATE(t1,t2,t3)
-
- END SUBROUTINE exportproj
-#endif
-
-#ifdef XYZ
- !------------------------------------------------------------------
- !> subroutine ExportXYZ
- !! export a map view of surface displacement into the GMT-compatible
- !! .xyz file format where data in each file is organized as follows
- !!
- !! x1 x2 u1, x1 x2 u2 and x1 x2 -u3
- !!
- !! for index-north.xyz, index-east.xyz and index-up.xyz,
- !! respectively.
- !!
- !! \author sylvain barbot (06/10/09) - original form
- !------------------------------------------------------------------
- SUBROUTINE exportxyz(c1,c2,c3,sx1,sx2,sx3,oz,dx1,dx2,dx3,i,wdir)
- INTEGER, INTENT(IN) :: i,sx1,sx2,sx3
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
-#endif
- REAL*8, INTENT(IN) :: oz,dx1,dx2,dx3
- CHARACTER(80), INTENT(IN) :: wdir
-
- INTEGER :: iostatus,pos
- REAL*4, DIMENSION(:,:), ALLOCATABLE :: temp1,temp2,temp3
- CHARACTER(80) :: file1,file2,file3
- CHARACTER(3) :: digit
-
- ALLOCATE(temp1(sx1,sx2),temp2(sx1,sx2),temp3(sx1,sx2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate memory for export"
-
- CALL exportspatial(c1(:,:,int(oz/dx3)+1),sx1,sx2,temp1)
- CALL exportspatial(c2(:,:,int(oz/dx3)+1),sx1,sx2,temp2)
- CALL exportspatial(c3(:,:,int(oz/dx3)+1),sx1,sx2,temp3)
- temp3=-temp3
-
- pos=INDEX(wdir," ")
- WRITE (digit,'(I3.3)') i
- file1=wdir(1:pos-1) // "/" // digit // "-north.xyz"
- file2=wdir(1:pos-1) // "/" // digit // "-east.xyz"
- file3=wdir(1:pos-1) // "/" // digit // "-up.xyz"
-
- CALL xyzwrite(temp1,sx1,sx2,dx1,dx2,file1)
- CALL xyzwrite(temp2,sx1,sx2,dx1,dx2,file2)
- CALL xyzwrite(temp3,sx1,sx2,dx1,dx2,file3)
-
- DEALLOCATE(temp1,temp2,temp3)
-
- END SUBROUTINE exportxyz
-#endif
-
-#ifdef TXT
- !------------------------------------------------------------------
- ! subroutine ExportTXT
- ! exports a horizontal slice of uniform depth into specified text
- ! files and adds filenames in the report file.
- ! if i is set to 0, the report file is reinitiated.
- ! input data c1,c2,c3 are in the space domain.
- !------------------------------------------------------------------
- SUBROUTINE exporttxt(c1,c2,c3,sx1,sx2,sx3,oz,dx3,i,time,wdir,reportfilename)
- INTEGER, INTENT(IN) :: i,sx1,sx2,sx3
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
-#endif
- REAL*8, INTENT(IN) :: oz,dx3,time
- CHARACTER(80), INTENT(IN) :: wdir,reportfilename
-
- INTEGER :: iostatus,pos
- REAL*4, DIMENSION(:,:), ALLOCATABLE :: temp1,temp2,temp3
- CHARACTER(3) :: digit
- CHARACTER(80) :: file1,file2,file3
-
- ALLOCATE(temp1(sx1,sx2),temp2(sx1,sx2),temp3(sx1,sx2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate memory for export"
-
- CALL exportspatial(c1(:,:,int(oz/dx3)+1),sx1,sx2,temp1)
- CALL exportspatial(c2(:,:,int(oz/dx3)+1),sx1,sx2,temp2)
- CALL exportspatial(c3(:,:,int(oz/dx3)+1),sx1,sx2,temp3)
-
- pos=INDEX(wdir," ")
- WRITE (digit,'(I3.3)') i
- file1=wdir(1:pos-1) // "/" // digit // "-u1.txt"
- file2=wdir(1:pos-1) // "/" // digit // "-u2.txt"
- file3=wdir(1:pos-1) // "/" // digit // "-u3.txt"
-
- CALL export2d(temp1,sx1,sx2,file1)
- CALL export2d(temp2,sx1,sx2,file2)
- CALL export2d(temp3,sx1,sx2,file3)
-
- file1=digit // "-u1.txt "
- file2=digit // "-u2.txt "
- file3=digit // "-u3.txt "
- CALL report(i,time,file1,file2,file3,sx1,sx2,reportfilename)
-
- DEALLOCATE(temp1,temp2,temp3)
-
- END SUBROUTINE exporttxt
-#endif
-
- !------------------------------------------------------------------
- !> subroutine exportpoints
- !! sample a vector field at a series of points for export.
- !! each location is attributed a file in which the time evolution
- !! of the vector value is listed in the format:
- !!
- !! t_0 u(t_0) v(t_0) w(t_0)
- !! t_1 u(t_1) v(t_1) w(t_1)
- !! ...
- !!
- !! \author sylvain barbot (11/10/07) - original form
- !------------------------------------------------------------------
- SUBROUTINE exportpoints(c1,c2,c3,sig,sx1,sx2,sx3,dx1,dx2,dx3, &
- opts,ptsname,time,wdir,isnew,x0,y0,rot)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
-#endif
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- TYPE(VECTOR_STRUCT), INTENT(IN), DIMENSION(:) :: opts
- CHARACTER(LEN=4), INTENT(IN), DIMENSION(:) :: ptsname
- REAL*8, INTENT(IN) :: dx1,dx2,dx3,time,x0,y0,rot
- CHARACTER(80), INTENT(IN) :: wdir
- LOGICAL, INTENT(IN) :: isnew
-
- INTEGER :: i1,i2,i3,n,k
- REAL*8 :: u1,u2,u3,v1,v2,v3,x1,x2,x3,y1,y2,y3
- TYPE(TENSOR) :: lsig
- INTEGER :: i,iostatus
- CHARACTER(80) :: file1,file2
-
- i=INDEX(wdir," ")
- n=SIZE(ptsname)
-
- DO k=1,n
- file1=wdir(1:i-1) // "/" // ptsname(k) // ".txt"
- file2=wdir(1:i-1) // "/" // ptsname(k) // ".c.txt"
-
- IF (isnew) THEN
- OPEN (UNIT=15,FILE=file1,IOSTAT=iostatus,FORM="FORMATTED")
- WRITE (15,'("# t u1 u2 u3 ", &
- "s11 s12 s13 s22 s23 s33")')
- OPEN (UNIT=16,FILE=file2,IOSTAT=iostatus,FORM="FORMATTED")
- ELSE
- OPEN (UNIT=15,FILE=file1,POSITION="APPEND",&
- IOSTAT=iostatus,FORM="FORMATTED")
- OPEN (UNIT=16,FILE=file2,POSITION="APPEND",&
- IOSTAT=iostatus,FORM="FORMATTED")
- END IF
- IF (iostatus>0) STOP "could not open point file for writing"
-
- x1=opts(k)%v1
- x2=opts(k)%v2
- x3=opts(k)%v3
-
- CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
-
- u1=c1(i1,i2,i3)
- u2=c2(i1,i2,i3)
- u3=c3(i1,i2,i3)
- lsig=sig(i1,i2,i3)
-
- ! change from computational reference frame to user reference system
- y1=x1;v1=u1
- y2=x2;v2=u2
- y3=x3;v3=u3
-
- CALL rotation(y1,y2,-rot)
- y1=y1+x0
- y2=y2+y0
- CALL rotation(v1,v2,-rot)
-
- x1=x1+x0
- x2=x2+y0
-
- WRITE (15,'(13ES11.3E2)') time,v1,v2,v3, &
- lsig%s11,lsig%s12,lsig%s13, &
- lsig%s22,lsig%s23,lsig%s33
- WRITE (16,'(7ES11.3E2)') x1,x2,x3,time,u1,u2,u3
-
- CLOSE(15)
- CLOSE(16)
- END DO
-
- CONTAINS
-
- !------------------------------------------------------------------
- ! subroutine Rotation
- ! rotates a point coordinate into the computational reference
- ! system.
- !
- ! sylvain barbot (04/16/09) - original form
- !------------------------------------------------------------------
- SUBROUTINE rotation(x,y,rot)
- REAL*8, INTENT(INOUT) :: x,y
- REAL*8, INTENT(IN) :: rot
-
- REAL*8 :: alpha,xx,yy
- REAL*8, PARAMETER :: DEG2RAD = 0.01745329251994329547437168059786927_8
-
-
- alpha=rot*DEG2RAD
- xx=x
- yy=y
-
- x=+xx*cos(alpha)+yy*sin(alpha)
- y=-xx*sin(alpha)+yy*cos(alpha)
-
- END SUBROUTINE rotation
-
- END SUBROUTINE exportpoints
-
- !---------------------------------------------------------------------
- !> subroutine exportoptsdat
- !! export the coordinates and name of the observation points (often
- !! coordinates of GPS instruments or such) for display with GMT in the
- !! ASCII format. The file contains a list of x1,x2,x3 coordinates and
- !! a 4-character name string.
- !!
- !! input variables
- !! @param n - number of observation points
- !! @param opts - coordinates of observation points
- !! @param ptsname - name of obs. points
- !! @param filename - output file (example: wdir/opts.xy)
- !!
- !! \author sylvain barbot (08/10/11) - original form
- !---------------------------------------------------------------------
- SUBROUTINE exportoptsdat(n,opts,ptsname,filename)
- INTEGER, INTENT(IN) :: n
- TYPE(VECTOR_STRUCT), DIMENSION(n) :: opts
- CHARACTER(LEN=4), DIMENSION(n) :: ptsname
- CHARACTER(80) :: filename
-
- INTEGER :: k,iostatus
-
- IF (n.LE.0) RETURN
-
- OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) STOP "could not open .xy file to export observation points"
- DO k=1,n
- WRITE (15,'(3ES11.4E1,X,a)') opts(k)%v1,opts(k)%v2,opts(k)%v3,ptsname(k)
- END DO
- CLOSE(15)
-
- END SUBROUTINE exportoptsdat
-
- !---------------------------------------------------------------------
- !> subroutine exportPlaneStress
- !! samples the value of an input tensor field at the location of
- !! defined plane (position, strike, dip, length and width).
- !!
- !! input variables
- !! @param sig - sampled tensor array
- !! @param nop - number of observation planes
- !! @param op - structure of observation planes (position, orientation)
- !! @param x0, y0 - origin position of coordinate system
- !! @param dx1,2,3 - sampling size
- !! @param sx1,2,3 - size of the scalar field
- !! @param wdir - output directory for writing
- !! @param i - loop index to suffix file names
- !!
- !! creates files
- !!
- !! wdir/index.s00001.estrain.txt with TXT_EXPORTEIGENSTRAIN option
- !!
- !! wdir/index.s00001.estrain.grd with GRD_EXPORTEIGENSTRAIN option
- !!
- !! \author sylvain barbot (01/01/07) - original form
- ! (02/25/10) - output in TXT and GRD formats
- !---------------------------------------------------------------------
- SUBROUTINE exportplanestress(sig,nop,op,x0,y0,dx1,dx2,dx3,sx1,sx2,sx3,wdir,i)
- INTEGER, INTENT(IN) :: nop,sx1,sx2,sx3,i
- TYPE(PLANE_STRUCT), INTENT(IN), DIMENSION(nop) :: op
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- REAL*8, INTENT(IN) :: x0,y0,dx1,dx2,dx3
- CHARACTER(80), INTENT(IN) :: wdir
-
- INTEGER :: k,ns1,ns2
- TYPE(SLIPPATCH_STRUCT), DIMENSION(:,:), ALLOCATABLE :: slippatch
- CHARACTER(3) :: sdigit
- CHARACTER(3) :: digit
-#ifdef TXT_EXPORTEIGENSTRAIN
- INTEGER :: iostatus,i1,i2
- CHARACTER(80) :: outfiletxt
-#endif
-!#_indef GRD_EXPORTEIGENSTRAIN
- CHARACTER(80) :: fn11,fn12,fn13,fn22,fn23,fn33
- INTEGER :: j,iostat,j1,j2
- REAL*4, ALLOCATABLE, DIMENSION(:,:) :: temp11,temp12,temp13, &
- temp22,temp23,temp33
- REAL*8 :: rland=9998.,rdum=9999.
- REAL*8 :: xmin,ymin
- CHARACTER(80) :: title="monitor tensor field "
-!#_endif
-
- IF (nop .le. 0) RETURN
-
- WRITE (digit,'(I3.3)') i
-
- DO k=1,nop
- CALL monitorstressfield(op(k)%x,op(k)%y,op(k)%z, &
- op(k)%width,op(k)%length,op(k)%strike,op(k)%dip, &
- 0._8,sx1,sx2,sx3,dx1,dx2,dx3,sig,slippatch)
-
- IF (.NOT. ALLOCATED(slippatch)) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("could not monitor slip")')
- STOP 2
- END IF
-
- ns1=SIZE(slippatch,1)
- ns2=SIZE(slippatch,2)
-
- slippatch(:,:)%x1=slippatch(:,:)%x1+x0
- slippatch(:,:)%x2=slippatch(:,:)%x2+y0
-
- WRITE (sdigit,'(I3.3)') k
-
-!#_ifdef GRD_EXPORTEIGENSTRAIN
- fn11=trim(wdir)//"/"//digit//".op"//sdigit//"-s11.grd"
- fn12=trim(wdir)//"/"//digit//".op"//sdigit//"-s12.grd"
- fn13=trim(wdir)//"/"//digit//".op"//sdigit//"-s13.grd"
- fn22=trim(wdir)//"/"//digit//".op"//sdigit//"-s22.grd"
- fn23=trim(wdir)//"/"//digit//".op"//sdigit//"-s23.grd"
- fn33=trim(wdir)//"/"//digit//".op"//sdigit//"-s33.grd"
-
- ! convert to c standard
- j=INDEX(fn11," ")
- fn11(j:j)=char(0)
- fn12(j:j)=char(0)
- fn13(j:j)=char(0)
- fn22(j:j)=char(0)
- fn23(j:j)=char(0)
- fn33(j:j)=char(0)
-
- ALLOCATE(temp11(ns1,ns2),temp12(ns1,ns2),temp13(ns1,ns2), &
- temp22(ns1,ns2),temp23(ns1,ns2),temp33(ns1,ns2),STAT=iostat)
- IF (iostatus>0) STOP "could not allocate temporary array for GRD slip export."
-
- DO j2=1,ns2
- DO j1=1,ns1
- temp11(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s11
- temp12(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s12
- temp13(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s13
- temp22(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s22
- temp23(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s23
- temp33(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s33
- END DO
- END DO
-
- ! xmin is the lowest coordinates (positive eastward in GMT)
- xmin= MINVAL(slippatch(:,:)%lx)
- ! ymin is the lowest coordinates (positive northward in GMT)
- ymin=-MAXVAL(slippatch(:,:)%lz)
-
- ! call the c function "writegrd_"
- CALL writegrd(temp11,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn11)
- CALL writegrd(temp12,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn12)
- CALL writegrd(temp13,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn13)
- CALL writegrd(temp22,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn22)
- CALL writegrd(temp23,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn23)
- CALL writegrd(temp33,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn33)
-
- DEALLOCATE(temp11,temp12,temp13,temp22,temp23,temp33)
-
-!#_endif
-
- DEALLOCATE(slippatch)
- END DO
-
-END SUBROUTINE exportplanestress
-
- !---------------------------------------------------------------------
- !> subroutine exportEigenstrain
- !! samples the value of an input scalar field at the location of
- !! defined plane (position, strike, dip, length and width).
- !!
- !! input variables
- !! @param field - sampled scalar array
- !! @param nop - number of observation planes
- !! @param op - structure of observation planes (position, orientation)
- !! @param x0, y0 - origin position of coordinate system
- !! @param dx1,2,3 - sampling size
- !! @param sx1,2,3 - size of the scalar field
- !! @param wdir - output directory for writing
- !! @param i - loop index to suffix file names
- !!
- !! creates files
- !!
- !! wdir/index.s00001.estrain.txt with TXT_EXPORTEIGENSTRAIN option
- !!
- !! wdir/index.s00001.estrain.grd with GRD_EXPORTEIGENSTRAIN option
- !!
- !! \author sylvain barbot (01/01/07) - original form
- ! (02/25/10) - output in TXT and GRD formats
- !---------------------------------------------------------------------
- SUBROUTINE exporteigenstrain(field,nop,op,x0,y0,dx1,dx2,dx3,sx1,sx2,sx3,wdir,i)
- INTEGER, INTENT(IN) :: nop,sx1,sx2,sx3,i
- TYPE(PLANE_STRUCT), INTENT(IN), DIMENSION(nop) :: op
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: field
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: field
-#endif
- REAL*8, INTENT(IN) :: x0,y0,dx1,dx2,dx3
- CHARACTER(80), INTENT(IN) :: wdir
-
- INTEGER :: k,ns1,ns2,pos
- TYPE(SLIPPATCH_STRUCT), DIMENSION(:,:), ALLOCATABLE :: slippatch
- CHARACTER(5) :: sdigit
- CHARACTER(3) :: digit
-#ifdef TXT_EXPORTEIGENSTRAIN
- INTEGER :: iostatus,i1,i2
- CHARACTER(80) :: outfiletxt
-#endif
-!#_indef GRD_EXPORTEIGENSTRAIN
- CHARACTER(80) :: outfilegrd
- INTEGER :: j,iostat,j1,j2
- REAL*4, ALLOCATABLE, DIMENSION(:,:) :: temp
- REAL*8 :: rland=9998.,rdum=9999.
- REAL*8 :: xmin,ymin
- CHARACTER(80) :: title="monitor field "
-!#_endif
-
- IF (nop .le. 0) RETURN
-
- pos=INDEX(wdir," ")
- WRITE (digit,'(I3.3)') i
-
- DO k=1,nop
- CALL monitorfield(op(k)%x,op(k)%y,op(k)%z, &
- op(k)%width,op(k)%length,op(k)%strike,op(k)%dip, &
- 0._8,sx1,sx2,sx3,dx1,dx2,dx3,field,slippatch)
-
- IF (.NOT. ALLOCATED(slippatch)) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("could not monitor slip")')
- STOP 2
- END IF
-
- ns1=SIZE(slippatch,1)
- ns2=SIZE(slippatch,2)
-
- slippatch(:,:)%x1=slippatch(:,:)%x1+x0
- slippatch(:,:)%x2=slippatch(:,:)%x2+y0
-
- WRITE (sdigit,'(I5.5)') k
-#ifdef TXT_EXPORTEIGENSTRAIN
- outfiletxt=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".estrain.txt"
-
- OPEN (UNIT=15,FILE=outfiletxt,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) STOP "could not open file for export"
-
- WRITE (15,'(6ES11.3E2)') ((slippatch(i1,i2), i1=1,ns1), i2=1,ns2)
-
- CLOSE(15)
-#endif
-
-!#_ifdef GRD_EXPORTEIGENSTRAIN
- outfilegrd=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".estrain.grd"
-
- ! convert to c standard
- j=INDEX(outfilegrd," ")
- outfilegrd(j:j)=char(0)
-
- ALLOCATE(temp(ns1,ns2),STAT=iostat)
- IF (iostatus>0) STOP "could not allocate temporary array for GRD slip export."
-
- DO j2=1,ns2
- DO j1=1,ns1
- temp(ns1+1-j1,j2)=slippatch(j1,j2)%slip
- END DO
- END DO
-
- ! xmin is the lowest coordinates (positive eastward in GMT)
- xmin= MINVAL(slippatch(:,:)%lx)
- ! ymin is the lowest coordinates (positive northward in GMT)
- ymin=-MAXVAL(slippatch(:,:)%lz)
-
- ! call the c function "writegrd_"
- CALL writegrd(temp,ns1,ns2,ymin,xmin,dx3,dx2, &
- rland,rdum,title,outfilegrd)
-
- DEALLOCATE(temp)
-
-!#_endif
-
- DEALLOCATE(slippatch)
- END DO
-
-END SUBROUTINE exporteigenstrain
-
- !---------------------------------------------------------------------
- !> subroutine exportCreep
- !! evaluates the value of creep velocity at the location of
- !! defined plane (position, strike, dip, length and width).
- !!
- !! input variables
- !! @param np - number of frictional planes
- !! @param n - array of frictional planes (position, orientation)
- !! @param structure - array of depth-dependent frictional properties
- !! @param x0, y0 - origin position of coordinate system
- !! @param dx1,2,3 - sampling size
- !! @param sx1,2,3 - size of the stress tensor field
- !! @param beta - smoothing factor controlling the extent of planes
- !! @param wdir - output directory for writing
- !! @param i - loop index to suffix file names
- !!
- !! creates files
- !!
- !! wdir/index.s00001.creep.txt
- !!
- !! containing
- !!
- !! x,y,z,x',y',sqrt(vx'^2+vy'^2),vx',vy'
- !!
- !! with TXT_EXPORTCREEP option and
- !!
- !! wdir/index.s00001.creep-north.grd
- !! wdir/index.s00001.creep-east.grd
- !! wdir/index.s00001.creep-up.grd
- !!
- !! with GRD_EXPORTCREEP option where the suffix -north stands for
- !! dip slip, -east for strike slip and -up for amplitude of slip.
- !!
- !! file wdir/index.s00001.creep.txt is subsampled by a factor "skip"
- !! compared to the grd files.
- !!
- !! \author sylvain barbot (01/01/07) - original form
- !! (02/25/10) - output in TXT and GRD formats
- !---------------------------------------------------------------------
-#define TXT_EXPORTCREEP
- SUBROUTINE exportcreep(np,n,beta,sig,structure, &
- sx1,sx2,sx3,dx1,dx2,dx3,x0,y0,wdir,i)
- INTEGER, INTENT(IN) :: np,sx1,sx2,sx3,i
- TYPE(PLANE_STRUCT), INTENT(IN), DIMENSION(np) :: n
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
- REAL*8, INTENT(IN) :: x0,y0,dx1,dx2,dx3,beta
- CHARACTER(80), INTENT(IN) :: wdir
-
- INTEGER :: k,ns1,ns2,pos
- TYPE(SLIPPATCH_STRUCT), DIMENSION(:,:), ALLOCATABLE :: slippatch
- CHARACTER(5) :: sdigit
- CHARACTER(3) :: digit
-#ifdef TXT_EXPORTCREEP
- CHARACTER(80) :: outfile
- INTEGER :: skip=3
-#endif
-#ifdef GRD_EXPORTCREEP
- INTEGER :: j,iostatus,i1,i2
- REAL*4, ALLOCATABLE, DIMENSION(:,:) :: temp1,temp2,temp3
- REAL*8 :: rland=9998.,rdum=9999.
- REAL*8 :: xmin,ymin
- CHARACTER(80) :: title="monitor field "
- CHARACTER(80) :: file1,file2,file3
-#endif
-
- IF (np .le. 0) RETURN
-
- pos=INDEX(wdir," ")
- WRITE (digit,'(I3.3)') i
-
- DO k=1,np
- CALL monitorfriction(n(k)%x,n(k)%y,n(k)%z, &
- n(k)%width,n(k)%length,n(k)%strike,n(k)%dip,n(k)%rake,beta, &
- sx1,sx2,sx3,dx1,dx2,dx3,sig,structure,slippatch)
-
- ns1=SIZE(slippatch,1)
- ns2=SIZE(slippatch,2)
-
- slippatch(:,:)%x1=slippatch(:,:)%x1+x0
- slippatch(:,:)%x2=slippatch(:,:)%x2+y0
-
- WRITE (sdigit,'(I5.5)') k
-#ifdef TXT_EXPORTCREEP
- outfile=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".creep.txt"
-
- OPEN (UNIT=15,FILE=outfile,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) STOP "could not open file for export"
-
- WRITE (15,'("# x1 x2 x3 yr yz", &
- " slip strike-slip dip-slip")')
- WRITE (15,'(8ES11.3E2)') ((slippatch(i1,i2), i1=1,ns1,skip), i2=1,ns2,skip)
-
- CLOSE(15)
-#endif
-
-#ifdef GRD_EXPORTCREEP
- file1=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".creep-north.grd"
- file2=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".creep-east.grd"
- file3=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".creep-up.grd"
-
- ! convert to c standard
- j=INDEX(file1," ")
- file1(j:j)=char(0)
- j=INDEX(file2," ")
- file2(j:j)=char(0)
- j=INDEX(file3," ")
- file3(j:j)=char(0)
-
- ALLOCATE(temp1(ns1,ns2),temp2(ns1,ns2),temp3(ns1,ns2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate temporary arrays for GRD slip export."
-
- DO i2=1,ns2
- DO i1=1,ns1
- temp1(ns1+1-i1,i2)=slippatch(i1,i2)%ds
- temp2(ns1+1-i1,i2)=slippatch(i1,i2)%ss
- temp3(ns1+1-i1,i2)=slippatch(i1,i2)%slip
- END DO
- END DO
-
- ! xmin is the lowest coordinates (positive eastward in GMT)
- xmin= MINVAL(slippatch(:,:)%lx)
- ! ymin is the lowest coordinates (positive northward in GMT)
- ymin=-MAXVAL(slippatch(:,:)%lz)
-
- ! call the c function "writegrd_"
- CALL writegrd(temp1,ns1,ns2,ymin,xmin,dx3,dx2, &
- rland,rdum,title,file1)
- CALL writegrd(temp2,ns1,ns2,ymin,xmin,dx3,dx2, &
- rland,rdum,title,file2)
- CALL writegrd(temp3,ns1,ns2,ymin,xmin,dx3,dx2, &
- rland,rdum,title,file3)
-
- DEALLOCATE(temp1,temp2,temp3)
-
-#endif
-
- DEALLOCATE(slippatch)
- END DO
-
-END SUBROUTINE exportcreep
-
-#ifdef GRD
- !------------------------------------------------------------------
- !> subroutine ExportStressGRD
- !! writes the 6 components of deformation in map view in the GMT
- !! (Generic Mapping Tools) GRD binary format. This is an interface
- !! to exportgrd.
- !!
- !! \author sylvain barbot 03/19/08 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportstressgrd(sig,sx1,sx2,sx3,dx1,dx2,dx3, &
- oz,origx,origy,wdir,index)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,index
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- REAL*8, INTENT(IN) :: dx1,dx2,dx3,origx,origy,oz
- CHARACTER(80), INTENT(IN) :: wdir
-
- REAL*4, DIMENSION(:,:), ALLOCATABLE :: t1,t2,t3
- INTEGER :: iostatus,i,j,k,l
-
- ALLOCATE(t1(sx1+2,sx2),t2(sx1+2,sx2),t3(sx1+2,sx2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate memory for grid export"
-
- k=fix(oz/dx3)+1
- DO j=1,sx2
- DO i=1,sx1
-#ifdef ALIGN_DATA
- l=(j-1)*(sx1+2)+i
-#else
- l=(j-1)*sx1+i
-#endif
- t1(l,1)=sig(i,j,k)%s11
- t2(l,1)=sig(i,j,k)%s12
- t3(l,1)=sig(i,j,k)%s13
- END DO
- END DO
-
- CALL exportgrd(t1,t2,t3,sx1,sx2,1, &
- dx1,dx2,dx3,0._8,origx,origy,wdir,index,convention=4)
-
- DO j=1,sx2
- DO i=1,sx1
-#ifdef ALIGN_DATA
- l=(j-1)*(sx1+2)+i
-#else
- l=(j-1)*sx1+i
-#endif
- t1(l,1)=sig(i,j,k)%s22
- t2(l,1)=sig(i,j,k)%s23
- t3(l,1)=sig(i,j,k)%s33
- END DO
- END DO
-
- CALL exportgrd(t1,t2,t3,sx1,sx2,1, &
- dx1,dx2,dx3,0._8,origx,origy,wdir,index,convention=5)
-
- DEALLOCATE(t1,t2,t3)
-
- END SUBROUTINE exportstressgrd
-
-
- !------------------------------------------------------------------
- !> subroutine ExportGRD
- !! writes the 3 components of deformation in map view in the GMT
- !! (Generic Mapping Tools) GRD binary format.
- !!
- !! \author sylvain barbot 03/19/08 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportgrd(c1,c2,c3,sx1,sx2,sx3,dx1,dx2,dx3,oz,origx,origy,&
- wdir,i,convention)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,i
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
-#endif
- REAL*8, INTENT(IN) :: dx1,dx2,dx3,origx,origy,oz
- CHARACTER(80), INTENT(IN) :: wdir
- INTEGER, INTENT(IN), OPTIONAL :: convention
-
- REAL*4, DIMENSION(:,:), ALLOCATABLE :: temp1,temp2,temp3
- REAL*8 :: rland=9998.,rdum=9999.
- INTEGER :: iostatus,k,pos,conv
- REAL*8 :: xmin,ymin
- CHARACTER(80) :: file1,file2,file3
- CHARACTER(3) :: digit
-
- IF (PRESENT(convention)) THEN
- conv=convention
- ELSE
- conv=1
- END IF
-
- ALLOCATE(temp1(sx2,sx1),temp2(sx2,sx1),temp3(sx2,sx1),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate memory for grid export"
-
- CALL exportspatial(c1(:,:,int(oz/dx3)+1),sx1,sx2,temp1,doflip=.true.)
- CALL exportspatial(c2(:,:,int(oz/dx3)+1),sx1,sx2,temp2,doflip=.true.)
- CALL exportspatial(c3(:,:,int(oz/dx3)+1),sx1,sx2,temp3,doflip=.true.)
-
- ! positive up
- temp3=-temp3
-
- pos=INDEX(wdir," ")
- WRITE (digit,'(I3.3)') i
-
- SELECT CASE(conv)
- CASE (1) ! cumulative displacement
- file1=wdir(1:pos-1) // "/" // digit // "-north.grd"
- file2=wdir(1:pos-1) // "/" // digit // "-east.grd"
- file3=wdir(1:pos-1) // "/" // digit // "-up.grd"
- CASE (2) ! postseismic displacement
- file1=wdir(1:pos-1) // "/" // digit // "-relax-north.grd"
- file2=wdir(1:pos-1) // "/" // digit // "-relax-east.grd"
- file3=wdir(1:pos-1) // "/" // digit // "-relax-up.grd"
- CASE (3) ! equivalent body forces
- file1=wdir(1:pos-1) // "/" // digit // "-eqbf-north.grd"
- file2=wdir(1:pos-1) // "/" // digit // "-eqbf-east.grd"
- file3=wdir(1:pos-1) // "/" // digit // "-eqbf-up.grd"
- CASE (4) ! equivalent body forces
- file1=wdir(1:pos-1) // "/" // digit // "-s11.grd"
- file2=wdir(1:pos-1) // "/" // digit // "-s12.grd"
- file3=wdir(1:pos-1) // "/" // digit // "-s13.grd"
- CASE (5) ! equivalent body forces
- file1=wdir(1:pos-1) // "/" // digit // "-s22.grd"
- file2=wdir(1:pos-1) // "/" // digit // "-s23.grd"
- file3=wdir(1:pos-1) // "/" // digit // "-s33.grd"
- END SELECT
-
- ! convert to c standard
- k=INDEX(file1," ")
- file1(k:k)=char(0)
- k=INDEX(file2," ")
- file2(k:k)=char(0)
- k=INDEX(file3," ")
- file3(k:k)=char(0)
-
- ! xmin is the lowest coordinates (positive eastward)
- xmin=origy-sx2/2*dx2
- ! ymin is the lowest coordinates (positive northward)
- ymin=origx-sx1/2*dx1
-
- ! call the c function "writegrd_"
- CALL writegrd(temp1,sx2,sx1,ymin,xmin,dx1,dx2, &
- rland,rdum,file1,file1)
- CALL writegrd(temp2,sx2,sx1,ymin,xmin,dx1,dx2, &
- rland,rdum,file2,file2)
- CALL writegrd(temp3,sx2,sx1,ymin,xmin,dx1,dx2, &
- rland,rdum,file3,file3)
-
- DEALLOCATE(temp1,temp2,temp3)
-
- END SUBROUTINE exportgrd
-#endif
-
-#ifdef VTK
- !------------------------------------------------------------------
- !> subroutine ExportVTK_Grid
- !! creates a .vtp file (in the VTK PolyData XML format) containing
- !! the dimension of the computational grid
- !!
- !! \author sylvain barbot 06/24/09 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportvtk_grid(sx1,sx2,sx3,dx1,dx2,dx3,cgfilename)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- CHARACTER(80), INTENT(IN) :: cgfilename
-
- INTEGER :: iostatus
- CHARACTER :: q
-
- q=char(34)
-
- OPEN (UNIT=15,FILE=cgfilename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', cgfilename
- STOP "could not open file for export"
- END IF
-
- WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
- WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
- WRITE (15,'(" <PolyData>")')
- WRITE (15,'(" <Piece NumberOfPoints=",a,"8",a," NumberOfPolys=",a,"6",a,">")'),q,q,q,q
- WRITE (15,'(" <Points>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Comp. Grid",a, &
- " NumberOfComponents=",a,"3",a, &
- " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
- WRITE (15,'(24ES9.2E1)') &
- -sx1*dx1/2, -sx2*dx2/2, sx3*dx3/2, &
- +sx1*dx1/2, -sx2*dx2/2, sx3*dx3/2, &
- +sx1*dx1/2, +sx2*dx2/2, sx3*dx3/2, &
- -sx1*dx1/2, +sx2*dx2/2, sx3*dx3/2, &
- -sx1*dx1/2, -sx2*dx2/2, 0.0, &
- +sx1*dx1/2, -sx2*dx2/2, 0.0, &
- +sx1*dx1/2, +sx2*dx2/2, 0.0, &
- -sx1*dx1/2, +sx2*dx2/2, 0.0
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Points>")')
- WRITE (15,'(" <Polys>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"connectivity",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"0",a, &
- " RangeMax=",a,"7",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'("0 1 2 3 4 5 6 7 2 3 7 6 0 3 7 4 0 1 5 4 1 2 6 5")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"offsets",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"4",a, &
- " RangeMax=",a,"24",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'(" 4 8 12 16 20 24")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Polys>")')
- WRITE (15,'(" </Piece>")')
- WRITE (15,'(" </PolyData>")')
- WRITE (15,'("</VTKFile>")')
-
- CLOSE(15)
-
- END SUBROUTINE exportvtk_grid
-
- !------------------------------------------------------------------
- !> subroutine ExportXY_RFaults
- !! creates a .xy file (in the GMT closed-polygon format) containing
- !! the rectangular faults. Each fault segemnt is described by a
- !! closed polygon (rectangle) associated with a slip amplitude.
- !! use pxzy with the -Cpalette.cpt -L -M options to color rectangles
- !! by slip.
- !!
- !! \author sylvain barbot 03/05/11 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportxy_rfaults(e,x0,y0,rffilename)
- TYPE(EVENT_STRUC), INTENT(IN) :: e
- REAL*8, INTENT(IN) :: x0, y0
- CHARACTER(80), INTENT(IN) :: rffilename
-
- INTEGER :: iostatus,k
- CHARACTER :: q
-
- REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W,slip
-
- REAL*8, DIMENSION(3) :: s,d
-
- ! double-quote character
- q=char(34)
-
- OPEN (UNIT=15,FILE=rffilename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', rffilename
- STOP "could not open file for export"
- END IF
-
- WRITE (15,'("> # east, north")')
- DO k=1,e%ns
-
- ! fault slip
- slip=e%s(k)%slip
-
- ! fault orientation
- strike=e%s(k)%strike
- dip=e%s(k)%dip
-
- ! fault center position
- x1=e%s(k)%x+x0
- x2=e%s(k)%y+y0
- x3=e%s(k)%z
-
- ! fault dimension
- W=e%s(k)%width
- L=e%s(k)%length
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! strike-slip unit direction
- s(1)=sstrike
- s(2)=cstrike
- s(3)=0._8
-
- ! dip-slip unit direction
- d(1)=+cstrike*sdip
- d(2)=-sstrike*sdip
- d(3)=+cdip
-
- ! fault edge coordinates - export east (x2) and north (x1)
- WRITE (15,'("> -Z",3ES11.2)') ABS(slip)
- WRITE (15,'(3ES11.2)') x2-d(2)*W/2-s(2)*L/2, x1-d(1)*W/2-s(1)*L/2
- WRITE (15,'(3ES11.2)') x2-d(2)*W/2+s(2)*L/2, x1-d(1)*W/2+s(1)*L/2
- WRITE (15,'(3ES11.2)') x2+d(2)*W/2+s(2)*L/2, x1+d(1)*W/2+s(1)*L/2
- WRITE (15,'(3ES11.2)') x2+d(2)*W/2-s(2)*L/2, x1+d(1)*W/2-s(1)*L/2
-
- END DO
-
- CLOSE(15)
-
- END SUBROUTINE exportxy_rfaults
-
- !------------------------------------------------------------------
- !> subroutine ExportVTK_RFaults
- !! creates a .vtp file (in the VTK PolyData XML format) containing
- !! the rectangular faults. The faults are characterized with a set
- !! of subsegments (rectangles) each associated with a slip vector.
- !!
- !! \author sylvain barbot 06/24/09 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportvtk_rfaults(e,rffilename)
- TYPE(EVENT_STRUC), INTENT(IN) :: e
- CHARACTER(80), INTENT(IN) :: rffilename
-
- INTEGER :: iostatus,k
- CHARACTER :: q
-
- REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W,slip
-
- REAL*8, DIMENSION(3) :: s,d
-
- ! double-quote character
- q=char(34)
-
- OPEN (UNIT=15,FILE=rffilename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', rffilename
- STOP "could not open file for export"
- END IF
-
- WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
- WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
- WRITE (15,'(" <PolyData>")')
-
- DO k=1,e%ns
-
- ! fault slip
- slip=e%s(k)%slip
-
- ! fault orientation
- strike=e%s(k)%strike
- dip=e%s(k)%dip
-
- ! fault center position
- x1=e%s(k)%x
- x2=e%s(k)%y
- x3=e%s(k)%z
-
- ! fault dimension
- W=e%s(k)%width
- L=e%s(k)%length
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! strike-slip unit direction
- s(1)=sstrike
- s(2)=cstrike
- s(3)=0._8
-
- ! dip-slip unit direction
- d(1)=+cstrike*sdip
- d(2)=-sstrike*sdip
- d(3)=+cdip
-
- WRITE (15,'(" <Piece NumberOfPoints=",a,"4",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
- WRITE (15,'(" <Points>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Fault Patch",a, &
- " NumberOfComponents=",a,"3",a, &
- " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
-
- ! fault edge coordinates
- WRITE (15,'(12ES11.2)') &
- x1-d(1)*W/2-s(1)*L/2,x2-d(2)*W/2-s(2)*L/2,x3-d(3)*W/2-s(3)*L/2, &
- x1-d(1)*W/2+s(1)*L/2,x2-d(2)*W/2+s(2)*L/2,x3-d(3)*W/2+s(3)*L/2, &
- x1+d(1)*W/2+s(1)*L/2,x2+d(2)*W/2+s(2)*L/2,x3+d(3)*W/2+s(3)*L/2, &
- x1+d(1)*W/2-s(1)*L/2,x2+d(2)*W/2-s(2)*L/2,x3+d(3)*W/2-s(3)*L/2
-
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Points>")')
- WRITE (15,'(" <Polys>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"connectivity",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"0",a, &
- " RangeMax=",a,"3",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'("0 1 2 3")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"offsets",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"4",a, &
- " RangeMax=",a,"4",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'(" 4")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Polys>")')
-
- WRITE (15,'(" <CellData Normals=",a,"slip",a,">")'), q,q
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"slip",a, &
- " NumberOfComponents=",a,"3",a, &
- " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
-
-
- WRITE (15,'(3ES11.2)'), (s(1)+d(1))*slip,(s(2)+d(2))*slip,(s(3)+s(3))*slip
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </CellData>")')
-
- WRITE (15,'(" </Piece>")')
-
- END DO
-
- WRITE (15,'(" </PolyData>")')
- WRITE (15,'("</VTKFile>")')
-
- CLOSE(15)
-
- END SUBROUTINE exportvtk_rfaults
-
- !------------------------------------------------------------------
- !> subroutine ExportVTK_RFaults_Stress_Init
- !! creates a .vtp file (in the VTK PolyData XML format) containing
- !! the rectangular faults. The faults are characterized with a set
- !! of subsegments (rectangles) each associated with stress values.
- !!
- !! \author sylvain barbot 06/06/11 - original form
- !------------------------------------------------------------------
- SUBROUTINE export_rfaults_stress_init(sig,sx1,sx2,sx3,dx1,dx2,dx3, &
- nsop,sop)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,nsop
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- TYPE(SEGMENT_STRUCT), INTENT(INOUT), DIMENSION(nsop) :: sop
-
- INTEGER :: k,i1,i2,i3
- REAL*8 :: x1,x2,x3
- ! local value of stress
- TYPE(TENSOR) :: lsig
-
- DO k=1,nsop
- ! fault center position
- x1=sop(k)%x
- x2=sop(k)%y
- x3=sop(k)%z
-
- CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
- lsig=sig(i1,i2,i3)
-
- sop(k)%sig0%s11=lsig%s11
- sop(k)%sig0%s12=lsig%s12
- sop(k)%sig0%s13=lsig%s13
- sop(k)%sig0%s22=lsig%s22
- sop(k)%sig0%s23=lsig%s23
- sop(k)%sig0%s33=lsig%s33
-
- END DO
-
- END SUBROUTINE export_rfaults_stress_init
-
- !------------------------------------------------------------------
- !> subroutine ExportGMT_RFaults_Stress
- !! creates a .vtp file (in the VTK PolyData XML format) containing
- !! the rectangular faults. The faults are characterized with a set
- !! of subsegments (rectangles) each associated with stress values.
- !!
- !! \author sylvain barbot 06/06/11 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportgmt_rfaults_stress(sx1,sx2,sx3,dx1,dx2,dx3, &
- nsop,sop,rffilename,convention,sig)
- USE elastic3d
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,nsop
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- TYPE(SEGMENT_STRUCT), INTENT(INOUT), DIMENSION(nsop) :: sop
- CHARACTER(80), INTENT(IN) :: rffilename
- INTEGER, INTENT(IN), OPTIONAL :: convention
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3), OPTIONAL :: sig
-
- INTEGER :: iostatus,k,i1,i2,i3,conv
- CHARACTER :: q
- REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W
- ! segment normal vector, strike direction, dip direction
- REAL*8, DIMENSION(3) :: n,s,d
- ! local value of stress
- TYPE(TENSOR) :: lsig
- ! stress components
- REAL*8 :: taun,taus,taustrike,taudip,taucoulomb
- ! friction coefficient
- REAL*8 :: friction
- ! traction components
- REAL*8, DIMENSION(3) :: t,ts
-
- IF (0.GE.nsop) RETURN
-
- ! double-quote character
- q=char(34)
-
- IF (PRESENT(convention)) THEN
- conv=convention
- ELSE
- conv=0
- END IF
-
- OPEN (UNIT=15,FILE=rffilename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', rffilename
- STOP "could not open file for export"
- END IF
-
- DO k=1,nsop
- ! friction coefficient
- friction=sop(k)%friction
-
- ! fault orientation
- strike=sop(k)%strike
- dip=sop(k)%dip
-
- ! fault center position
- x1=sop(k)%x
- x2=sop(k)%y
- x3=sop(k)%z
-
- IF (PRESENT(sig)) THEN
-
- CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
- lsig=sig(i1,i2,i3)
-
- IF (1.EQ.conv) THEN
- lsig%s11=lsig%s11-sop(k)%sig0%s11
- lsig%s12=lsig%s12-sop(k)%sig0%s12
- lsig%s13=lsig%s13-sop(k)%sig0%s13
- lsig%s22=lsig%s22-sop(k)%sig0%s22
- lsig%s23=lsig%s23-sop(k)%sig0%s23
- lsig%s33=lsig%s33-sop(k)%sig0%s33
- END IF
- ELSE
- lsig=TENSOR(0.d0,0.d0,0.d0,0.d0,0.d0,0.d0)
- END IF
-
- ! fault dimension
- W=sop(k)%width
- L=sop(k)%length
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! surface normal vector components
- n(1)=+cdip*cstrike
- n(2)=-cdip*sstrike
- n(3)=-sdip
-
- ! strike-slip unit direction
- s(1)=sstrike
- s(2)=cstrike
- s(3)=0._8
-
- ! dip-slip unit direction
- d(1)=+cstrike*sdip
- d(2)=-sstrike*sdip
- d(3)=+cdip
-
- ! traction vector
- t=lsig .tdot. n
-
- ! signed normal component
- taun=SUM(t*n)
-
- ! shear traction
- ts=t-taun*n
-
- ! absolute value of shear component
- taus=SQRT(SUM(ts*ts))
-
- ! strike-direction shear component
- taustrike=SUM(ts*s)
-
- ! dip-direction shear component
- taudip=SUM(ts*d)
-
- ! Coulomb stress
- taucoulomb=taus+friction*taun
-
- WRITE (15,'("> -Z",5ES11.2)') taus, taun, taucoulomb, taustrike, taudip
- WRITE (15,'(3ES11.2)') x1-d(1)*W/2-s(1)*L/2, x2-d(2)*W/2-s(2)*L/2
- WRITE (15,'(3ES11.2)') x1-d(1)*W/2+s(1)*L/2, x2-d(2)*W/2+s(2)*L/2
- WRITE (15,'(3ES11.2)') x1+d(1)*W/2+s(1)*L/2, x2+d(2)*W/2+s(2)*L/2
- WRITE (15,'(3ES11.2)') x1+d(1)*W/2-s(1)*L/2, x2+d(2)*W/2-s(2)*L/2
-
- END DO
-
- CLOSE(15)
-
- END SUBROUTINE exportgmt_rfaults_stress
-
- !------------------------------------------------------------------
- !> subroutine ExportVTK_RFaults_Stress
- !! creates a .vtp file (in the VTK PolyData XML format) containing
- !! the rectangular faults. The faults are characterized with a set
- !! of subsegments (rectangles) each associated with stress values.
- !!
- !! \author sylvain barbot 06/06/11 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportvtk_rfaults_stress(sx1,sx2,sx3,dx1,dx2,dx3, &
- nsop,sop,rffilename,convention,sig)
- USE elastic3d
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,nsop
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- TYPE(SEGMENT_STRUCT), INTENT(INOUT), DIMENSION(nsop) :: sop
- CHARACTER(80), INTENT(IN) :: rffilename
- INTEGER, INTENT(IN), OPTIONAL :: convention
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3), OPTIONAL :: sig
-
- INTEGER :: iostatus,k,i1,i2,i3,conv
- CHARACTER :: q
- REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W
- ! segment normal vector, strike direction, dip direction
- REAL*8, DIMENSION(3) :: n,s,d
- ! local value of stress
- TYPE(TENSOR) :: lsig
- ! stress components
- REAL*8 :: taun,taus,taustrike,taudip,taucoulomb
- ! friction coefficient
- REAL*8 :: friction
- ! traction components
- REAL*8, DIMENSION(3) :: t,ts
-
- IF (0.GE.nsop) RETURN
-
- ! double-quote character
- q=char(34)
-
- IF (PRESENT(convention)) THEN
- conv=convention
- ELSE
- conv=0
- END IF
-
- OPEN (UNIT=15,FILE=rffilename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', rffilename
- STOP "could not open file for export"
- END IF
-
- WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
- WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
- WRITE (15,'(" <PolyData>")')
-
- DO k=1,nsop
- ! friction coefficient
- friction=sop(k)%friction
-
- ! fault orientation
- strike=sop(k)%strike
- dip=sop(k)%dip
-
- ! fault center position
- x1=sop(k)%x
- x2=sop(k)%y
- x3=sop(k)%z
-
- IF (PRESENT(sig)) THEN
-
- CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
- lsig=sig(i1,i2,i3)
-
- IF (1.EQ.conv) THEN
- lsig%s11=lsig%s11-sop(k)%sig0%s11
- lsig%s12=lsig%s12-sop(k)%sig0%s12
- lsig%s13=lsig%s13-sop(k)%sig0%s13
- lsig%s22=lsig%s22-sop(k)%sig0%s22
- lsig%s23=lsig%s23-sop(k)%sig0%s23
- lsig%s33=lsig%s33-sop(k)%sig0%s33
- END IF
- ELSE
- lsig=TENSOR(0.d0,0.d0,0.d0,0.d0,0.d0,0.d0)
- END IF
-
- ! fault dimension
- W=sop(k)%width
- L=sop(k)%length
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! surface normal vector components
- n(1)=+cdip*cstrike
- n(2)=-cdip*sstrike
- n(3)=-sdip
-
- ! strike-slip unit direction
- s(1)=sstrike
- s(2)=cstrike
- s(3)=0._8
-
- ! dip-slip unit direction
- d(1)=+cstrike*sdip
- d(2)=-sstrike*sdip
- d(3)=+cdip
-
- ! traction vector
- t=lsig .tdot. n
-
- ! signed normal component
- taun=SUM(t*n)
-
- ! shear traction
- ts=t-taun*n
-
- ! absolute value of shear component
- taus=SQRT(SUM(ts*ts))
-
- ! strike-direction shear component
- taustrike=SUM(ts*s)
-
- ! dip-direction shear component
- taudip=SUM(ts*d)
-
- ! Coulomb stress
- taucoulomb=taus+friction*taun
-
- WRITE (15,'(" <Piece NumberOfPoints=",a,"4",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
- WRITE (15,'(" <Points>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Fault Patch",a, &
- " NumberOfComponents=",a,"3",a, &
- " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
- ! fault edge coordinates
- WRITE (15,'(12ES11.2)') &
- x1-d(1)*W/2-s(1)*L/2, x2-d(2)*W/2-s(2)*L/2, x3-d(3)*W/2-s(3)*L/2, &
- x1-d(1)*W/2+s(1)*L/2, x2-d(2)*W/2+s(2)*L/2, x3-d(3)*W/2+s(3)*L/2, &
- x1+d(1)*W/2+s(1)*L/2, x2+d(2)*W/2+s(2)*L/2, x3+d(3)*W/2+s(3)*L/2, &
- x1+d(1)*W/2-s(1)*L/2, x2+d(2)*W/2-s(2)*L/2, x3+d(3)*W/2-s(3)*L/2
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" </Points>")')
- WRITE (15,'(" <Polys>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"connectivity",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"0",a, &
- " RangeMax=",a,"3",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'("0 1 2 3")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"offsets",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"4",a, &
- " RangeMax=",a,"4",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'(" 4")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Polys>")')
-
- WRITE (15,'(" <CellData Normals=",a,"stress",a,">")'), q,q
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"stress tensor",a, &
- " NumberOfComponents=",a,"6",a, &
- " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
- WRITE (15,'(6ES11.2)'), lsig%s11,lsig%s12,lsig%s13,lsig%s22,lsig%s23,lsig%s33
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"shear stress",a, &
- " NumberOfComponents=",a,"1",a, &
- " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
- WRITE (15,'(ES11.2)'), taus
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"normal stress",a, &
- " NumberOfComponents=",a,"1",a, &
- " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
- WRITE (15,'(ES11.2)'), taun
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Coulomb stress",a, &
- " NumberOfComponents=",a,"1",a, &
- " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
- WRITE (15,'(ES11.2)'), taucoulomb
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"stress in strike direction",a, &
- " NumberOfComponents=",a,"1",a, &
- " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
- WRITE (15,'(ES11.2)'), taustrike
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"stress in dip direction",a, &
- " NumberOfComponents=",a,"1",a, &
- " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
- WRITE (15,'(ES11.2)'), taudip
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" </CellData>")')
-
- WRITE (15,'(" </Piece>")')
-
- END DO
-
- WRITE (15,'(" </PolyData>")')
- WRITE (15,'("</VTKFile>")')
-
- CLOSE(15)
-
- END SUBROUTINE exportvtk_rfaults_stress
-
- !--------------------------------------------------------------------------------
- !> subroutine ExportCoulombStress
- !! sample the stress tensor, shear and normal stress and Coulomb
- !! stress at a series of locations.
- !!
- !! each fault patch is attributed to a file in which the time
- !! evolution is listed in the following format:
- !!
- !! #t s11 s12 s13 s22 s23 s33 taus taud tau taun Coulomb
- !! t0 s11(t0) s12(t0) s13(t0) s22(t0) s23(t0) s33(t0) taus(t0) taud(t0) tau(t0) taun(t0) Coulomb(t0)
- !! t1 s11(t1) s12(t1) s13(t1) s22(t1) s23(t1) s33(t1) taus(t1) taud(t1) tau(t1) taun(t1) Coulomb(t0)
- !! ...
- !!
- !! where sij(t0) is the component ij of the stress tensor at time t0, taus is
- !! the component of shear in the strike direction, taud is the component of shear
- !! in the fault dip direction, tau^2=taus^2+taud^2, taun is the fault normal
- !! stress and Coulomb(t0) is the Coulomb stress tau+mu*taun.
- !!
- !! \author sylvain barbot (10/05/11) - original form
- !--------------------------------------------------------------------------------
- SUBROUTINE exportcoulombstress(sig,sx1,sx2,sx3,dx1,dx2,dx3, &
- nsop,sop,time,wdir,isnew)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,nsop
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- TYPE(SEGMENT_STRUCT), INTENT(INOUT), DIMENSION(nsop) :: sop
- REAL*8, INTENT(IN) :: dx1,dx2,dx3,time
- CHARACTER(80), INTENT(IN) :: wdir
- LOGICAL, INTENT(IN) :: isnew
-
- INTEGER :: iostatus,k,i1,i2,i3
- CHARACTER :: q
- CHARACTER(4) :: digit4
- CHARACTER(80) :: file
- REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W
- ! segment normal vector, strike direction, dip direction
- REAL*8, DIMENSION(3) :: n,s,d
- ! local value of stress
- TYPE(TENSOR) :: lsig
- ! stress components
- REAL*8 :: taun,taus,taustrike,taudip,taucoulomb
- ! friction coefficient
- REAL*8 :: friction
- ! traction components
- REAL*8, DIMENSION(3) :: t,ts
-
- IF (0.GE.nsop) RETURN
-
- ! double-quote character
- q=char(34)
-
- DO k=1,nsop
- WRITE (digit4,'(I4.4)') k
- file=trim(wdir)//"/cfaults-sigma-"//digit4//".txt"
-
- ! fault center position
- x1=sop(k)%x
- x2=sop(k)%y
- x3=sop(k)%z
-
- IF (isnew) THEN
- OPEN (UNIT=15,FILE=file,IOSTAT=iostatus,FORM="FORMATTED")
- WRITE (15,'("# center position (north, east, down): ",3ES9.2)') x1,x2,x3
- WRITE (15,'("# t s11 s12 s13 ", &
- "s22 s23 s33 taus taud tau taun Coulomb")')
- ELSE
- OPEN (UNIT=15,FILE=file,POSITION="APPEND",&
- IOSTAT=iostatus,FORM="FORMATTED")
- END IF
- IF (iostatus>0) STOP "could not open point file for writing"
-
- ! friction coefficient
- friction=sop(k)%friction
-
- ! fault orientation
- strike=sop(k)%strike
- dip=sop(k)%dip
-
- CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
- lsig=sig(i1,i2,i3)
-
- ! fault dimension
- W=sop(k)%width
- L=sop(k)%length
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! surface normal vector components
- n(1)=+cdip*cstrike
- n(2)=-cdip*sstrike
- n(3)=-sdip
-
- ! strike-slip unit direction
- s(1)=sstrike
- s(2)=cstrike
- s(3)=0._8
-
- ! dip-slip unit direction
- d(1)=+cstrike*sdip
- d(2)=-sstrike*sdip
- d(3)=+cdip
-
- ! traction vector
- t=lsig .tdot. n
-
- ! signed normal component
- taun=SUM(t*n)
-
- ! shear traction
- ts=t-taun*n
-
- ! absolute value of shear component
- taus=SQRT(SUM(ts*ts))
-
- ! strike-direction shear component
- taustrike=SUM(ts*s)
-
- ! dip-direction shear component
- taudip=SUM(ts*d)
-
- ! Coulomb stress
- taucoulomb=taus+friction*taun
-
- WRITE (15,'(12ES11.3E2)') time, &
- lsig%s11,lsig%s12,lsig%s13, &
- lsig%s22,lsig%s23,lsig%s33, &
- taustrike,taudip,taus,taun,taucoulomb
- CLOSE(15)
- END DO
-
- END SUBROUTINE exportcoulombstress
-
- !------------------------------------------------------------------
- !> subroutine ExportVTK_Rectangle
- !! creates a .vtp file (in the VTK PolyData XML format) containing
- !! a rectangle.
- !!
- !! \author sylvain barbot 06/24/09 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportvtk_rectangle(x1,x2,x3,L,W,strike,dip,filename)
- REAL*8 :: x1,x2,x3,L,W,strike,dip
- CHARACTER(80), INTENT(IN) :: filename
-
- INTEGER :: iostatus
- CHARACTER :: q
-
- REAL*8 :: cstrike,sstrike,cdip,sdip
- REAL*8, DIMENSION(3) :: s,d
-
- ! double-quote character
- q=char(34)
-
- OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', filename
- STOP "could not open file for export in ExportVTK_Rectangle"
- END IF
-
- WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
- WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
- WRITE (15,'(" <PolyData>")')
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! strike-slip unit direction
- s(1)=sstrike
- s(2)=cstrike
- s(3)=0._8
-
- ! dip-slip unit direction
- d(1)=+cstrike*sdip
- d(2)=-sstrike*sdip
- d(3)=+cdip
-
- WRITE (15,'(" <Piece NumberOfPoints=",a,"4",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
- WRITE (15,'(" <Points>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Fault Patch",a, &
- " NumberOfComponents=",a,"3",a, &
- " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
-
- ! fault edge coordinates
- WRITE (15,'(12ES11.2)') &
- x1-d(1)*W/2-s(1)*L/2,x2-d(2)*W/2-s(2)*L/2,x3-d(3)*W/2-s(3)*L/2, &
- x1-d(1)*W/2+s(1)*L/2,x2-d(2)*W/2+s(2)*L/2,x3-d(3)*W/2+s(3)*L/2, &
- x1+d(1)*W/2+s(1)*L/2,x2+d(2)*W/2+s(2)*L/2,x3+d(3)*W/2+s(3)*L/2, &
- x1+d(1)*W/2-s(1)*L/2,x2+d(2)*W/2-s(2)*L/2,x3+d(3)*W/2-s(3)*L/2
-
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Points>")')
- WRITE (15,'(" <Polys>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"connectivity",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"0",a, &
- " RangeMax=",a,"3",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'("0 1 2 3")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"offsets",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"4",a, &
- " RangeMax=",a,"4",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'(" 4")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Polys>")')
-
- WRITE (15,'(" </Piece>")')
-
- WRITE (15,'(" </PolyData>")')
- WRITE (15,'("</VTKFile>")')
-
- CLOSE(15)
-
- END SUBROUTINE exportvtk_rectangle
-
- !------------------------------------------------------------------
- !> subroutine ExportXY_Brick
- !! creates a .xy file containing a brick (3d rectangle, cuboid).
- !!
- !! \author sylvain barbot 11/29/11 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportxy_brick(x1,x2,x3,L,W,T,strike,dip,filename)
- REAL*8 :: x1,x2,x3,L,W,T,strike,dip
- CHARACTER(80), INTENT(IN) :: filename
-
- INTEGER :: iostatus
-
- REAL*8 :: cstrike,sstrike,cdip,sdip
- REAL*8, DIMENSION(3) :: s,d,n
-
- OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', filename
- STOP "could not open file for export in ExportXY_Brick"
- END IF
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! strike-slip unit direction
- s(1)=sstrike
- s(2)=cstrike
- s(3)=0._8
-
- ! dip-slip unit direction
- d(1)=+cstrike*sdip
- d(2)=-sstrike*sdip
- d(3)=+cdip
-
- ! surface normal vector components
- n(1)=+cdip*cstrike
- n(2)=-cdip*sstrike
- n(3)=-sdip
-
- ! fault edge coordinates
- WRITE (15,'(">")')
- WRITE (15,'(3ES11.2)') x2-d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x1-d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x3-d(3)*W/2-s(3)*L/2-n(3)*T/2.d0
- WRITE (15,'(3ES11.2)') x2-d(2)*W/2+s(2)*L/2-n(2)*T/2.d0, x1-d(1)*W/2+s(1)*L/2-n(1)*T/2.d0, x3-d(3)*W/2+s(3)*L/2-n(3)*T/2.d0
- WRITE (15,'(3ES11.2)') x2-d(2)*W/2+s(2)*L/2+n(2)*T/2.d0, x1-d(1)*W/2+s(1)*L/2+n(1)*T/2.d0, x3-d(3)*W/2+s(3)*L/2+n(3)*T/2.d0
- WRITE (15,'(3ES11.2)') x2-d(2)*W/2-s(2)*L/2+n(2)*T/2.d0, x1-d(1)*W/2-s(1)*L/2+n(1)*T/2.d0, x3-d(3)*W/2-s(3)*L/2+n(3)*T/2.d0
- WRITE (15,'(3ES11.2)') x2-d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x1-d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x3-d(3)*W/2-s(3)*L/2-n(3)*T/2.d0
- WRITE (15,'(">")')
- WRITE (15,'(3ES11.2)') x2+d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x1+d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x3+d(3)*W/2-s(3)*L/2-n(3)*T/2.d0
- WRITE (15,'(3ES11.2)') x2+d(2)*W/2+s(2)*L/2-n(2)*T/2.d0, x1+d(1)*W/2+s(1)*L/2-n(1)*T/2.d0, x3+d(3)*W/2+s(3)*L/2-n(3)*T/2.d0
- WRITE (15,'(3ES11.2)') x2+d(2)*W/2+s(2)*L/2+n(2)*T/2.d0, x1+d(1)*W/2+s(1)*L/2+n(1)*T/2.d0, x3+d(3)*W/2+s(3)*L/2+n(3)*T/2.d0
- WRITE (15,'(3ES11.2)') x2+d(2)*W/2-s(2)*L/2+n(2)*T/2.d0, x1+d(1)*W/2-s(1)*L/2+n(1)*T/2.d0, x3+d(3)*W/2-s(3)*L/2+n(3)*T/2.d0
- WRITE (15,'(3ES11.2)') x2+d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x1+d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x3+d(3)*W/2-s(3)*L/2-n(3)*T/2.d0
-
- CLOSE(15)
-
- END SUBROUTINE exportxy_brick
-
- !------------------------------------------------------------------
- !> subroutine ExportVTK_Brick
- !! creates a .vtp file (in the VTK PolyData XML format) containing
- !! a brick (3d rectangle, cuboid).
- !!
- !! \author sylvain barbot 06/24/09 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportvtk_brick(x1,x2,x3,L,W,T,strike,dip,filename)
- REAL*8 :: x1,x2,x3,L,W,T,strike,dip
- CHARACTER(80), INTENT(IN) :: filename
-
- INTEGER :: iostatus
- CHARACTER :: q
-
- REAL*8 :: cstrike,sstrike,cdip,sdip
- REAL*8, DIMENSION(3) :: s,d,n
-
- ! double-quote character
- q=char(34)
-
- OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', filename
- STOP "could not open file for export in ExportVTK_Brick"
- END IF
-
- WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
- WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
- WRITE (15,'(" <PolyData>")')
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! strike-slip unit direction
- s(1)=sstrike
- s(2)=cstrike
- s(3)=0._8
-
- ! dip-slip unit direction
- d(1)=+cstrike*sdip
- d(2)=-sstrike*sdip
- d(3)=+cdip
-
- ! surface normal vector components
- n(1)=+cdip*cstrike
- n(2)=-cdip*sstrike
- n(3)=-sdip
-
- WRITE (15,'(" <Piece NumberOfPoints=",a,"8",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
- WRITE (15,'(" <Points>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Weak Zone",a, &
- " NumberOfComponents=",a,"3",a, &
- " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
-
- ! fault edge coordinates
- WRITE (15,'(24ES11.2)') &
- x1-d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x2-d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x3-d(3)*W/2-s(3)*L/2-n(3)*T/2.d0, &
- x1-d(1)*W/2+s(1)*L/2-n(1)*T/2.d0, x2-d(2)*W/2+s(2)*L/2-n(2)*T/2.d0, x3-d(3)*W/2+s(3)*L/2-n(3)*T/2.d0, &
- x1+d(1)*W/2+s(1)*L/2-n(1)*T/2.d0, x2+d(2)*W/2+s(2)*L/2-n(2)*T/2.d0, x3+d(3)*W/2+s(3)*L/2-n(3)*T/2.d0, &
- x1+d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x2+d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x3+d(3)*W/2-s(3)*L/2-n(3)*T/2.d0, &
- x1+d(1)*W/2-s(1)*L/2+n(1)*T/2.d0, x2+d(2)*W/2-s(2)*L/2+n(2)*T/2.d0, x3+d(3)*W/2-s(3)*L/2+n(3)*T/2.d0, &
- x1-d(1)*W/2-s(1)*L/2+n(1)*T/2.d0, x2-d(2)*W/2-s(2)*L/2+n(2)*T/2.d0, x3-d(3)*W/2-s(3)*L/2+n(3)*T/2.d0, &
- x1-d(1)*W/2+s(1)*L/2+n(1)*T/2.d0, x2-d(2)*W/2+s(2)*L/2+n(2)*T/2.d0, x3-d(3)*W/2+s(3)*L/2+n(3)*T/2.d0, &
- x1+d(1)*W/2+s(1)*L/2+n(1)*T/2.d0, x2+d(2)*W/2+s(2)*L/2+n(2)*T/2.d0, x3+d(3)*W/2+s(3)*L/2+n(3)*T/2.d0
-
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Points>")')
- WRITE (15,'(" <Polys>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"connectivity",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"0",a, &
- " RangeMax=",a,"6",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'("7 4 5 6 7 4 3 2 7 2 1 6")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"offsets",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"12",a, &
- " RangeMax=",a,"12",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'(" 12")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Polys>")')
- WRITE (15,'(" </Piece>")')
-
- WRITE (15,'(" <Piece NumberOfPoints=",a,"8",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
- WRITE (15,'(" <Points>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Weak Zone",a, &
- " NumberOfComponents=",a,"3",a, &
- " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
-
- ! fault edge coordinates
- WRITE (15,'(24ES11.2)') &
- x1-d(1)*W/2.d0-s(1)*L/2.d0-n(1)*T/2.d0, x2-d(2)*W/2.d0-s(2)*L/2.d0-n(2)*T/2.d0,x3-d(3)*W/2-s(3)*L/2-n(3)*T/2.d0, &
- x1-d(1)*W/2.d0+s(1)*L/2.d0-n(1)*T/2.d0, x2-d(2)*W/2.d0+s(2)*L/2.d0-n(2)*T/2.d0,x3-d(3)*W/2+s(3)*L/2-n(3)*T/2.d0, &
- x1+d(1)*W/2.d0+s(1)*L/2.d0-n(1)*T/2.d0, x2+d(2)*W/2.d0+s(2)*L/2.d0-n(2)*T/2.d0,x3+d(3)*W/2+s(3)*L/2-n(3)*T/2.d0, &
- x1+d(1)*W/2.d0-s(1)*L/2.d0-n(1)*T/2.d0, x2+d(2)*W/2.d0-s(2)*L/2.d0-n(2)*T/2.d0,x3+d(3)*W/2-s(3)*L/2-n(3)*T/2.d0, &
- x1+d(1)*W/2.d0-s(1)*L/2.d0+n(1)*T/2.d0, x2+d(2)*W/2.d0-s(2)*L/2.d0+n(2)*T/2.d0,x3+d(3)*W/2-s(3)*L/2+n(3)*T/2.d0, &
- x1-d(1)*W/2.d0-s(1)*L/2.d0+n(1)*T/2.d0, x2-d(2)*W/2.d0-s(2)*L/2.d0+n(2)*T/2.d0,x3-d(3)*W/2-s(3)*L/2+n(3)*T/2.d0, &
- x1-d(1)*W/2.d0+s(1)*L/2.d0+n(1)*T/2.d0, x2-d(2)*W/2.d0+s(2)*L/2.d0+n(2)*T/2.d0,x3-d(3)*W/2+s(3)*L/2+n(3)*T/2.d0, &
- x1+d(1)*W/2.d0+s(1)*L/2.d0+n(1)*T/2.d0, x2+d(2)*W/2.d0+s(2)*L/2.d0+n(2)*T/2.d0,x3+d(3)*W/2+s(3)*L/2+n(3)*T/2.d0
-
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Points>")')
- WRITE (15,'(" <Polys>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"connectivity",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"0",a, &
- " RangeMax=",a,"7",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'("0 1 2 3 0 5 4 3 0 1 6 5")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Int32",a, &
- " Name=",a,"offsets",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,"12",a, &
- " RangeMax=",a,"12",a,">")'), q,q,q,q,q,q,q,q,q,q
- WRITE (15,'(" 12")')
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" </Polys>")')
- WRITE (15,'(" </Piece>")')
- WRITE (15,'(" </PolyData>")')
- WRITE (15,'("</VTKFile>")')
-
- CLOSE(15)
-
- END SUBROUTINE exportvtk_brick
-
- !------------------------------------------------------------------
- !> subroutine ExportVTK_Vectors
- !! creates a .vtr file (in the VTK Rectilinear XML format)
- !! containing a vector field.
- !!
- !! \author sylvain barbot 06/25/09 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportvtk_vectors(u1,u2,u3,sx1,sx2,sx3,dx1,dx2,dx3,j1,j2,j3,vcfilename)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,j1,j2,j3
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: u1,u2,u3
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: u1,u2,u3
-#endif
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- CHARACTER(80), INTENT(IN) :: vcfilename
-
- INTEGER :: iostatus,idum,i1,i2,i3
- CHARACTER :: q
- INTEGER :: k1,k2,k3
- REAL*8 :: x1,x2,x3
-
- ! double-quote character
- q=char(34)
-
- OPEN (UNIT=15,FILE=vcfilename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', vcfilename
- STOP "could not open file for export"
- END IF
-
- WRITE (15,'("<?xml version=",a,"0.1",a,"?>")') q,q
- WRITE (15,'("<VTKFile type=",a,"RectilinearGrid",a," version=",a,"0.1",a,">")') q,q,q,q
- WRITE (15,'(" <RectilinearGrid WholeExtent=",a,6I5.4,a,">")') q,1,sx1/j1,1,sx2/j2,1,sx3/j3,q
- WRITE (15,'(" <Piece Extent=",a,6I5.4,a,">")') q,1,sx1/j1,1,sx2/j2,1,sx3/j3,q
- WRITE (15,'(" <PointData Scalars=",a,"Vector Field",a,">")') q,q
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"X Velocity",a, &
- " format=",a,"ascii",a,">")') q,q,q,q,q,q
-
- ! write first component values
- DO k3=0,sx3-1,j3
- x3=REAL(k3,8)
- DO k2=-sx2/2,sx2/2-1,j2
- x2=REAL(k2,8)
- DO k1=-sx1/2,sx1/2-1,j1
- x1=REAL(k1,8)
-
- CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
- WRITE (15,'(ES12.2)') u1(i1,i2,k3+1)
- END DO
- END DO
- END DO
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Y Velocity",a, &
- " format=",a,"ascii",a,">")') q,q,q,q,q,q
-
- ! write second component values
- DO k3=0,sx3-1,j3
- x3=REAL(k3,8)
- DO k2=-sx2/2,sx2/2-1,j2
- x2=REAL(k2,8)
- DO k1=-sx1/2,sx1/2-1,j1
- x1=REAL(k1,8)
-
- CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
- WRITE (15,'(ES12.2)') u2(i1,i2,k3+1)
-
- END DO
- END DO
- END DO
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Z Velocity",a, &
- " format=",a,"ascii",a,">")') q,q,q,q,q,q
-
- ! write third component values
- DO k3=0,sx3-1,j3
- x3=REAL(k3,8)
- DO k2=-sx2/2,sx2/2-1,j2
- x2=REAL(k2,8)
- DO k1=-sx1/2,sx1/2-1,j1
- x1=REAL(k1,8)
-
- CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
- WRITE (15,'(ES12.2)') u3(i1,i2,k3+1)
-
- END DO
- END DO
- END DO
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" </PointData>")')
-
- WRITE (15,'(" <Coordinates>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Array 1",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,ES12.2,a, &
- " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,-sx1/2*dx1,q,q,(sx1/2-1)*dx1,q
- DO k1=-sx1/2,sx1/2-1,j1
- x1=REAL(k1,8)
- WRITE (15,'(ES12.2)') x1*dx1
- END DO
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Array 2",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,ES12.2,a, &
- " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,-sx2/2*dx2,q,q,(sx2/2-1)*dx2,q
- DO k2=-sx2/2,sx2/2-1,j2
- x2=REAL(k2,8)
- WRITE (15,'(ES12.2)') x2*dx2
- END DO
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Array 3",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,ES12.2,a, &
- " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,0,q,q,(sx3-1)*dx3,q
- DO k3=0,sx3-1,j3
- x3=REAL(k3,8)
- WRITE (15,'(ES12.2)') x3*dx3
- END DO
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" </Coordinates>")')
- WRITE (15,'("</Piece>")')
- WRITE (15,'("</RectilinearGrid>")')
- WRITE (15,'("</VTKFile>")')
-
- CLOSE(15)
-
- END SUBROUTINE exportvtk_vectors
-
- !------------------------------------------------------------------
- !> subroutine ExportVTK_Vectors_Slice
- !! creates a .vtr file (in the VTK Rectilinear XML format)
- !! containing a vector field.
- !!
- !! \author sylvain barbot 06/25/09 - original form
- !------------------------------------------------------------------
- SUBROUTINE exportvtk_vectors_slice(u1,u2,u3,sx1,sx2,sx3,dx1,dx2,dx3,oz,j1,j2,vcfilename)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,j1,j2
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: u1,u2,u3
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: u1,u2,u3
-#endif
- REAL*8, INTENT(IN) :: dx1,dx2,dx3,oz
- CHARACTER(80), INTENT(IN) :: vcfilename
-
- INTEGER :: iostatus,idum,i1,i2
- CHARACTER :: q
- INTEGER :: k1,k2,k3
- REAL*8 :: x1,x2,x3
-
- ! double-quote character
- q=char(34)
-
- OPEN (UNIT=15,FILE=vcfilename,IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- PRINT '(a)', vcfilename
- STOP "could not open file for export"
- END IF
-
- WRITE (15,'("<?xml version=",a,"0.1",a,"?>")') q,q
- WRITE (15,'("<VTKFile type=",a,"RectilinearGrid",a," version=",a,"0.1",a,">")') q,q,q,q
- WRITE (15,'(" <RectilinearGrid WholeExtent=",a,6I5.4,a,">")') q,1,sx1/j1,1,sx2/j2,1,1,q
- WRITE (15,'(" <Piece Extent=",a,6I5.4,a,">")') q,1,sx1/j1,1,sx2/j2,1,1,q
- WRITE (15,'(" <PointData Scalars=",a,"Vector Field",a,">")') q,q
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"X Velocity",a, &
- " format=",a,"ascii",a,">")') q,q,q,q,q,q
-
- ! write first component values
- x3=oz/dx3
- DO k2=-sx2/2,sx2/2-1,j2
- x2=REAL(k2,8)
- DO k1=-sx1/2,sx1/2-1,j1
- x1=REAL(k1,8)
-
- CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
- WRITE (15,'(ES12.2)') u1(i1,i2,k3+1)
- END DO
- END DO
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Y Velocity",a, &
- " format=",a,"ascii",a,">")') q,q,q,q,q,q
-
- ! write second component values
- x3=oz/dx3
- DO k2=-sx2/2,sx2/2-1,j2
- x2=REAL(k2,8)
- DO k1=-sx1/2,sx1/2-1,j1
- x1=REAL(k1,8)
-
- CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
- WRITE (15,'(ES12.2)') u2(i1,i2,k3+1)
-
- END DO
- END DO
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Z Velocity",a, &
- " format=",a,"ascii",a,">")') q,q,q,q,q,q
-
- ! write third component values
- x3=oz/dx3
- DO k2=-sx2/2,sx2/2-1,j2
- x2=REAL(k2,8)
- DO k1=-sx1/2,sx1/2-1,j1
- x1=REAL(k1,8)
-
- CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
- WRITE (15,'(ES12.2)') u3(i1,i2,k3+1)
-
- END DO
- END DO
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" </PointData>")')
-
- WRITE (15,'(" <Coordinates>")')
-
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Array 1",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,ES12.2,a, &
- " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,-sx1/2*dx1,q,q,(sx1/2-1)*dx1,q
- DO k1=-sx1/2,sx1/2-1,j1
- x1=REAL(k1,8)
- WRITE (15,'(ES12.2)') x1*dx1
- END DO
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Array 2",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,ES12.2,a, &
- " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,-sx2/2*dx1,q,q,(sx2/2-1)*dx2,q
- DO k2=-sx2/2,sx2/2-1,j2
- x2=REAL(k2,8)
- WRITE (15,'(ES12.2)') x2*dx2
- END DO
- WRITE (15,'(" </DataArray>")')
- WRITE (15,'(" <DataArray type=",a,"Float32",a, &
- " Name=",a,"Array 3",a, &
- " format=",a,"ascii",a, &
- " RangeMin=",a,ES12.2,a, &
- " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,oz,q,q,oz,q
- WRITE (15,'(2ES12.2)') oz
- WRITE (15,'(" </DataArray>")')
-
- WRITE (15,'(" </Coordinates>")')
- WRITE (15,'("</Piece>")')
- WRITE (15,'("</RectilinearGrid>")')
- WRITE (15,'("</VTKFile>")')
-
- CLOSE(15)
-
- END SUBROUTINE exportvtk_vectors_slice
-#endif
-
-END MODULE export
diff -r 405d8f4fa05f -r e7295294f654 fourier.f90
--- a/fourier.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,631 +0,0 @@
-!-----------------------------------------------------------------------
-! Copyright 2007, 2008, 2009 Sylvain Barbot
-!
-! This file is part of RELAX
-!
-! RELAX 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 3 of the License, or
-! (at your option) any later version.
-!
-! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
-!-----------------------------------------------------------------------
-
-#include "include.f90"
-
-MODULE fourier
-
-#ifdef IMKL_FFT
- USE MKL_DFTI
-#endif
-
- IMPLICIT NONE
-
- PUBLIC
-
-#ifdef FFTW3
- INCLUDE 'fftw3.f'
-#endif
-
- INTEGER, PARAMETER :: FFT_FORWARD=-1,FFT_INVERSE=1
-
-CONTAINS
-
- !---------------------------------------------------------------------
- !> subroutine wavenumbers
- !! computes the values of the wavenumbers
- !! in the sequential order required when using subroutine FOURT
- !! to perform forward and backward inverse transforms.
- !!
- !! INPUT
- !! @param i1 running index in the discrete Fourier domain array
- !! @param i2 running index in the discrete Fourier domain array
- !! @param i3 running index in the discrete Fourier domain array
- !! @param sx1 number of elements in the x1-direction
- !! @param sx2 number of elements in the x2-direction
- !! @param sx3 number of elements in the x3-direction
- !! @param dx1 sampling interval in the x1-direction
- !! @param dx2 sampling interval in the x2-direction
- !! @param dx3 sampling interval in the x3-direction
- !!
- !! OUTPUT
- !! @param k1 wavenumber in the x1 direction
- !! @param k2 wavenumber in the x2 direction
- !! @param k3 wavenumber in the x3 direction
- !!
- !! \author sylvain barbot (04-14-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE wavenumbers(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,k1,k2,k3)
- INTEGER, INTENT(IN) :: i1, i2, i3, sx1, sx2, sx3
- REAL*8, INTENT(IN) :: dx1, dx2, dx3
- REAL*8, INTENT(OUT) :: k1, k2, k3
-
- IF (i3 < sx3/2+1) THEN
- k3= (DBLE(i3)-1._8)/(sx3*dx3)
- ELSE
- k3=-(DBLE(sx3-i3)+1._8)/(sx3*dx3)
- END IF
- IF (i2 < sx2/2+1) THEN
- k2= (DBLE(i2)-1._8)/(sx2*dx2)
- ELSE
- k2=-(DBLE(sx2-i2)+1._8)/(sx2*dx2)
- END IF
- k1=(DBLE(i1)-1._8)/(sx1*dx1)
-
- END SUBROUTINE wavenumbers
-
- SUBROUTINE wavenumber1(i1,sx1,dx1,k1)
- INTEGER, INTENT(IN) :: i1,sx1
- REAL*8, INTENT(IN) :: dx1
- REAL*8, INTENT(OUT) :: k1
-
- k1=(DBLE(i1)-1._8)/(sx1*dx1)
- END SUBROUTINE wavenumber1
-
- SUBROUTINE wavenumber2(i2,sx2,dx2,k2)
- INTEGER, INTENT(IN) :: i2,sx2
- REAL*8, INTENT(IN) :: dx2
- REAL*8, INTENT(OUT) :: k2
-
- IF (i2 < sx2/2+1) THEN
- k2= (DBLE(i2)-1._8)/(sx2*dx2)
- ELSE
- k2=-(DBLE(sx2-i2)+1._8)/(sx2*dx2)
- END IF
- END SUBROUTINE wavenumber2
-
- SUBROUTINE wavenumber3(i3,sx3,dx3,k3)
- INTEGER, INTENT(IN) :: i3,sx3
- REAL*8, INTENT(IN) :: dx3
- REAL*8, INTENT(OUT) :: k3
-
- IF (i3 < sx3/2+1) THEN
- k3= (DBLE(i3)-1._8)/(sx3*dx3)
- ELSE
- k3=-(DBLE(sx3-i3)+1._8)/(sx3*dx3)
- END IF
- END SUBROUTINE wavenumber3
-
- !---------------------------------------------------------------------
- ! subroutine FFTshift_TF applies the transfer function
- ! in the Fourier domain corresponding to shifting the space
- ! domain array by sx1*dx1/2 in the 1-direction and sx3*dx3/2
- ! in the 3-direction.
- !
- ! fftshift_tf follows the data storage convention in
- ! agreement with DFT subroutine FOURT
- !
- ! sylvain barbot (05-01-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE fftshift_tf(spec)
- REAL*4, INTENT(INOUT), DIMENSION(:,:,:) :: spec
-
- INTEGER :: sx1, sx2, sx3, i1, i2, i3
- REAL*4 :: exp1, exp2, exp3
-
- sx1=SIZE(spec, 1)-2
- sx2=SIZE(spec, 2)
- sx3=SIZE(spec, 3)
-
- DO i3=1,sx3
- IF (i3 < sx3/2+1) THEN
- exp3=-(DBLE(i3)-1._8)
- ELSE
- exp3= (DBLE(sx3-i3)+1._8)
- END IF
- DO i2=1,sx2
- IF (i2 < sx2/2+1) THEN
- exp2=-(DBLE(i2)-1._8)
- ELSE
- exp2= (DBLE(sx2-i2)+1._8)
- END IF
- DO i1=1,sx1/2+1
- exp1=(DBLE(i1)-1._8)
- spec(2*i1-1:2*i1,i2,i3) = &
- spec(2*i1-1:2*i1,i2,i3)*((-1._4)**(exp1+exp2+exp3))
- END DO
- END DO
- END DO
- END SUBROUTINE fftshift_tf
-
- !----------------------------------------------------------------------
- !> subroutine FFT3 performs normalized forward and
- !! inverse fourier transforms of real 3d data
- !
- !! USES
- !! ctfft (Brenner, 1968) by default
- !! fftw3 (Frigo & Jonhson) with preproc FFTW3 flag
- !! scfft (SGI library) with preproc SGI_FFT flag
- !! ctfft (Cooley-Tuckey) by default (slowest FFT)
- !!
- !! for real array the fourier transform returns a sx1/2+1 complex array
- !! and the enough space must be reserved
- !----------------------------------------------------------------------
-#ifdef FFTW3
- !--------------------------------------------------------
- ! implementation of FFTW3
- ! must be linked with -lfftw3f (single-threaded version)
- !
- ! sylvain barbot (09-28-08) - original form
- !--------------------------------------------------------
- SUBROUTINE fft3(data,sx1,sx2,sx3,dx1,dx2,dx3,direction)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,direction
- REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
-
- INTEGER*8 :: plan
-
- IF (FFT_FORWARD == direction) THEN
- CALL sfftw_plan_dft_r2c_3d(plan,sx1,sx2,sx3, &
- data(1,1,1),data(1,1,1),FFTW_ESTIMATE)
- ELSE
- CALL sfftw_plan_dft_c2r_3d(plan,sx1,sx2,sx3, &
- data(1,1,1),data(1,1,1),FFTW_ESTIMATE)
- END IF
-
- CALL sfftw_execute(plan)
- CALL sfftw_destroy_plan(plan)
-
- IF (FFT_INVERSE == direction) THEN
- data=data/(sx1*dx1*sx2*dx2*sx3*dx3)
- ELSE
- data=data*(dx1*dx2*dx3)
- END IF
-
- END SUBROUTINE fft3
-#else
-#ifdef SGI_FFT
- !--------------------------------------------------------------------
- ! implementation of SGI SCFFT
- ! must be linked with -L/usr/lib -lscs or -L/usr/lib -lscs_mp for
- ! multithread version expect up x8 performance increase compared to
- ! ctfft implementation. check out the SGI documentation at:
- !
- ! http://techpubs.sgi.com/library/tpl/cgi-bin/getdoc.cgi?coll=linux&
- ! db=man&fname=/usr/share/catman/man3/ccfft.3s.html&srch=ccfft
- !
- ! sylvain barbot (09-28-08) - original form
- !--------------------------------------------------------------------
- SUBROUTINE fft3(data,sx1,sx2,sx3,dx1,dx2,dx3,direction)
- INTEGER, INTENT(IN) :: direction,sx1,sx2,sx3
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
-
- INTEGER, PARAMETER :: NF=256, NFR=256
-
- REAL*4, DIMENSION(sx1+NFR+(2*sx2+NF)+(2*sx3+NF)) :: table
- REAL*4, DIMENSION(sx1+4*sx3) :: work
- INTEGER, DIMENSION(2) :: isys
- REAL*4 :: scale
-
- isys(1)=1
-
- IF (FFT_FORWARD == direction) THEN
- scale=dx1*dx2*dx3
- ! initialize the sin/cos table
- CALL SCFFT3D(+0,sx1,sx2,sx3,scale,data(1,1,1),sx1+2,sx2, &
- data(1,1,1),sx1/2+1,sx2,table,work,isys)
- CALL SCFFT3D(-1,sx1,sx2,sx3,scale,data(1,1,1),sx1+2,sx2, &
- data(1,1,1),sx1/2+1,sx2,table,work,isys)
- ELSE
- scale=1._4/(sx1*dx1*sx2*dx2*sx3*dx3)
- ! initialize the sin/cos table
- CALL CSFFT3D(+0,sx1,sx2,sx3,scale,data(1,1,1),sx1/2+1,sx2, &
- data(1,1,1),sx1+2,sx2,table,work,isys)
- CALL CSFFT3D(+1,sx1,sx2,sx3,scale,data(1,1,1),sx1/2+1,sx2, &
- data(1,1,1),sx1+2,sx2,table,work,isys)
- END IF
-
- END SUBROUTINE fft3
-#else
-#ifdef IMKL_FFT
- !-------------------------------------------------------------------------
- ! implementation IMKL_FFT (Intel Math Kernel Library)
- ! for information and example calculations with the
- ! mkl FFT, see:
- !
- ! http://www.intel.com/software/products/mkl/docs/webhelp/appendices/ ...
- ! mkl_appC_DFT.html#appC-exC-25
- !
- ! and a thread (Fortran 3-D FFT real-to-complex ...)
- ! on the intel forum
- !
- ! http://software.intel.com/en-us/forums/intel-math-kernel-library/
- !
- ! sylvain barbot (04-30-10) - original form
- !-------------------------------------------------------------------------
- SUBROUTINE fft3(data,sx1,sx2,sx3,dx1,dx2,dx3,direction)
- REAL*4, DIMENSION(0:*), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,direction
-
- INTEGER :: iret,size(3),rstrides(4),cstrides(4)
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL*4 :: scale
-
- rstrides=(/ 0,1,(sx1/2+1)*2,(sx1/2+1)*2*sx2 /)
- cstrides=(/ 0,1,sx1/2+1,(sx1/2+1)*sx2 /)
- size=(/ sx1,sx2,sx3 /)
-
- iret=DftiCreateDescriptor(desc,DFTI_SINGLE,DFTI_REAL,3,size)
- iret=DftiSetValue(desc,DFTI_CONJUGATE_EVEN_STORAGE,DFTI_COMPLEX_COMPLEX)
-
- IF(iret.NE.0) THEN
- IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
- WRITE_DEBUG_INFO
- WRITE (0,*) DftiErrorMessage(iret)
- STOP 1
- END IF
- END IF
-
- IF (FFT_FORWARD == direction) THEN
- scale=dx1*dx2*dx3
- iret=DftiSetValue(desc,DFTI_FORWARD_SCALE,scale)
- iret=DftiSetValue(desc,DFTI_INPUT_STRIDES,rstrides);
- iret=DftiSetValue(desc,DFTI_OUTPUT_STRIDES,cstrides);
- iret=DftiCommitDescriptor(desc)
- iret=DftiComputeForward(desc,data)
- ELSE
- scale=1._4/(sx1*dx1*sx2*dx2*sx3*dx3)
- iret=DftiSetValue(desc,DFTI_BACKWARD_SCALE,scale)
- iret=DftiSetValue(desc,DFTI_INPUT_STRIDES,cstrides);
- iret=DftiSetValue(desc,DFTI_OUTPUT_STRIDES,rstrides);
- iret=DftiCommitDescriptor(desc)
- iret=DftiComputeBackward(desc,data)
- END IF
- iret=DftiFreeDescriptor(desc)
- IF(iret.NE.0) THEN
- IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
- WRITE_DEBUG_INFO
- WRITE (0,*) DftiErrorMessage(iret)
- STOP 1
- END IF
- END IF
-
- END SUBROUTINE fft3
-#else
- !------------------------------------------------------
- ! implementation of ctfft (N. Brenner, 1968)
- ! must be linked with ctfft.o
- !------------------------------------------------------
- SUBROUTINE fft3(data,sx1,sx2,sx3,dx1,dx2,dx3,direction)
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- INTEGER, INTENT(IN) :: sx1,sx2,sx3,direction
-
- INTEGER :: dim(3)
- INTEGER :: FOURT_DS ! data storage
- INTEGER, PARAMETER :: FOURT_NW = 128 ! extra work space size
- REAL*4, DIMENSION(FOURT_NW) :: FOURT_WORK ! extra work space
-
- dim=(/ sx1,sx2,sx3 /)
-
- IF (FFT_FORWARD == direction) THEN
- FOURT_DS=0
- ELSE
- FOURT_DS=-1
- END IF
- CALL ctfft(data,dim,3,direction,FOURT_DS,FOURT_WORK,FOURT_NW)
-
- IF (FFT_INVERSE == direction) THEN
- data=data/(sx1*dx1*sx2*dx2*sx3*dx3)
- ELSE
- data=data*(dx1*dx2*dx3)
- END IF
-
- END SUBROUTINE fft3
-#endif
-#endif
-#endif
- !----------------------------------------------------------------------
- !> subroutine FFT2 performs normalized forward and
- !! inverse fourier transforms of real 2d data
- !!
- !! USES subroutine FOURT
- !! ctfft(data,n,ndim,isign,iform,work,nwork)
- !! or
- !! fftw3
- !!
- !! for real array the fourier transform returns a sx1/2+1 complex array
- !! and the enough space must be reserved
- !----------------------------------------------------------------------
-#ifdef FFTW3
- SUBROUTINE fft2(data,sx1,sx2,dx1,dx2,direction)
- INTEGER, INTENT(IN) :: sx1,sx2,direction
- REAL*4, DIMENSION(sx1+2,sx2), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx1,dx2
-
- INTEGER*8 :: plan
-
- IF (FFT_FORWARD == direction) THEN
- CALL sfftw_plan_dft_r2c_2d(plan,sx1,sx2, &
- data(1,1),data(1,1),FFTW_ESTIMATE)
- ELSE
- CALL sfftw_plan_dft_c2r_2d(plan,sx1,sx2, &
- data(1,1),data(1,1),FFTW_ESTIMATE)
- END IF
-
- CALL sfftw_execute(plan)
- CALL sfftw_destroy_plan(plan)
-
- IF (FFT_INVERSE == direction) THEN
- data=data/(sx1*dx1*sx2*dx2)
- ELSE
- data=data*(dx1*dx2)
- END IF
-
- END SUBROUTINE fft2
-#else
-#ifdef SGI_FFT
- SUBROUTINE fft2(data,sx1,sx2,dx1,dx2,direction)
- REAL*4, DIMENSION(:,:), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx1,dx2
- INTEGER, INTENT(IN) :: sx1,sx2,direction
-
- INTEGER, PARAMETER :: NF=256, NFR=256
-
- REAL*4, DIMENSION(sx1+NFR+2*sx2+NF) :: table
- REAL*4, DIMENSION(sx1+4*sx2) :: work
- INTEGER, DIMENSION(2) :: isys
- REAL*4 :: scale
-
- isys(1)=1
-
- IF (FFT_FORWARD == direction) THEN
- scale=dx1*dx2
- ! initialize the sin/cos table
- CALL SCFFT2D(+0,sx1,sx2,scale,data(1,1),sx1+2, &
- data(1,1),sx1/2+1,table,work,isys)
- CALL SCFFT2D(-1,sx1,sx2,scale,data(1,1),sx1+2, &
- data(1,1),sx1/2+1,table,work,isys)
- ELSE
- scale=1._4/(sx1*dx1*sx2*dx2)
- ! initialize the sin/cos table
- CALL CSFFT2D(+0,sx1,sx2,scale,data(1,1),sx1/2+1, &
- data(1,1),sx1+2,table,work,isys)
- CALL CSFFT2D(+1,sx1,sx2,scale,data(1,1),sx1/2+1, &
- data(1,1),sx1+2,table,work,isys)
- END IF
-
- END SUBROUTINE fft2
-#else
-#ifdef IMKL_FFT
- !------------------------------------------------------
- ! implementation IMKL_FFT (Intel Math Kernel Library)
- ! for information and example calculations with the
- ! mkl FFT, see:
- !
- ! http://www.intel.com/software/products/mkl/ ...
- ! docs/webhelp/appendices/ ...
- ! mkl_appC_DFT.html#appC-exC-25
- !
- ! sylvain barbot (04-30-10) - original form
- !------------------------------------------------------
- SUBROUTINE fft2(data,sx1,sx2,dx1,dx2,direction)
- REAL*4, DIMENSION(0:*), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx1,dx2
- INTEGER, INTENT(IN) :: sx1,sx2,direction
-
- INTEGER :: iret,size(2),rstrides(3),cstrides(3)
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL*4 :: scale
-
- rstrides=(/ 0,1,sx1+2 /)
- cstrides=(/ 0,1,sx1/2+1 /)
- size=(/ sx1,sx2 /)
-
- iret=DftiCreateDescriptor(desc,DFTI_SINGLE,DFTI_REAL,2,size);
- iret=DftiSetValue(desc,DFTI_CONJUGATE_EVEN_STORAGE,DFTI_COMPLEX_COMPLEX)
-
- IF(iret.NE.0) THEN
- IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
- WRITE_DEBUG_INFO
- WRITE (0,*) DftiErrorMessage(iret)
- STOP 1
- END IF
- END IF
-
- IF (FFT_FORWARD == direction) THEN
- scale=dx1*dx2
- iret=DftiSetValue(desc,DFTI_FORWARD_SCALE,scale)
- iret=DftiSetValue(desc,DFTI_INPUT_STRIDES,rstrides);
- iret=DftiSetValue(desc,DFTI_OUTPUT_STRIDES,cstrides);
- iret=DftiCommitDescriptor(desc)
- iret=DftiComputeForward(desc,data)
- ELSE
- scale=1._4/(sx1*dx1*sx2*dx2)
- iret=DftiSetValue(desc,DFTI_BACKWARD_SCALE,scale)
- iret=DftiSetValue(desc,DFTI_INPUT_STRIDES,cstrides);
- iret=DftiSetValue(desc,DFTI_OUTPUT_STRIDES,rstrides);
- iret=DftiCommitDescriptor(desc)
- iret=DftiComputeBackward(desc,data)
- END IF
- iret=DftiFreeDescriptor(desc)
- IF(iret.NE.0) THEN
- IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
- WRITE_DEBUG_INFO
- WRITE (0,*) DftiErrorMessage(iret)
- STOP 1
- END IF
- END IF
-
- END SUBROUTINE fft2
-#else
- !------------------------------------------------------
- ! Couley-Tuckey implementation of the Fourier
- ! transform with built-in FFT code (ctfft.f).
- !------------------------------------------------------
- SUBROUTINE fft2(data,sx1,sx2,dx1,dx2,direction)
- REAL*4, DIMENSION(:,:), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx1,dx2
- INTEGER, INTENT(IN) :: sx1,sx2,direction
-
- INTEGER :: dim(2)
- INTEGER :: FOURT_DS ! data storage
- INTEGER, PARAMETER :: FOURT_NW = 64 ! extra work space size
- REAL*4, DIMENSION(FOURT_NW) :: FOURT_WORK ! extra work space
-
- dim=(/ sx1,sx2 /)
-
- IF (FFT_FORWARD == direction) THEN
- FOURT_DS=0
- ELSE
- FOURT_DS=-1
- END IF
- CALL ctfft(data,dim,2,direction,FOURT_DS,FOURT_WORK,FOURT_NW)
-
- IF (FFT_INVERSE == direction) THEN
- data=data/(sx1*dx1*sx2*dx2)
- ELSE
- data=data*(dx1*dx2)
- END IF
-
- END SUBROUTINE fft2
-#endif
-#endif
-#endif
-
- !-----------------------------------------------------------------
- !> subroutine FFT1
- !! performs a one dimensional complex to complex Fourier
- !! transform
- !!
- !! uses complex DFT ctfft (N. Brenner, 1968) by default
- !! or CCFFT (SGI library) with compile flag SGI_FFT
- !!
- !! \author sylvain barbot (05-02-07) - original form
- !-----------------------------------------------------------------
-#ifdef SGI_FFT
- !------------------------------------------------------
- ! implementation CCFFT
- !
- ! sylvain barbot (09-28-08) - original form
- !------------------------------------------------------
- SUBROUTINE fft1(data,sx,dx,direction)
- INTEGER, INTENT(IN) :: sx,direction
- COMPLEX(KIND=4), DIMENSION(:), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx
-
- INTEGER, PARAMETER :: NF=256
-
- REAL*4, DIMENSION(2*sx+NF) :: table
- REAL*4, DIMENSION(2*sx) :: work
- INTEGER, DIMENSION(2) :: isys
- REAL*4 :: scale
-
- isys(1)=1
-
- IF (FFT_FORWARD == direction) THEN
- scale=dx
- ! initialize the sin/cos table
- CALL CCFFT(+0,sx,scale,data,data,table,work,isys)
- CALL CCFFT(-1,sx,scale,data,data,table,work,isys)
- ELSE
- scale=1._4/(sx*dx)
- ! initialize the sin/cos table
- CALL CCFFT(+0,sx,scale,data,data,table,work,isys)
- CALL CCFFT(+1,sx,scale,data,data,table,work,isys)
- END IF
-
- END SUBROUTINE fft1
-#else
-#ifdef IMKL_FFT
- !------------------------------------------------------
- ! implementation IMKL_FFT (Intel Math Kernel Library)
- ! evaluates a complex-to-complex Fourier transform
- !
- ! sylvain barbot (04-30-10) - original form
- !------------------------------------------------------
- SUBROUTINE fft1(data,sx,dx,direction)
- INTEGER, INTENT(IN) :: sx,direction
- COMPLEX(KIND=4), DIMENSION(0:*), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx
-
- INTEGER :: iret
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
-
- REAL*4 :: scale
-
- iret=DftiCreateDescriptor(desc,DFTI_SINGLE,DFTI_COMPLEX,1,sx)
- IF(iret.NE.0) THEN
- IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
- WRITE_DEBUG_INFO
- WRITE (0,*) DftiErrorMessage(iret)
- STOP 1
- END IF
- END IF
-
- IF (FFT_FORWARD == direction) THEN
- scale=dx
- iret=DftiSetValue(desc,DFTI_FORWARD_SCALE,scale)
- iret=DftiCommitDescriptor(desc)
- iret=DftiComputeForward(desc,data)
- ELSE
- scale=1._4/(sx*dx)
- iret=DftiSetValue(desc,DFTI_BACKWARD_SCALE,scale)
- iret=DftiCommitDescriptor(desc)
- iret=DftiComputeBackward(desc,data)
- END IF
- iret=DftiFreeDescriptor(desc)
- IF(iret.NE.0) THEN
- IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
- WRITE_DEBUG_INFO
- WRITE (0,*) DftiErrorMessage(iret)
- STOP 1
- END IF
- END IF
-
- END SUBROUTINE fft1
-#else
- !----------------------------------------------------
- ! implementation ctfft
- !
- ! sylvain barbot (05-02-07) - original form
- !----------------------------------------------------
- SUBROUTINE fft1(data,sx,dx,direction)
- COMPLEX(KIND=4),DIMENSION(:), INTENT(INOUT) :: data
- REAL*8, INTENT(IN) :: dx
- INTEGER, INTENT(IN) :: sx,direction
-
- INTEGER, PARAMETER :: FOURT_NW = 32 ! extra work space size
- REAL*4, DIMENSION(FOURT_NW) :: FOURT_WORK ! extra work space
- INTEGER :: FOURT_DS = 1
-
- CALL ctfft(data,sx,1,direction,FOURT_DS,FOURT_WORK,FOURT_NW)
- IF (FFT_INVERSE == direction) THEN
- data=data/(sx*dx)
- ELSE
- data=data*dx
- END IF
-
- END SUBROUTINE fft1
-#endif
-#endif
-
-END MODULE fourier
diff -r 405d8f4fa05f -r e7295294f654 friction3d.f90
--- a/friction3d.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,554 +0,0 @@
-!-----------------------------------------------------------------------
-! Copyright 2007, 2008, 2009 Sylvain Barbot
-!
-! This file is part of RELAX
-!
-! RELAX 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 3 of the License, or
-! (at your option) any later version.
-!
-! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
-!-----------------------------------------------------------------------
-
-MODULE friction3d
-
- USE elastic3d
-
- IMPLICIT NONE
-
-#include "include.f90"
-
- REAL*8, PRIVATE, PARAMETER :: pi = 3.141592653589793115997963468544185161_8
- REAL*8, PRIVATE, PARAMETER :: pi2 = 6.28318530717958623199592693708837032318_8
- REAL*8, PRIVATE, PARAMETER :: pid2 = 1.57079632679489655799898173427209258079_8
-
-CONTAINS
-
- !-----------------------------------------------------------------
- !> subroutine FrictionPlaneExpEigenStress
- !!
- !! *** this function is deprecated ***
- !
- ! compute the eigen-stress (forcing moment) to be relaxed by
- ! rate-dependent inelastic deformation in the case of a frictional
- ! surface:
- !
- ! sigma^i = C:F:sigma
- !
- ! where C is the elastic moduli tensor, F is the heterogeneous
- ! fluidity moduli tensor and sigma is the instantaneous stress
- ! tensor. for a frictional surface, the eigenstrain-rate is given
- ! by
- !
- ! epsilon^i^dot = F:sigma = gamma^dot R
- !
- ! where gamma^dot is the slip rate (a scalar) and R is the
- ! deviatoric, symmetric, and unitary, tensor:
- !
- ! R_ij = 1/2 ( t_i n_j + t_j n_i ) / sqrt( t_j t_j )
- !
- ! where the shear traction t_i is the projection of the traction
- ! vector on the plane surface. the strain amplitude is given by
- !
- ! gamma^dot = vo sinh( taus / (t_c )
- !
- ! where taus is the effective shear on the fault plane,
- !
- ! taus = tau + mu*sigma
- !
- ! where tau is the shear and sigma the normal stress. tau and sigma
- ! assumed to be the co-seismic change only, not the absolute
- ! stress. vo is a reference slip velocity, and t_c, the critical
- ! stress, corresponds to (a-b)*sigma in the framework of rate-and-
- ! state friction. the effective viscosity eta* and the fluidity
- !
- ! eta* = tau / gamma^dot
- ! fluidity = 1 / eta*
- !
- ! are used to compute the optimal time-step.
- !
- ! sylvain barbot (07/24/07) - original form
- ! (07/24/07) - deprecated (see frictioneigenstress)
- !-----------------------------------------------------------------
- SUBROUTINE frictionplaneeigenstress(sig,mu,structure, &
- n1,n2,n3,sx1,sx2,sx3,dx1,dx2,dx3,moment,maxwelltime,gamma,dt)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: mu,dx1,dx2,dx3
- TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: moment
- REAL*8, OPTIONAL, INTENT(INOUT) :: maxwelltime
-#ifdef ALIGN_DATA
- REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: n1,n2,n3
- REAL*4, INTENT(OUT), DIMENSION(sx1+2,sx2,sx3), OPTIONAL :: gamma
-#else
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: n1,n2,n3
- REAL*4, INTENT(OUT), DIMENSION(sx1,sx2,sx3), OPTIONAL :: gamma
-#endif
- REAL*8, INTENT(IN), OPTIONAL :: dt
-
- INTEGER :: i1,i2,i3
- TYPE(TENSOR) :: s
- REAL*8, DIMENSION(3) :: t,ts,n
- REAL*8 :: vo,taue,tauc,taun,taus,gammadot,impulse, &
- friction,tau,scaling,cohesion
-
- ! delta function scaling
- scaling=sqrt(pi2)*dx1
-
- DO i3=1,sx3
-
- vo=structure(i3)%gammadot0
- tauc=structure(i3)%stressexponent
- friction=structure(i3)%friction
- cohesion=structure(i3)%cohesion
-
- DO i2=1,sx2
- DO i1=1,sx1
- n=(/ DBLE(n1(i1,i2,i3)),DBLE(n2(i1,i2,i3)),DBLE(n3(i1,i2,i3))/)
- impulse=sqrt(sum(n*n))
-
- IF (impulse .LE. 0.01_8/dx1) CYCLE
-
- ! discrete delta function impulse
- n=n/impulse
-
- ! traction = sigma . n
- s=sig(i1,i2,i3)
- t=s .tdot. n
-
- ! signed normal component
- taun=SUM(t*n)
-
- ! absolute value of shear component
- ts=t-taun*n
- taus=SQRT(SUM(ts*ts))
-
- ! effective shear stress on fault plane
- tau=taus+friction*taun
-
- ! warning for wrong input
- IF ((tau/tauc) .gt. 20) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("------------------------------------------")')
- WRITE (0,'("wrong value of (a-b)sigma gives rise to")')
- WRITE (0,'("(a-b)sigma=",3ES11.3E2)') tauc
- WRITE (0,'("tau=",3ES11.3E2)') tau
- WRITE (0,'("taus=",3ES11.3E2)') taus
- WRITE (0,'("taun=",3ES11.3E2)') taun
- WRITE (0,'("tau/((a-b)sigma)=",3ES11.3E2)') tau/tauc
- WRITE (0,'("------------------------------------------")')
- STOP 5
- END IF
-
- ! effective stress
- taue=tau-cohesion
-
- ! yield surface test
- IF ((0._8 .GE. taus) .OR. (taue .LE. 1e-8)) CYCLE
-
- ! shear traction direction
- ts=ts/taus
-
- ! deviatoric strain rate
- gammadot=vo*2*sinh(taue/tauc)
-
- IF (PRESENT(maxwelltime)) &
- maxwelltime=MIN(maxwelltime,taue/mu/gammadot)
-
- ! provide the strain-rate on request
- IF (PRESENT(gamma)) THEN
- gamma(i1,i2,i3)=gamma(i1,i2,i3)+gammadot*impulse*scaling*dt
- END IF
-
- ! deviatoric strain
- moment(i1,i2,i3)=moment(i1,i2,i3) .plus. &
- (ts .sdyad. ((2._8*mu*impulse*gammadot)*n))
-
- END DO
- END DO
- END DO
-
- END SUBROUTINE frictionplaneeigenstress
-
- !-----------------------------------------------------------------
- !> subroutine FrictionEigenStress
- !! compute the eigen-stress (forcing moment) to be relaxed by
- !! rate-dependent inelastic deformation in the case of a frictional
- !! surface:
- !!
- !! sigma^i = C:F:sigma
- !!
- !! where C is the elastic moduli tensor, F is the heterogeneous
- !! fluidity moduli tensor and sigma is the instantaneous stress
- !! tensor. for a frictional surface, the eigenstrain-rate is given
- !! by
- !!
- !! epsilon^i^dot = F:sigma = gamma^dot R
- !!
- !! where gamma^dot is the slip rate (a scalar) and R is the
- !! deviatoric, symmetric, and unitary, tensor:
- !!
- !! R_ij = 1/2 ( t_i n_j + t_j n_i ) / sqrt( t_j t_j )
- !!
- !! where the shear traction t_i is the projection of the traction
- !! vector on the plane surface. the strain amplitude is given by
- !!
- !! gamma^dot = H( t_j r_j ) 2 vo sinh( taus / (t_c )
- !!
- !! where taus is the effective shear on the fault plane,
- !!
- !! taus = tau + mu*sigma
- !!
- !! where tau is the shear and sigma the normal stress. tau and sigma
- !! assumed to be the co-seismic change only, not the absolute
- !! stress. vo is a reference slip velocity, and t_c, the critical
- !! stress, corresponds to (a-b)*sigma in the framework of rate-and-
- !! state friction. the effective viscosity eta* and the fluidity
- !!
- !! eta* = tau / gamma^dot
- !! fluidity = 1 / eta*
- !!
- !! are used to compute the optimal time-step. H( x ) is the
- !! Heaviside function and r_i is the rake vector. I impose
- !! gamma^dot to be zero is t_j r_j < 0. This constraint is
- !! enforced to ensure that no back slip occurs on faults.
- !!
- !! \author sylvain barbot (07/24/07) - original form
- !! (02/28/11) - add constraints on the direction
- !! of afterslip
- !-----------------------------------------------------------------
- SUBROUTINE frictioneigenstress(x,y,z,L,W,strike,dip,rake,beta, &
- sig,mu,structure,sx1,sx2,sx3,dx1,dx2,dx3,moment,maxwelltime,vel)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: mu,dx1,dx2,dx3,x,y,z,L,W,strike,dip,rake,beta
- TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: moment
- REAL*8, OPTIONAL, INTENT(INOUT) :: maxwelltime
-#ifdef ALIGN_DATA
- REAL*4, INTENT(OUT), DIMENSION(sx1+2,sx2,sx3), OPTIONAL :: vel
-#else
- REAL*4, INTENT(OUT), DIMENSION(sx1,sx2,sx3), OPTIONAL :: vel
-#endif
-
- INTEGER :: i1,i2,i3
- TYPE(TENSOR) :: s
- REAL*8, DIMENSION(3) :: t,ts,n,r
- REAL*8 :: vo,tauc,taun,taus,gammadot,impulse, &
- friction,tau,scaling,cohesion
- REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
- cstrike,sstrike,cdip,sdip,cr,sr,x2r,&
- temp1,temp2,temp3,sourc,image,xr,yr,zr,Wp,Lp,dum
- REAL*4 :: tm
-
- IF (PRESENT(maxwelltime)) THEN
- tm=maxwelltime
- ELSE
- tm=1e30
- END IF
-
- ! delta function scaling
- scaling=sqrt(pi2)*dx1
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
- cr=cos(rake)
- sr=sin(rake)
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta)/2._8
- Lp=L*(1._8+2._8*beta)/2._8
-
- ! rotate centre coordinates of source and images
- x2r= cstrike*x -sstrike*y
- xr = cdip *x2r-sdip *z
- yr = sstrike*x +cstrike*y
- zr = sdip *x2r+cdip *z
-
- ! surface normal vector components
- n(1)=+cdip*cstrike
- n(2)=-cdip*sstrike
- n(3)=-sdip
-
- ! rake vector component
- r(1)=sstrike*cr+cstrike*sdip*sr
- r(2)=cstrike*cr-sstrike*sdip*sr
- r(3)=cdip*sr
-
- DO i3=1,sx3
- x3=DBLE(i3-1)*dx3
- IF ((abs(x3-z).gt.Lp) .and. (abs(x3+z).gt.Lp)) CYCLE
-
- vo=structure(i3)%gammadot0
- tauc=structure(i3)%stressexponent
- friction=structure(i3)%friction
- cohesion=structure(i3)%cohesion
-
- DO i2=1,sx2
- DO i1=1,sx1
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
- dx1,dx2,dx3,x1,x2,dum)
- IF ((ABS(x1-x).gt.MAX(Wp,Lp)) .OR. (ABS(x2-y).gt.MAX(Wp,Lp))) CYCLE
-
- x2r= cstrike*x1-sstrike*x2
- x1s= cdip*x2r-sdip*x3
- x1i= cdip*x2r+sdip*x3
- IF ((ABS(x1s-xr).GT.7.01_8*dx1).AND.(ABS(x1i-xr).GT.7.01_8*dx1)) CYCLE
- x2s= sstrike*x1+cstrike*x2
- x3s= sdip*x2r+cdip*x3
- x3i=-sdip*x2r+cdip*x3
-
- ! integrate at depth and along strike with raised cosine taper
- ! and shift sources to x,y,z coordinate
- temp1=gauss(x1s-xr,dx1)
- temp2=omega((x2s-yr)/W,beta)
- temp3=omega((x3s-zr)/L,beta)
- sourc=temp1*temp2*temp3
-
- temp1=gauss(x1i-xr,dx1)
- temp3=omega((x3i+zr)/L,beta)
- image=temp1*temp2*temp3
-
- impulse=sourc+image
-
- ! traction = sigma . n
- s=sig(i1,i2,i3)
- t=s .tdot. n
-
- ! signed normal component
- taun=SUM(t*n)
-
- ! absolute value of shear component
- ts=t-taun*n
- taus=SQRT(SUM(ts*ts))
-
- ! effective shear stress on fault plane
- tau=MAX(0.d0,taus+friction*taun-cohesion)
-
- ! rake direction test only if | rake | < 3*Pi
- IF (SUM(ts*r).LT.0.d0 .AND. ABS(rake).LT.pi2*1.5d0) CYCLE
-
- ! warning for wrong input
- IF ((tau/tauc) .gt. 20) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("------------------------------------------")')
- WRITE (0,'("wrong value of (a-b)sigma gives rise to")')
- WRITE (0,'("(a - b) * sigma = ",ES11.3E2)') tauc
- WRITE (0,'("tau = ",ES11.3E2)') tau
- WRITE (0,'("tau_s = ",ES11.3E2)') taus
- WRITE (0,'("tau_n = ",ES11.3E2)') taun
- WRITE (0,'("tau / ((a - b) sigma) = ",ES11.3E2)') tau/tauc
- WRITE (0,'("------------------------------------------")')
- STOP 5
- END IF
-
- ! shear traction direction
- ts=ts/taus
-
- ! deviatoric strain rate
- gammadot=vo*2._8*sinh(tau/tauc)
-
- tm=MIN(tm,tau/mu/gammadot*(MIN(L,W)/sqrt(dx1*dx3)))
-
- ! provide the strain-rate on request
- IF (PRESENT(vel)) THEN
- vel(i1,i2,i3)=vel(i1,i2,i3)+gammadot*impulse*scaling
- END IF
-
- ! deviatoric strain
- moment(i1,i2,i3)=moment(i1,i2,i3) .plus. &
- (ts .sdyad. ((2._8*mu*impulse*gammadot)*n))
-
- END DO
- END DO
- END DO
-
- IF (PRESENT(maxwelltime)) maxwelltime=MIN(tm,maxwelltime)
-
- END SUBROUTINE frictioneigenstress
-
- !---------------------------------------------------------------------
- !> function MonitorFriction
- !! samples a scalar field along a specified planar surface.
- !!
- !! input:
- !! @param x,y,z coordinates of the creeping segment
- !! @param L dimension of segment in the depth direction
- !! @param W dimension of segment in the strike direction
- !! @param beta smoothing factor
- !! @param sx1,2,3 dimension of the stress tensor array
- !! @param dx1,2,3 sampling size
- !! @param sig stress tensor array
- !! @param structure frictional properties as a function of depth
- !!
- !! output:
- !! @param patch list of strike- and dip-slip as a function of position
- !! on the fault.
- !!
- !! \author sylvain barbot (10-16-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE monitorfriction(x,y,z,L,W,strike,dip,rake,beta, &
- sx1,sx2,sx3,dx1,dx2,dx3,sig,structure,patch)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: x,y,z,L,W,strike,rake,dip,beta,dx1,dx2,dx3
- TYPE(TENSOR), DIMENSION(sx1,sx2,sx3), INTENT(IN) :: sig
- TYPE(SLIPPATCH_STRUCT), ALLOCATABLE, DIMENSION(:,:), INTENT(OUT) :: patch
- TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
-
- INTEGER :: i1,i2,i3,px2,px3,j2,j3,status
- REAL*8 :: cstrike,sstrike,cdip,sdip,cr,sr
- REAL*8 :: vo,tauc,taun,taus, &
- friction,tau,cohesion
- REAL*8 :: x1,x2,x3,xr,yr,zr,Wp,Lp
- TYPE(TENSOR) :: s
- REAL*8, DIMENSION(3) :: t,ts,n,sv,dv,r
-
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
- cr=cos(rake)
- sr=sin(rake)
-
- ! strike direction vector
- sv=(/ sstrike, cstrike, 0._8 /)
-
- ! dip direction vector
- dv=(/ -cstrike*sdip, +sstrike*sdip, -cdip /)
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta) ! horizontal dimension for vertical fault
- Lp=L*(1._8+2._8*beta) ! depth for a vertical fault
-
- ! number of samples in the dip and strike direction
- px3=fix(L/dx3)
- px2=fix(W/dx2)
-
- ! allocate array of measurements
- ALLOCATE(patch(px2+1,px3+1),STAT=status)
- IF (status>0) STOP "could not allocate the slip patches for export"
-
- ! surface normal vector components
- n(1)=+cdip*cstrike
- n(2)=-cdip*sstrike
- n(3)=-sdip
-
- ! rake vector component
- r(1)=sstrike*cr+cstrike*sdip*sr
- r(2)=cstrike*cr-sstrike*sdip*sr
- r(3)=cdip*sr
-
- ! loop in the dip direction
- DO j3=1,px3+1
- ! loop in the strike direction
- DO j2=1,px2+1
-
- CALL ref2local(x,y,z,xr,yr,zr)
-
- ! no translation in out of plane direction
- yr=REAL(yr)+REAL((DBLE(j2)-DBLE(px2)/2._8-1._8)*dx2)
- zr=REAL(zr)+REAL((DBLE(j3)-DBLE(px3)/2._8-1._8)*dx3)
-
- CALL local2ref(xr,yr,zr,x1,x2,x3)
-
- ! initialize zero slip velocity
- patch(j2,j3)=SLIPPATCH_STRUCT(x1,x2,x3,yr,zr,0._8,0._8,0._8,s)
-
- ! discard out-of-bound locations
- IF ( (x1 .GT. DBLE(sx1/2-1)*dx1) .OR. (x1 .LT. -DBLE(sx1/2)*dx1) &
- .OR. (x2 .GT. DBLE(sx2/2-1)*dx2) .OR. (x2 .LT. -DBLE(sx2/2)*dx2) &
- .OR. (x3 .GT. DBLE(sx3-1)*dx3) .OR. (x3 .LT. 0._8) ) CYCLE
-
- ! evaluates instantaneous creep velocity
- CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
-
- ! retrieve friction parameters
- vo=structure(i3)%gammadot0
- tauc=structure(i3)%stressexponent
- friction=structure(i3)%friction
- cohesion=structure(i3)%cohesion
-
- ! traction = sigma . n
- s=sig(i1,i2,i3)
- t=s .tdot. n
-
- ! signed normal component
- taun=SUM(t*n)
-
- ! absolute value of shear component
- ts=t-taun*n
- taus=SQRT(SUM(ts*ts))
-
- ! effective shear stress on fault plane
- tau=MAX(0.d0,taus+friction*taun-cohesion)
-
- ! rake direction test only if | rake | < 3*Pi
- IF (SUM(ts*r).LT.0.d0 .AND. ABS(rake).LT.pi2*1.5d0) CYCLE
-
- ! creep rate
- patch(j2,j3)%slip=vo*2._8*sinh(tau/tauc)
-
- ! shear traction direction
- ts=ts/taus
-
- ! strike-direction creep rate
- patch(j2,j3)%ss=patch(j2,j3)%slip*SUM(ts*sv)
-
- ! dip-direction creep rate
- patch(j2,j3)%ds=patch(j2,j3)%slip*SUM(ts*dv)
-
- END DO
- END DO
-
- CONTAINS
-
- !-----------------------------------------------
- ! subroutine ref2local
- ! convert reference Cartesian coordinates into
- ! the rotated, local fault coordinates system.
- !-----------------------------------------------
- SUBROUTINE ref2local(x,y,z,xp,yp,zp)
- REAL*8, INTENT(IN) :: x,y,z
- REAL*8, INTENT(OUT) :: xp,yp,zp
-
- REAL*8 :: x2
-
- x2 = cstrike*x -sstrike*y
- xp = cdip *x2 -sdip *z
- yp = sstrike*x +cstrike*y
- zp = sdip *x2 +cdip *z
-
- END SUBROUTINE ref2local
-
- !-----------------------------------------------
- ! subroutine local2ref
- ! converts a set of coordinates from the rotated
- ! fault-aligned coordinate system into the
- ! reference, Cartesian coordinates system.
- !-----------------------------------------------
- SUBROUTINE local2ref(xp,yp,zp,x,y,z)
- REAL*8, INTENT(IN) :: xp,yp,zp
- REAL*8, INTENT(OUT) :: x,y,z
-
- REAL*8 :: x2p
-
- x2p= cdip*xp+sdip*zp
- x = cstrike*x2p+sstrike*yp
- y = -sstrike*x2p+cstrike*yp
- z = -sdip*xp +cdip*zp
-
- END SUBROUTINE local2ref
-
- END SUBROUTINE monitorfriction
-
-END MODULE friction3d
diff -r 405d8f4fa05f -r e7295294f654 getdata.f
--- a/getdata.f Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,30 +0,0 @@
- subroutine getdata(unit,line)
- implicit none
-c
-c First implemented in Potsdam, Feb, 1999
-c Last modified: Potsdam, Nov, 2001, by R. Wang
-c
- integer unit
- character line*180,char*1
-c
- integer i
-c
-c this subroutine reads over all comment lines starting with "#".
-c
- char='#'
-100 continue
- if(char.eq.'#')then
- read(unit,'(a)')line
- i=1
- char=line(1:1)
-200 continue
- if(char.eq.' ')then
- i=i+1
- char=line(i:i)
- goto 200
- endif
- goto 100
- endif
-c
- return
- end
diff -r 405d8f4fa05f -r e7295294f654 getopt_m.f90
--- a/getopt_m.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,233 +0,0 @@
-! ------------------------------------------------------------
-! Copyright 2008 by Mark Gates
-!
-! This program is free software; you can redistribute or modify it under
-! the terms of the GNU general public license (GPL), version 2 or later.
-!
-! 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.
-!
-! If you wish to incorporate this into non-GPL software, please contact
-! me regarding licensing terms.
-!
-! ------------------------------------------------------------
-! Fortran 95 getopt() and getopt_long(), similar to those in standard C library.
-!
-! ch = getopt( optstring, [longopts] )
-! Returns next option character from command line arguments.
-! If an option is not recognized, it returns '?'.
-! If no options are left, it returns a null character, char(0).
-!
-! optstring contains characters that are recognized as options.
-! If a character is followed by a colon, then it takes a required argument.
-! For example, "x" recognizes "-x", while "x:" recognizes "-x arg" or "-xarg".
-!
-! optopt is set to the option character, even if it isn't recognized.
-! optarg is set to the option's argument.
-! optind has the index of the next argument to process. Initially optind=1.
-! Errors are printed by default. Set opterr=.false. to suppress them.
-!
-! Grouped options are allowed, so "-abc" is the same as "-a -b -c".
-!
-! If longopts is present, it is an array of type(option_s), where each entry
-! describes one long option.
-!
-! type option_s
-! character(len=80) :: name
-! logical :: has_arg
-! character :: val
-! end type
-!
-! The name field is the option name, without the leading -- double dash.
-! Set the has_arg field to true if it requires an argument, false if not.
-! The val field is returned. Typically this is set to the corresponding short
-! option, so short and long options can be processed together. (But there
-! is no requirement that every long option has a short option, or vice-versa.)
-!
-! -----
-! EXAMPLE
-! program test
-! use getopt_m
-! implicit none
-! character:: ch
-! type(option_s):: opts(2)
-! opts(1) = option_s( "alpha", .false., 'a' )
-! opts(2) = option_s( "beta", .true., 'b' )
-! do
-! select case( getopt( "ab:c", opts ))
-! case( char(0))
-! exit
-! case( 'a' )
-! print *, 'option alpha/a'
-! case( 'b' )
-! print *, 'option beta/b=', optarg
-! case( '?' )
-! print *, 'unknown option ', optopt
-! stop
-! case default
-! print *, 'unhandled option ', optopt, ' (this is a bug)'
-! end select
-! end do
-! end program test
-!
-! Differences from C version:
-! - when options are finished, C version returns -1 instead of char(0),
-! and thus stupidly requires an int instead of a char.
-! - does not support optreset
-! - does not support "--" as last argument
-! - if no argument, optarg is blank, not NULL
-! - argc and argv are implicit
-!
-! Differences for long options:
-! - optional argument to getopt(), rather than separate function getopt_long()
-! - has_arg is logical, and does not support optional_argument
-! - does not support flag field (and thus always returns val)
-! - does not support longindex
-! - does not support "--opt=value" syntax, only "--opt value"
-! - knows the length of longopts, so does not need an empty last record
-
-module getopt_m
- implicit none
- character(len=80):: optarg
- character:: optopt
- integer:: optind=1
- logical:: opterr=.true.
-
- type option_s
- character(len=80) :: name
- logical :: has_arg
- character :: val
- end type
-
- ! grpind is index of next option within group; always >= 2
- integer, private:: grpind=2
-
-contains
-
-! ----------------------------------------
-! Return str(i:j) if 1 <= i <= j <= len(str),
-! else return empty string.
-! This is needed because Fortran standard allows but doesn't *require* short-circuited
-! logical AND and OR operators. So this sometimes fails:
-! if ( i < len(str) .and. str(i+1:i+1) == ':' ) then
-! but this works:
-! if ( substr(str, i+1, i+1) == ':' ) then
-
-character function substr( str, i, j )
- ! arguments
- character(len=*), intent(in):: str
- integer, intent(in):: i, j
-
- if ( 1 <= i .and. i <= j .and. j <= len(str)) then
- substr = str(i:j)
- else
- substr = ''
- endif
-end function substr
-
-
-! ----------------------------------------
-character function getopt( optstring, longopts )
- ! arguments
- character(len=*), intent(in):: optstring
- type(option_s), intent(in), optional:: longopts(:)
-
- ! local variables
- character(len=80):: arg
-
- optarg = ''
- if ( optind > iargc()) then
- getopt = char(0)
- endif
-
- call getarg( optind, arg )
- if ( present( longopts ) .and. arg(1:2) == '--' ) then
- getopt = process_long( longopts, arg )
- elseif ( arg(1:1) == '-' ) then
- getopt = process_short( optstring, arg )
- else
- getopt = char(0)
- endif
-end function getopt
-
-
-! ----------------------------------------
-character function process_long( longopts, arg )
- ! arguments
- type(option_s), intent(in):: longopts(:)
- character(len=*), intent(in):: arg
-
- ! local variables
- integer:: i
-
- ! search for matching long option
- optind = optind + 1
- do i = 1, size(longopts)
- if ( arg(3:) == longopts(i)%name ) then
- optopt = longopts(i)%val
- process_long = optopt
- if ( longopts(i)%has_arg ) then
- if ( optind <= iargc()) then
- call getarg( optind, optarg )
- optind = optind + 1
- elseif ( opterr ) then
- WRITE (0,'(a,a,a)') "error: option '", trim(arg), "' requires an argument"
- endif
- endif
- return
- endif
- end do
- ! else not found
- process_long = '?'
- if ( opterr ) then
- WRITE (0,'(a,a,a)'), "error: unrecognized option '", trim(arg), "'"
- endif
-end function process_long
-
-
-! ----------------------------------------
-character function process_short( optstring, arg )
- ! arguments
- character(len=*), intent(in):: optstring, arg
-
- ! local variables
- integer:: i, arglen
-
- arglen = len( trim( arg ))
- optopt = arg(grpind:grpind)
- process_short = optopt
-
- i = index( optstring, optopt )
- if ( i == 0 ) then
- ! unrecognized option
- process_short = '?'
- if ( opterr ) then
- print '(a,a,a)', "Error: unrecognized option '-", optopt, "'"
- endif
- endif
- if ( i > 0 .and. substr( optstring, i+1, i+1 ) == ':' ) then
- ! required argument
- optind = optind + 1
- if ( arglen > grpind ) then
- ! -xarg, return remainder of arg
- optarg = arg(grpind+1:arglen)
- elseif ( optind <= iargc()) then
- ! -x arg, return next arg
- call getarg( optind, optarg )
- optind = optind + 1
- elseif ( opterr ) then
- WRITE (0,'(a,a,a)') "error: option '-", optopt, "' requires an argument"
- endif
- grpind = 2
- elseif ( arglen > grpind ) then
- ! no argument (or unrecognized), go to next option in argument (-xyz)
- grpind = grpind + 1
- else
- ! no argument (or unrecognized), go to next argument
- grpind = 2
- optind = optind + 1
- endif
-end function process_short
-
-end module getopt_m
diff -r 405d8f4fa05f -r e7295294f654 green.f90
--- a/green.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,953 +0,0 @@
-!-----------------------------------------------------------------------
-! Copyright 2007, 2008, 2009 Sylvain Barbot
-!
-! This file is part of RELAX
-!
-! RELAX 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 3 of the License, or
-! (at your option) any later version.
-!
-! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
-!-----------------------------------------------------------------------
-
-MODULE green
-
- USE fourier
-
- IMPLICIT NONE
-
-#include "include.f90"
-
- PUBLIC
- REAL*8, PRIVATE, PARAMETER :: pi = 3.141592653589793115997963468544185161_8
- REAL*8, PRIVATE, PARAMETER :: pi2 = 6.28318530717958623199592693708837032318_8
- REAL*8, PRIVATE, PARAMETER :: pid2 = 1.57079632679489655799898173427209258079_8
-
- INTEGER, PARAMETER :: GRN_IMAGE=1,GRN_HS=0
-
-CONTAINS
-
- !------------------------------------------------------------------------
- !> Subroutine ElasticResponse
- !! apply the 2d elastic (half-space) transfert function
- !! to the set of body forces.
- !!
- !! INPUT:
- !! @param mu shear modulus
- !! @param f1,2,3 equivalent body-forces in the Fourier domain
- !! @param dx1,2,3 sampling size
- !!
- !! \author sylvain barbot (04/14/07) - original form
- !! (02/06/09) - parallel implementation with MPI and OpenMP
- !! (01/06/11) - remove implementation with MPI
- !------------------------------------------------------------------------
- SUBROUTINE elasticresponse(lambda,mu,f1,f2,f3,dx1,dx2,dx3)
- REAL*8, INTENT(IN) :: lambda,mu,dx1,dx2,dx3
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: f1,f2,f3
-
- REAL*8 :: k1,k2,k3,denom,r2,ratio1,ratio2
- INTEGER :: i1,i2,i3,sx1,sx2,sx3,ubound3
- COMPLEX(kind=8) :: buf1,buf2,buf3,c1,c2,c3
-
- sx1=SIZE(f2,1)-2
- sx2=SIZE(f2,2)
- sx3=SIZE(f2,3)
-
- ratio1=(lambda+mu)/(lambda+2._8*mu)/mu/(pi2**2._8)
- ratio2=mu/(lambda+mu)
-
- ubound3=sx3
-
- ! serial computation
-!$omp parallel do private(i1,i2,k1,k2,k3,r2,denom,c1,c2,c3,buf1,buf2,buf3)
- DO i3=1,ubound3
- CALL wavenumber3(i3,sx3,dx3,k3)
- DO i2=1,sx2
- CALL wavenumber2(i2,sx2,dx2,k2)
- DO i1=1,sx1/2+1
- CALL wavenumber1(i1,sx1,dx1,k1)
-
- r2=k1**2._8+k2**2._8+k3**2._8
- denom=ratio1/r2**2
-
- c1=CMPLX(f1(2*i1-1,i2,i3),f1(2*i1,i2,i3),8)
- c2=CMPLX(f2(2*i1-1,i2,i3),f2(2*i1,i2,i3),8)
- c3=CMPLX(f3(2*i1-1,i2,i3),f3(2*i1,i2,i3),8)
-
- buf1=((k2**2._8+k3**2._8+ratio2*r2)*c1-k1*(k2*c2+k3*c3))*denom
- buf2=((k1**2._8+k3**2._8+ratio2*r2)*c2-k2*(k1*c1+k3*c3))*denom
- buf3=((k1**2._8+k2**2._8+ratio2*r2)*c3-k3*(k1*c1+k2*c2))*denom
-
- f1(2*i1-1:2*i1,i2,i3)=REAL((/ REAL(buf1),AIMAG(buf1) /))
- f2(2*i1-1:2*i1,i2,i3)=REAL((/ REAL(buf2),AIMAG(buf2) /))
- f3(2*i1-1:2*i1,i2,i3)=REAL((/ REAL(buf3),AIMAG(buf3) /))
- END DO
- END DO
- END DO
-!$omp end parallel do
-
- ! zero wavenumber, no net body-force
- f1(1:2,1,1)=(/ 0._4, 0._4 /)
- f2(1:2,1,1)=(/ 0._4, 0._4 /)
- f3(1:2,1,1)=(/ 0._4, 0._4 /)
-
- END SUBROUTINE elasticresponse
-
- !---------------------------------------------------------------------
- !> subroutine SurfaceNormalTraction
- !! computes the two-dimensional field of surface normal stress
- !! expressed in the Fourier domain.
- !! The surface (x3=0) solution is obtained by integrating over the
- !! wavenumbers in 3-direction in the Fourier domain.
- !!
- !! \author sylvain barbot (05-01-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE surfacenormaltraction(lambda, mu, u1, u2, u3, dx1, dx2, dx3, p)
- REAL*4, INTENT(IN), DIMENSION(:,:,:) :: u1, u2, u3
- REAL*8, INTENT(IN) :: lambda, mu, dx1, dx2, dx3
- REAL*4, INTENT(OUT), DIMENSION(:,:) :: p
-
- INTEGER :: i1, i2, i3, sx1, sx2, sx3
- REAL*8 :: k1, k2, k3, modulus
- COMPLEX*8, PARAMETER :: i = CMPLX(0._8,pi2)
- COMPLEX*8 :: sum, c1, c2, c3
-
- sx1=SIZE(u1,1)-2
- sx2=SIZE(u1,2)
- sx3=SIZE(u1,3)
-
- modulus=lambda+2*mu
-
- p=0
- DO i3=1,sx3
- DO i2=1,sx2
- DO i1=1,sx1/2+1
- CALL wavenumbers(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,k1,k2,k3)
-
- c1=CMPLX(u1(2*i1-1,i2,i3),u1(2*i1,i2,i3))
- c2=CMPLX(u2(2*i1-1,i2,i3),u2(2*i1,i2,i3))
- c3=CMPLX(u3(2*i1-1,i2,i3),u3(2*i1,i2,i3))
-
- sum=i*(modulus*k3*c3+lambda*(k1*c1+k2*c2))
-
- p(2*i1-1,i2)=p(2*i1-1,i2)+REAL( REAL(sum))
- p(2*i1 ,i2)=p(2*i1 ,i2)+REAL(AIMAG(sum))
- END DO
- END DO
- END DO
- p=p/(sx3*dx3)
-
- END SUBROUTINE surfacenormaltraction
-
- !---------------------------------------------------------------------
- !> subroutine Boussinesq3D
- !! computes the deformation field in the 3-dimensional grid
- !! due to a normal stress at the surface. Apply the Fourier domain
- !! solution of Steketee [1958].
- !---------------------------------------------------------------------
- SUBROUTINE boussinesq3d(p,lambda,mu,u1,u2,u3,dx1,dx2,dx3)
- REAL*4, DIMENSION(:,:), INTENT(IN) :: p
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: u1, u2, u3
- REAL*8, INTENT(IN) :: lambda, mu, dx1, dx2, dx3
-
- INTEGER :: i1, i2, i3, sx1, sx2, sx3, status
- REAL*8 :: k1, k2, k3, x3, alpha
- COMPLEX, ALLOCATABLE, DIMENSION(:) :: b1, b2, b3
- COMPLEX :: load
-
- sx1=SIZE(u1,1)-2
- sx2=SIZE(u1,2)
- sx3=SIZE(u1,3)
-
- ALLOCATE(b1(sx3),b2(sx3),b3(sx3),STAT=status)
- IF (0/=status) STOP "could not allocate arrays for Boussinesq3D"
-
- alpha=(lambda+mu)/(lambda+2*mu)
-
- DO i2=1,sx2
- DO i1=1,sx1/2+1
- CALL wavenumbers(i1,i2,1,sx1,sx2,1,dx1,dx2,1._8,k1,k2,k3)
- load=CMPLX(p(2*i1-1,i2),p(2*i1,i2))
- DO i3=1,sx3
- IF (i3<=sx3/2) THEN
- x3=DBLE(i3-1)*dx3
- ELSE
- x3=ABS(DBLE(i3-sx3-1)*dx3)
- END IF
- CALL steketeesolution(load,alpha,b1(i3),b2(i3),b3(i3),k1,k2,x3)
- END DO
-
- ! transforms the Steketee solution into a full 3-dimensional
- ! Fourier transform by 1d transforming in the 3-direction
- CALL fft1(b1,sx3,dx3,FFT_FORWARD)
- CALL fft1(b2,sx3,dx3,FFT_FORWARD)
- CALL fft1(b3,sx3,dx3,FFT_FORWARD)
-
- ! add the Boussinesq contribution to the deformation field
- DO i3=1,sx3
- u1(2*i1-1:2*i1,i2,i3)=u1(2*i1-1:2*i1,i2,i3)+ &
- (/REAL(b1(i3)),AIMAG(b1(i3))/)
- u2(2*i1-1:2*i1,i2,i3)=u2(2*i1-1:2*i1,i2,i3)+ &
- (/REAL(b2(i3)),AIMAG(b2(i3))/)
- u3(2*i1-1:2*i1,i2,i3)=u3(2*i1-1:2*i1,i2,i3)+ &
- (/REAL(b3(i3)),AIMAG(b3(i3))/)
- END DO
- END DO
- END DO
-
- DEALLOCATE(b1,b2,b3)
-
- CONTAINS
- !-----------------------------------------------------------------
- !> subroutine SteketeeSolution
- !! computes the spectrum (two-dimensional Fourier transform)
- !! of the 3 components of the deformation field u1, u2, u3
- !! at wavenumbers k1, k2 and position x3. This is the analytical
- !! solution of [J. A. Steketee, On Volterra's dislocations in a
- !! semi-infinite elastic medium, Canadian Journal of Physics, 1958]
- !!
- !! \author sylvain barbot (05-02-07) - original form
- !-----------------------------------------------------------------
- SUBROUTINE steketeesolution(p,alpha,u1,u2,u3,k1,k2,x3)
- COMPLEX, INTENT(INOUT) :: u1, u2, u3
- REAL*8, INTENT(IN) :: alpha, k1, k2, x3
- COMPLEX, INTENT(IN) :: p
-
- REAL*8 :: beta, depthdecay
- COMPLEX, PARAMETER :: i=CMPLX(0,1)
- COMPLEX :: b
-
- beta=pi2*sqrt(k1**2._8+k2**2._8)
- depthdecay=exp(-beta*abs(x3))
-
- IF (0==k1 .AND. 0==k2) THEN
- u1=CMPLX(0.,0.)
- u2=CMPLX(0.,0.)
- u3=CMPLX(0.,0.)
- ELSE
- b=p/(2._8*mu*alpha*beta**3._8)
- u1=i*alpha*pi2*beta*b*(1._8-1._8/alpha+beta*x3)*depthdecay
- u2=u1
- u1=u1*k1
- u2=u2*k2
- u3=-p/(2*mu*beta)*(1._8/alpha+beta*x3)*depthdecay
- END IF
-
- END SUBROUTINE steketeesolution
-
- END SUBROUTINE boussinesq3d
-
- !---------------------------------------------------------------------
- !> subroutine SurfaceTraction
- !! computes the two-dimensional field of surface normal stress
- !! expressed in the Fourier domain.
- !! The surface (x3=0) solution is obtained by integrating over the
- !! wavenumbers in 3-direction in the Fourier domain.
- !!
- !! \author sylvain barbot (07-07-07) - original form
- ! (02-09-09) - parallelized with mpi and openmp
- !---------------------------------------------------------------------
- SUBROUTINE surfacetraction(lambda,mu,u1,u2,u3,dx1,dx2,dx3,p1,p2,p3)
- REAL*4, INTENT(IN), DIMENSION(:,:,:) :: u1,u2,u3
- REAL*8, INTENT(IN) :: lambda,mu,dx1,dx2,dx3
- REAL*4, INTENT(OUT), DIMENSION(:,:) :: p1,p2,p3
-
- INTEGER :: i1,i2,i3,sx1,sx2,sx3
- REAL*8 :: k1,k2,k3,modulus
- COMPLEX(KIND=8), PARAMETER :: i=CMPLX(0._8,pi2,8)
- COMPLEX(KIND=8) :: sum1,sum2,sum3,c1,c2,c3
-
- sx1=SIZE(u1,1)-2
- sx2=SIZE(u1,2)
- sx3=SIZE(u1,3)
-
- modulus=lambda+2._8*mu
-
- p1=0
- p2=0
- p3=0
-
-!$omp parallel do private(i1,i2,k1,k2,k3,c1,c2,c3,sum1,sum2,sum3), &
-!$omp reduction(+:p1,p2,p3)
- DO i3=1,sx3
- DO i2=1,sx2
- DO i1=1,sx1/2+1
- CALL wavenumbers(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,k1,k2,k3)
-
- c1=CMPLX(u1(2*i1-1,i2,i3),u1(2*i1,i2,i3),8)
- c2=CMPLX(u2(2*i1-1,i2,i3),u2(2*i1,i2,i3),8)
- c3=CMPLX(u3(2*i1-1,i2,i3),u3(2*i1,i2,i3),8)
-
- sum1=i*mu*(k3*c1+k1*c3)
- sum2=i*mu*(k3*c2+k2*c3)
- sum3=i*(modulus*k3*c3+lambda*(k1*c1+k2*c2))
-
- p1(2*i1-1:2*i1,i2)=p1(2*i1-1:2*i1,i2) &
- +(/REAL(REAL(sum1)),REAL(AIMAG(sum1))/)
- p2(2*i1-1:2*i1,i2)=p2(2*i1-1:2*i1,i2) &
- +(/REAL(REAL(sum2)),REAL(AIMAG(sum2))/)
- p3(2*i1-1:2*i1,i2)=p3(2*i1-1:2*i1,i2) &
- +(/REAL(REAL(sum3)),REAL(AIMAG(sum3))/)
-
- END DO
- END DO
- END DO
-!$omp end parallel do
-
- p1=p1/(sx3*dx3)
- p2=p2/(sx3*dx3)
- p3=p3/(sx3*dx3)
-
- END SUBROUTINE surfacetraction
-
- !---------------------------------------------------------------------
- !> subroutine SurfaceTractionCowling
- !! computes the two-dimensional field of the resulting traction
- !! expressed in the Fourier domain in the presence of gravity.
- !!
- !! The surface solution (x3=0) is obtained from the Fourier domain
- !! array by integrating over the wavenumbers in 3-direction.
- !!
- !! The effective traction at x3=0 is
- !!
- !! t_1 = sigma_13
- !! t_2 = sigma_23
- !! t_3 = sigma_33 - r g u3
- !! = sigma_33 - 2 mu alpha gamma u3
- !!
- !! \author sylvain barbot (07-07-07) - original form
- !---------------------------------------------------------------------
- SUBROUTINE surfacetractioncowling(lambda,mu,gamma,u1,u2,u3,dx1,dx2,dx3, &
- p1,p2,p3)
- REAL*4, INTENT(IN), DIMENSION(:,:,:) :: u1,u2,u3
- REAL*8, INTENT(IN) :: lambda,mu,gamma,dx1,dx2,dx3
- REAL*4, INTENT(OUT), DIMENSION(:,:) :: p1,p2,p3
-
- INTEGER :: i1,i2,i3,sx1,sx2,sx3
- REAL*8 :: k1,k2,k3,modulus,alpha,grav
- COMPLEX*8, PARAMETER :: i=CMPLX(0._8,pi2)
- COMPLEX*8 :: sum1,sum2,sum3,c1,c2,c3
-
- sx1=SIZE(u1,1)-2
- sx2=SIZE(u1,2)
- sx3=SIZE(u1,3)
-
- modulus=lambda+2._8*mu
- alpha=(lambda+mu)/(lambda+2._8*mu)
- grav=2._8*mu*alpha*gamma
-
- p1=0
- p2=0
- p3=0
-
-!$omp parallel do private(i1,i3,k1,k2,k3,c1,c2,c3,sum1,sum2,sum3)
-!!!$omp reduction(+:p1,p2,p3)
- DO i2=1,sx2
- DO i3=1,sx3
- DO i1=1,sx1/2+1
- CALL wavenumbers(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,k1,k2,k3)
-
- c1=CMPLX(u1(2*i1-1,i2,i3),u1(2*i1,i2,i3))
- c2=CMPLX(u2(2*i1-1,i2,i3),u2(2*i1,i2,i3))
- c3=CMPLX(u3(2*i1-1,i2,i3),u3(2*i1,i2,i3))
-
- sum1=i*mu*(k3*c1+k1*c3)
- sum2=i*mu*(k3*c2+k2*c3)
- sum3=i*(modulus*k3*c3+lambda*(k1*c1+k2*c2))-grav*c3
-
- p1(2*i1-1:2*i1,i2)=p1(2*i1-1:2*i1,i2)+(/REAL(sum1),AIMAG(sum1)/)
- p2(2*i1-1:2*i1,i2)=p2(2*i1-1:2*i1,i2)+(/REAL(sum2),AIMAG(sum2)/)
- p3(2*i1-1:2*i1,i2)=p3(2*i1-1:2*i1,i2)+(/REAL(sum3),AIMAG(sum3)/)
- END DO
- END DO
- END DO
-!$omp end parallel do
-
- p1=p1/(sx3*dx3)
- p2=p2/(sx3*dx3)
- p3=p3/(sx3*dx3)
-
- END SUBROUTINE surfacetractioncowling
-
- !---------------------------------------------------------------------
- !> subroutine Cerruti3D
- !! computes the deformation field in the 3-dimensional grid
- !! due to an arbitrary surface traction.
- !!
- !! \author sylvain barbot (07/07/07) - original form
- ! (02/01/09) - parallelized with MPI and OpenMP
- ! (01/06/11) - remove parallelized version with MPI
- !---------------------------------------------------------------------
- SUBROUTINE cerruti3d(p1,p2,p3,lambda,mu,u1,u2,u3,dx1,dx2,dx3)
- REAL*4, DIMENSION(:,:), INTENT(IN) :: p1,p2,p3
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: u1,u2,u3
- REAL*8, INTENT(IN) :: lambda,mu,dx1,dx2,dx3
-
- INTEGER :: i1,i2,i3,ib,sx1,sx2,sx3,iostatus,buffersize
- REAL*8 :: k1,k2,k3,x3,alpha
- COMPLEX(KIND=4) :: t1,t2,t3
- INTEGER, PARAMETER :: stride=64
- COMPLEX(KIND=4), ALLOCATABLE, DIMENSION(:,:) :: b1,b2,b3
-
- sx1=SIZE(u1,1)-2
- sx2=SIZE(u1,2)
- sx3=SIZE(u1,3)
-
- alpha=(lambda+mu)/(lambda+2*mu)
-
- ! serial programmation implementation
-!$omp parallel private(b1,b2,b3,iostatus)
-
- ALLOCATE(b1(sx3,stride),b2(sx3,stride),b3(sx3,stride),STAT=iostatus)
- IF (0/=iostatus) STOP "could not allocate arrays for Cerruti3D"
-
-!$omp do private(i1,i3,ib,k1,k2,k3,t1,t2,t3,x3,buffersize)
- DO i2=1,sx2
- DO i1=1,sx1/2+1,stride
-
- ! buffer results
- IF (i1+stride-1 .GT. sx1/2+1) THEN
- buffersize=sx1/2+1-i1+1
- ELSE
- buffersize=stride
- END IF
-
- DO ib=0,buffersize-1
-
- CALL wavenumbers(i1+ib,i2,1,sx1,sx2,1,dx1,dx2,1._8,k1,k2,k3)
- t1=CMPLX(p1(2*(i1+ib)-1,i2),p1(2*(i1+ib),i2),4)
- t2=CMPLX(p2(2*(i1+ib)-1,i2),p2(2*(i1+ib),i2),4)
- t3=CMPLX(p3(2*(i1+ib)-1,i2),p3(2*(i1+ib),i2),4)
-
- DO i3=1,sx3
- IF (i3<=sx3/2) THEN
- x3=DBLE(i3-1)*dx3
- ELSE
- x3=ABS(DBLE(i3-sx3-1)*dx3)
- END IF
- CALL cerrutisolution(mu,t1,t2,t3,alpha,b1(i3,ib+1),b2(i3,ib+1),b3(i3,ib+1),k1,k2,x3)
- END DO
-
- ! transforms the Cerruti solution into a full 3-dimensional
- ! Fourier transform by 1d transforming in the 3-direction
- CALL fft1(b1(:,ib+1),sx3,dx3,FFT_FORWARD)
- CALL fft1(b2(:,ib+1),sx3,dx3,FFT_FORWARD)
- CALL fft1(b3(:,ib+1),sx3,dx3,FFT_FORWARD)
-
- END DO
-
- ! update solution displacement
- DO i3=1,sx3
- DO ib=0,buffersize-1
- u1(2*(i1+ib)-1,i2,i3)=u1(2*(i1+ib)-1,i2,i3)+REAL( REAL(b1(i3,ib+1)))
- u1(2*(i1+ib) ,i2,i3)=u1(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b1(i3,ib+1)))
- u2(2*(i1+ib)-1,i2,i3)=u2(2*(i1+ib)-1,i2,i3)+REAL( REAL(b2(i3,ib+1)))
- u2(2*(i1+ib) ,i2,i3)=u2(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b2(i3,ib+1)))
- u3(2*(i1+ib)-1,i2,i3)=u3(2*(i1+ib)-1,i2,i3)+REAL( REAL(b3(i3,ib+1)))
- u3(2*(i1+ib) ,i2,i3)=u3(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b3(i3,ib+1)))
- END DO
- END DO
-
- END DO
- END DO
-
- DEALLOCATE(b1,b2,b3)
-!$omp end parallel
-
- CONTAINS
- !-----------------------------------------------------------------
- !> subroutine CerrutiSolution
- !! computes the general solution for the deformation field in an
- !! elastic half-space due to an arbitrary surface traction.
- !! the 3 components u1, u2, u3 of the deformation field are
- !! expressed in the horizontal Fourier at depth x3.
- !! this combines the solution to the Boussinesq's and the Cerruti's
- !! problem in a half-space.
- !!
- !! \author sylvain barbot (07-07-07) - original form
- !-----------------------------------------------------------------
- SUBROUTINE cerrutisolution(mu,p1,p2,p3,alpha,u1,u2,u3,k1,k2,x3)
- COMPLEX(KIND=4), INTENT(INOUT) :: u1,u2,u3
- REAL*8, INTENT(IN) :: mu,alpha,k1,k2,x3
- COMPLEX(KIND=4), INTENT(IN) :: p1,p2,p3
-
- REAL*8 :: beta, depthdecay
- COMPLEX(KIND=8), PARAMETER :: i=CMPLX(0._8,pi2,8)
- REAL*8 :: temp
- COMPLEX(KIND=8) :: b1,b2,b3,tmp,v1,v2,v3
-
- beta=pi2*sqrt(k1**2+k2**2)
- depthdecay=exp(-beta*abs(x3))
-
- IF (0==k1 .AND. 0==k2) THEN
- u1=CMPLX(0._4,0._4,4)
- u2=CMPLX(0._4,0._4,4)
- u3=CMPLX(0._4,0._4,4)
- ELSE
- temp=1._8/(2._8*mu*beta**3)*depthdecay
- b1=temp*p1
- b2=temp*p2
- b3=temp*p3
-
- ! b3 contribution
- tmp=i*b3*(beta*(1._8-1._8/alpha+beta*x3))
- v1=tmp*k1
- v2=tmp*k2
- v3=-beta**2*b3*(1._8/alpha+beta*x3)
-
- ! b1 contribution
- temp=pi2**2*(2._8-1._8/alpha+beta*x3)
- v1=v1+b1*(-2._8*beta**2+k1**2*temp)
- v2=v2+b1*k1*k2*temp
- v3=v3+b1*i*k1*beta*(1._8/alpha-1._8+beta*x3)
-
- ! b2 contribution & switch to single-precision
- u1=v1+b2*k1*k2*temp
- u2=v2+b2*(-2._8*beta**2+k2**2*temp)
- u3=v3+b2*i*k2*beta*(1._8/alpha-1._8+beta*x3)
- END IF
-
- END SUBROUTINE cerrutisolution
- END SUBROUTINE cerruti3d
-
- !---------------------------------------------------------------------
- !> subroutine CerrutiCowling
- !! computes the deformation field in the 3-dimensional grid
- !! due to an arbitrary surface traction.
- !!
- !! \author sylvain barbot - (07/07/07) - original form
- !! (21/11/08) - gravity effect
- !! (02/01/09) - parallelized with MPI and OpenMP
- !! (01/06/11) - remove parallelized version with MPI
- !---------------------------------------------------------------------
- SUBROUTINE cerruticowling(p1,p2,p3,lambda,mu,gamma,u1,u2,u3,dx1,dx2,dx3)
- REAL*4, DIMENSION(:,:), INTENT(IN) :: p1,p2,p3
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: u1,u2,u3
- REAL*8, INTENT(IN) :: lambda,mu,gamma,dx1,dx2,dx3
-
- INTEGER :: i1,i2,i3,ib,sx1,sx2,sx3,iostatus,buffersize
- REAL*8 :: k1,k2,k3,x3,alpha
- COMPLEX(KIND=4) :: t1,t2,t3
- INTEGER, PARAMETER :: stride=64
- COMPLEX(KIND=4), ALLOCATABLE, DIMENSION(:,:) :: b1,b2,b3
-
- sx1=SIZE(u1,1)-2
- sx2=SIZE(u1,2)
- sx3=SIZE(u1,3)
-
- alpha=(lambda+mu)/(lambda+2*mu)
-
- ! serial programmation implementation
-!$omp parallel private(b1,b2,b3,iostatus)
-
- ALLOCATE(b1(sx3,stride),b2(sx3,stride),b3(sx3,stride),STAT=iostatus)
- IF (0/=iostatus) STOP "could not allocate arrays for Cerruti3D"
-
-!$omp do private(i1,i3,ib,k1,k2,k3,t1,t2,t3,x3,buffersize)
- DO i2=1,sx2
- DO i1=1,sx1/2+1,stride
-
- ! buffer results
- IF (i1+stride-1 .GT. sx1/2+1) THEN
- buffersize=sx1/2+1-i1+1
- ELSE
- buffersize=stride
- END IF
-
- DO ib=0,buffersize-1
-
- CALL wavenumbers(i1+ib,i2,1,sx1,sx2,1,dx1,dx2,1._8,k1,k2,k3)
- t1=CMPLX(p1(2*(i1+ib)-1,i2),p1(2*(i1+ib),i2),4)
- t2=CMPLX(p2(2*(i1+ib)-1,i2),p2(2*(i1+ib),i2),4)
- t3=CMPLX(p3(2*(i1+ib)-1,i2),p3(2*(i1+ib),i2),4)
-
- DO i3=1,sx3
- IF (i3<=sx3/2) THEN
- x3=DBLE(i3-1)*dx3
- ELSE
- x3=ABS(DBLE(i3-sx3-1)*dx3)
- END IF
- CALL cerrutisolcowling(mu,t1,t2,t3,alpha,gamma, &
- b1(i3,ib+1),b2(i3,ib+1),b3(i3,ib+1),k1,k2,x3,DBLE(sx3/2)*dx3)
- END DO
-
- ! transforms the Cerruti solution into a full 3-dimensional
- ! Fourier transform by 1d transforming in the 3-direction
- CALL fft1(b1(:,ib+1),sx3,dx3,FFT_FORWARD)
- CALL fft1(b2(:,ib+1),sx3,dx3,FFT_FORWARD)
- CALL fft1(b3(:,ib+1),sx3,dx3,FFT_FORWARD)
-
- END DO
-
- ! update solution displacement
- DO i3=1,sx3
- DO ib=0,buffersize-1
- u1(2*(i1+ib)-1,i2,i3)=u1(2*(i1+ib)-1,i2,i3)+REAL( REAL(b1(i3,ib+1)))
- u1(2*(i1+ib) ,i2,i3)=u1(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b1(i3,ib+1)))
- u2(2*(i1+ib)-1,i2,i3)=u2(2*(i1+ib)-1,i2,i3)+REAL( REAL(b2(i3,ib+1)))
- u2(2*(i1+ib) ,i2,i3)=u2(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b2(i3,ib+1)))
- u3(2*(i1+ib)-1,i2,i3)=u3(2*(i1+ib)-1,i2,i3)+REAL( REAL(b3(i3,ib+1)))
- u3(2*(i1+ib) ,i2,i3)=u3(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b3(i3,ib+1)))
- END DO
- END DO
-
- END DO
- END DO
-
- DEALLOCATE(b1,b2,b3)
-!$omp end parallel
-
- CONTAINS
-
- !-----------------------------------------------------------------
- !> subroutine CerrutiSolCowling
- !! computes the general solution for the deformation field in an
- !! elastic half-space due to an arbitrary surface traction in the
- !! presence of gravity.
- !!
- !! The 3 components u1, u2 and u3 of the deformation field are
- !! expressed in the horizontal Fourier at depth x3.
- !!
- !! Combines the solution to the Boussinesq's and the Cerruti's
- !! problem in a half-space with buoyancy boundary conditions.
- !
- ! sylvain barbot (07-07-07) - original form
- ! (08-30-10) - account for net surface traction
- !-----------------------------------------------------------------
- SUBROUTINE cerrutisolcowling(mu,p1,p2,p3,alpha,gamma,u1,u2,u3,k1,k2,x3,L)
- COMPLEX(KIND=4), INTENT(INOUT) :: u1,u2,u3
- REAL*8, INTENT(IN) :: mu,alpha,gamma,k1,k2,x3,L
- COMPLEX(KIND=4), INTENT(IN) :: p1,p2,p3
-
- REAL*8 :: beta, depthdecay, h
- COMPLEX(KIND=8), PARAMETER :: i=CMPLX(0._8,pi2)
- REAL*8 :: temp
- COMPLEX(KIND=8) :: b1,b2,b3,tmp,v1,v2,v3
-
- beta=pi2*sqrt(k1**2+k2**2)
- depthdecay=exp(-beta*abs(x3))
- h=gamma/beta
-
- IF (0==k1 .AND. 0==k2) THEN
- ! the 1/3 ratio is ad hoc
- u1=CMPLX(REAL(+p1/mu*(x3-L)/3.d0),0._4)
- u2=CMPLX(REAL(+p2/mu*(x3-L)/3.d0),0._4)
- u3=CMPLX(REAL(+p3/mu*(x3-L)*(alpha-1.d0)/(1.d0+2.d0*L*alpha*gamma*(1.d0-alpha))/3.d0),0._4)
- !u1=CMPLX(0._4,0._4)
- !u2=CMPLX(0._4,0._4)
- !u3=CMPLX(0._4,0._4)
- ELSE
- temp=1._8/(2._8*mu*beta**3)*depthdecay
- b1=temp*p1
- b2=temp*p2
- b3=temp*p3/(1+h)
-
- ! b3 contribution
- tmp=i*b3*(beta*(1._8-1._8/alpha+beta*x3))
- v1=tmp*k1
- v2=tmp*k2
- v3=-beta**2*b3*(1._8/alpha+beta*x3)
-
- ! b1 contribution
- temp=pi2**2*(2._8-1._8/alpha+beta*x3)/(1+h)
- v1=v1+b1*(-2._8*beta**2+k1**2*temp)
- v2=v2+b1*k1*k2*temp
- v3=v3+b1*i*k1*beta*(1._8/alpha-1._8+beta*x3)/(1+h)
-
- ! b2 contribution & switch to single-precision
- u1=v1+b2*k1*k2*temp
- u2=v2+b2*(-2._8*beta**2+k2**2*temp)
- u3=v3+b2*i*k2*beta*(1._8/alpha-1._8+beta*x3)/(1+h)
- END IF
-
- END SUBROUTINE cerrutisolcowling
-
- END SUBROUTINE cerruticowling
-
- !---------------------------------------------------------------------
- !> subroutine CerrutiCowlingSerial
- !! computes the deformation field in the 3-dimensional grid
- !! due to an arbitrary surface traction. No parallel version.
- !
- ! sylvain barbot - 07/07/07 - original form
- ! 21/11/08 - gravity effect
- !---------------------------------------------------------------------
- SUBROUTINE cerruticowlingserial(p1,p2,p3,lambda,mu,gamma,u1,u2,u3,dx1,dx2,dx3)
- REAL*4, DIMENSION(:,:), INTENT(IN) :: p1,p2,p3
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: u1,u2,u3
- REAL*8, INTENT(IN) :: lambda,mu,gamma,dx1,dx2,dx3
-
- INTEGER :: i1,i2,i3,sx1,sx2,sx3,status
- REAL*8 :: k1,k2,k3,x3,alpha
- COMPLEX(KIND=4), ALLOCATABLE, DIMENSION(:) :: b1,b2,b3
- COMPLEX(KIND=4) :: t1,t2,t3
-
- sx1=SIZE(u1,1)-2
- sx2=SIZE(u1,2)
- sx3=SIZE(u1,3)
-
- ALLOCATE(b1(sx3),b2(sx3),b3(sx3),STAT=status)
- IF (0/=status) STOP "could not allocate arrays for Cerruti3D"
-
- alpha=(lambda+mu)/(lambda+2*mu)
-
- DO i2=1,sx2
- DO i1=1,sx1/2+1
- CALL wavenumbers(i1,i2,1,sx1,sx2,1,dx1,dx2,1._8,k1,k2,k3)
- t1=CMPLX(p1(2*i1-1,i2),p1(2*i1,i2))
- t2=CMPLX(p2(2*i1-1,i2),p2(2*i1,i2))
- t3=CMPLX(p3(2*i1-1,i2),p3(2*i1,i2))
- DO i3=1,sx3
- IF (i3<=sx3/2) THEN
- x3=DBLE(i3-1)*dx3
- ELSE
- x3=ABS(DBLE(i3-sx3-1)*dx3)
- END IF
- CALL cerrutisolcowling(t1,t2,t3,alpha,gamma, &
- b1(i3),b2(i3),b3(i3),k1,k2,x3)
- END DO
-
- ! transforms the Cerruti solution into a full 3-dimensional
- ! Fourier transform by 1d transforming in the 3-direction
- CALL fft1(b1,sx3,dx3,FFT_FORWARD)
- CALL fft1(b2,sx3,dx3,FFT_FORWARD)
- CALL fft1(b3,sx3,dx3,FFT_FORWARD)
-
- ! add the Cerruti's contribution to the deformation field
- DO i3=1,sx3
- u1(2*i1-1,i2,i3)=u1(2*i1-1,i2,i3)+REAL( REAL(b1(i3)))
- u1(2*i1 ,i2,i3)=u1(2*i1 ,i2,i3)+REAL(AIMAG(b1(i3)))
- u2(2*i1-1,i2,i3)=u2(2*i1-1,i2,i3)+REAL( REAL(b2(i3)))
- u2(2*i1 ,i2,i3)=u2(2*i1 ,i2,i3)+REAL(AIMAG(b2(i3)))
- u3(2*i1-1,i2,i3)=u3(2*i1-1,i2,i3)+REAL( REAL(b3(i3)))
- u3(2*i1 ,i2,i3)=u3(2*i1 ,i2,i3)+REAL(AIMAG(b3(i3)))
- END DO
- END DO
- END DO
-
- CONTAINS
- !-----------------------------------------------------------------
- !> subroutine CerrutiSolCowling
- !! computes the general solution for the deformation field in an
- !! elastic half-space due to an arbitrary surface traction in the
- !! presence of gravity.
- !!
- !! The 3 components u1, u2 and u3 of the deformation field are
- !! expressed in the horizontal Fourier at depth x3.
- !!
- !! Combines the solution to the Boussinesq's and the Cerruti's
- !! problem in a half-space with buoyancy boundary conditions.
- !
- ! sylvain barbot (07-07-07) - original form
- !-----------------------------------------------------------------
- SUBROUTINE cerrutisolcowling(p1,p2,p3,alpha,gamma,u1,u2,u3,k1,k2,x3)
- COMPLEX(KIND=4), INTENT(INOUT) :: u1,u2,u3
- REAL*8, INTENT(IN) :: alpha,gamma,k1,k2,x3
- COMPLEX(KIND=4), INTENT(IN) :: p1,p2,p3
-
- REAL*8 :: beta, depthdecay, h
- COMPLEX(KIND=8), PARAMETER :: i=CMPLX(0._8,pi2)
- REAL*8 :: temp
- COMPLEX(KIND=8) :: b1,b2,b3,tmp,v1,v2,v3
-
- beta=pi2*sqrt(k1**2+k2**2)
- depthdecay=exp(-beta*abs(x3))
- h=gamma/beta
-
- IF (0==k1 .AND. 0==k2) THEN
- u1=CMPLX(0._4,0._4)
- u2=CMPLX(0._4,0._4)
- u3=CMPLX(0._4,0._4)
- ELSE
- temp=1._8/(2._8*mu*beta**3)*depthdecay
- b1=temp*p1
- b2=temp*p2
- b3=temp*p3/(1+h)
-
- ! b3 contribution
- tmp=i*b3*(beta*(1._8-1._8/alpha+beta*x3))
- v1=tmp*k1
- v2=tmp*k2
- v3=-beta**2*b3*(1._8/alpha+beta*x3)
-
- ! b1 contribution
- temp=pi2**2*(2._8-1._8/alpha+beta*x3)/(1+h)
- v1=v1+b1*(-2._8*beta**2+k1**2*temp)
- v2=v2+b1*k1*k2*temp
- v3=v3+b1*i*k1*beta*(1._8/alpha-1._8+beta*x3)/(1+h)
-
- ! b2 contribution & switch to single-precision
- u1=v1+b2*k1*k2*temp
- u2=v2+b2*(-2._8*beta**2+k2**2*temp)
- u3=v3+b2*i*k2*beta*(1._8/alpha-1._8+beta*x3)/(1+h)
- END IF
-
- END SUBROUTINE cerrutisolcowling
-
- END SUBROUTINE cerruticowlingserial
-
- !------------------------------------------------------------------
- !> subroutine GreenFunction
- !! computes (inplace) the displacement components due to a set of
- !! 3-D body-forces by application of the semi-analytic Green's
- !! function. The solution satisfies quasi-static Navier's equation
- !! including vanishing of normal traction at the surface.
- !!
- !! The surface traction can be made to vanish by application of
- !! 1) method of images + boussinesq problem (grn_method=GRN_IMAGE)
- !! 2) boussinesq's and cerruti's problems (grn_method=GRN_HS)
- !! in the first case, the body-forces are supposed by have been
- !! imaged appropriately.
- !
- ! sylvain barbot (07/07/07) - original form
- !------------------------------------------------------------------
- SUBROUTINE greenfunction(c1,c2,c3,t1,t2,t3,dx1,dx2,dx3,lambda,mu,grn_method)
- REAL*4, INTENT(INOUT), DIMENSION(:,:,:) :: c1,c2,c3
- REAL*4, INTENT(INOUT), DIMENSION(:,:) :: t1,t2,t3
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- REAL*8, INTENT(IN) :: lambda,mu
- INTEGER, INTENT(IN) :: grn_method
-
- INTEGER :: sx1,sx2,sx3,status
-
- REAL*4, DIMENSION(:,:), ALLOCATABLE :: p1,p2,p3
-
- sx1=SIZE(c1,1)-2
- sx2=SIZE(c1,2)
- sx3=SIZE(c1,3)
-
- ALLOCATE(p1(sx1+2,sx2),p2(sx1+2,sx2),p3(sx1+2,sx2),STAT=status)
- IF (status > 0) THEN
- WRITE_DEBUG_INFO
- WRITE(0,'("could not allocate memory for green function")')
- STOP 1
- ELSE
- p1=0;p2=0;p3=0;
- END IF
-
- ! forward Fourier transform equivalent body-force
- CALL fft3(c1,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
- CALL fft3(c2,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
- CALL fft3(c3,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
- CALL fft2(t1,sx1,sx2,dx1,dx2,FFT_FORWARD)
- CALL fft2(t2,sx1,sx2,dx1,dx2,FFT_FORWARD)
- CALL fft2(t3,sx1,sx2,dx1,dx2,FFT_FORWARD)
-
- ! solve for displacement field
- CALL elasticresponse(lambda,mu,c1,c2,c3,dx1,dx2,dx3)
- IF (GRN_IMAGE .eq. grn_method) THEN
- CALL surfacenormaltraction(lambda,mu,c1,c2,c3,dx1,dx2,dx3,p3)
- p3=t3-p3
- CALL boussinesq3d(p3,lambda,mu,c1,c2,c3,dx1,dx2,dx3)
- ELSE
- CALL surfacetraction(lambda,mu,c1,c2,c3,dx1,dx2,dx3,p1,p2,p3)
- p1=t1-p1
- p2=t2-p2
- p3=t3-p3
- CALL cerruti3d(p1,p2,p3,lambda,mu,c1,c2,c3,dx1,dx2,dx3)
- END IF
-
- ! inverse Fourier transform solution displacement components
- CALL fft3(c1,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
- CALL fft3(c2,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
- CALL fft3(c3,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
- CALL fft2(t1,sx1,sx2,dx1,dx2,FFT_INVERSE)
- CALL fft2(t2,sx1,sx2,dx1,dx2,FFT_INVERSE)
- CALL fft2(t3,sx1,sx2,dx1,dx2,FFT_INVERSE)
-
- DEALLOCATE(p1,p2,p3)
-
- END SUBROUTINE greenfunction
-
- !------------------------------------------------------------------
- !> subroutine GreensFunctionCowling
- !! computes (inplace) the displacement components due to a set of
- !! 3-D body-forces by application of the semi-analytic Green's
- !! function. The solution satisfies quasi-static Navier's equation
- !! with buoyancy boundary condition to simulate the effect of
- !! gravity (the Cowling approximation).
- !!
- !! the importance of gravity depends upon the density contrast rho
- !! at the surface, the acceleration of gravity g and the value of
- !! shear modulus mu in the crust. effect on the displacement field
- !! is governed by the gradient
- !!
- !! gamma = (1 - nu) rho g / mu
- !! = rho g / (2 mu alpha)
- !!
- !! where nu is the Poisson's ratio. For a Poisson's solid with
- !! nu = 1/4, with a density contrast rho = 3200 kg/m^3 and a shear
- !! modulus mu = 30 GPa, we have gamma = 0.8e-6 /m.
- !!
- !! INPUT:
- !! @param c1,c2,c3 is a set of body forces
- !! @param dx1,dx2,dx3 are the sampling size
- !! @param lambda,mu are the Lame elastic parameters
- !! @param gamma is the gravity coefficient
- !
- ! sylvain barbot (07/07/07) - original function greenfunction
- ! (11/21/08) - effect of gravity
- !------------------------------------------------------------------
- SUBROUTINE greenfunctioncowling(c1,c2,c3,t1,t2,t3,dx1,dx2,dx3, &
- lambda,mu,gamma)
- REAL*4, INTENT(INOUT), DIMENSION(:,:,:) :: c1,c2,c3
- REAL*4, INTENT(INOUT), DIMENSION(:,:) :: t1,t2,t3
- REAL*8, INTENT(IN) :: dx1,dx2,dx3
- REAL*8, INTENT(IN) :: lambda,mu,gamma
-
- INTEGER :: sx1,sx2,sx3,status
-
- REAL*4, DIMENSION(:,:), ALLOCATABLE :: p1,p2,p3
-
- sx1=SIZE(c1,1)-2
- sx2=SIZE(c1,2)
- sx3=SIZE(c1,3)
-
- ALLOCATE(p1(sx1+2,sx2),p2(sx1+2,sx2),p3(sx1+2,sx2),STAT=status)
- IF (status > 0) THEN
- WRITE_DEBUG_INFO
- WRITE(0,'("could not allocate memory for green function")')
- STOP 1
- ELSE
- p1=0;p2=0;p3=0;
- END IF
-
- ! forward Fourier transform equivalent body-force
- CALL fft3(c1,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
- CALL fft3(c2,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
- CALL fft3(c3,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
- CALL fft2(t1,sx1,sx2,dx1,dx2,FFT_FORWARD)
- CALL fft2(t2,sx1,sx2,dx1,dx2,FFT_FORWARD)
- CALL fft2(t3,sx1,sx2,dx1,dx2,FFT_FORWARD)
-
- ! solve for displacement field
- CALL elasticresponse(lambda,mu,c1,c2,c3,dx1,dx2,dx3)
-
- CALL surfacetractioncowling(lambda,mu,gamma, &
- c1,c2,c3,dx1,dx2,dx3,p1,p2,p3)
- p1=t1-p1
- p2=t2-p2
- p3=t3-p3
- CALL cerruticowling(p1,p2,p3,lambda,mu,gamma, &
- c1,c2,c3,dx1,dx2,dx3)
-
- ! inverse Fourier transform solution displacement components
- CALL fft3(c1,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
- CALL fft3(c2,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
- CALL fft3(c3,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
- CALL fft2(t1,sx1,sx2,dx1,dx2,FFT_INVERSE)
- CALL fft2(t2,sx1,sx2,dx1,dx2,FFT_INVERSE)
- CALL fft2(t3,sx1,sx2,dx1,dx2,FFT_INVERSE)
-
- DEALLOCATE(p1,p2,p3)
-
- END SUBROUTINE greenfunctioncowling
-
-END MODULE green
diff -r 405d8f4fa05f -r e7295294f654 include.f90
--- a/include.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,59 +0,0 @@
-#include "config.h"
-
-! implement SGI Fast Fourier Transforms library
-!#define SGI_FFT 1
-
-! export data to GMT XYZ text format
-!#define XYZ 1
-
-! export data to GMT GRD binary format
-#define GRD 1
-
-! export equivalent body forces in GRD format
-!#define GRD_EQBF 1
-
-! export amplitude of scalar fields
-! along a plane in GRD binary format
-#define GRD_EXPORTEIGENSTRAIN 1
-
-! export creep velocity along a frictional
-! plane in GRD binary format
-#define GRD_EXPORTCREEP 1
-
-! export data to the TXT format
-!#define TXT 1
-
-! export data to longitude/latitude format
-#define PROJ 1
-
-! export amplitude of scalar fields along
-! an observation plane in text format
-#define TXT_EXPORTEIGENSTRAIN 1
-
-! export creep velocity along a frictional
-! plane in text format
-!#define TXT_EXPORTCREEP 1
-
-! export data to VTK format (for visualization in Paraview)
-#define VTK 1
-!#define VTK_EQBF 1
-
-#define WRITE_DEBUG_INFO WRITE (0,'("error at line ",I5.5," of source file ",a)') __LINE__,__FILE__
-
-
-#ifdef IMKL_FFT
-#define WRITE_MKL_DEBUG_INFO(i) IF(i.NE.0)THEN;IF(.NOT.DftiErrorClass(i,DFTI_NO_ERROR))THEN;WRITE_DEBUG_INFO;WRITE (0,*) DftiErrorMessage(i);STOP 1;END IF;END IF
-#endif
-
-! adjust data alignment for the Fourier transform
-#ifdef FFTW3
-#define ALIGN_DATA 1
-#else
-#ifdef SGI_FFT
-#define ALIGN_DATA 1
-#else
-#ifdef IMKL_FFT
-#define ALIGN_DATA 1
-#endif
-#endif
-#endif
diff -r 405d8f4fa05f -r e7295294f654 input.f90
--- a/input.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1368 +0,0 @@
-!-----------------------------------------------------------------------
-! Copyright 2007, 2008, 2009 Sylvain Barbot
-!
-! This file is part of RELAX
-!
-! RELAX 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 3 of the License, or
-! (at your option) any later version.
-!
-! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
-!-----------------------------------------------------------------------
-
-#include "include.f90"
-
-MODULE input
-
- IMPLICIT NONE
-
- REAL*8, PARAMETER :: DEG2RAD = 0.01745329251994329547437168059786927_8
-
-CONTAINS
-
- !---------------------------------------------------------------------
- !> subroutine init
- !! reads simulation parameters from the standard input and initialize
- !! model parameters.
- !!
- !! INPUT:
- !! @param unit - the unit number used to read input data
- !!
- !! OUTPUT:
- !! @param in
- !---------------------------------------------------------------------
- SUBROUTINE init(in,unit)
- USE types
- USE export
- USE getopt_m
-
- TYPE(SIMULATION_STRUC), INTENT(OUT) :: in
- INTEGER, OPTIONAL, INTENT(INOUT) :: unit
-
- CHARACTER :: ch
- CHARACTER(180) :: dataline
- CHARACTER(80) :: rffilename,filename
-#ifdef VTK
- CHARACTER(3) :: digit
- CHARACTER(4) :: digit4
-#endif
- INTEGER :: iunit
-!$ INTEGER :: omp_get_num_procs,omp_get_max_threads
- REAL*8 :: dummy,dum1,dum2
- REAL*8 :: minlength,minwidth
- TYPE(OPTION_S) :: opts(12)
-
- INTEGER :: k,iostatus,i,e
-
- ! default is standard input
- IF (.NOT. PRESENT(unit)) THEN
- iunit=5
- ELSE
- iunit=unit
- END IF
-
- ! parse the command line for options
- opts( 1)=OPTION_S("no-proj-output",.FALSE.,CHAR(20))
- opts( 2)=OPTION_S("no-relax-output",.FALSE.,CHAR(21))
- opts( 3)=OPTION_S("no-txt-output",.FALSE.,CHAR(22))
- opts( 4)=OPTION_S("no-vtk-output",.FALSE.,CHAR(23))
- opts( 5)=OPTION_S("no-grd-output",.FALSE.,CHAR(24))
- opts( 6)=OPTION_S("no-xyz-output",.FALSE.,CHAR(25))
- opts( 7)=OPTION_S("no-stress-output",.FALSE.,CHAR(26))
- opts( 8)=OPTION_S("with-stress-output",.FALSE.,CHAR(27))
- opts( 9)=OPTION_S("with-vtk-output",.FALSE.,CHAR(28))
- opts(10)=OPTION_S("with-vtk-relax-output",.FALSE.,CHAR(29))
- opts(11)=OPTION_S("dry-run",.FALSE.,CHAR(30))
- opts(12)=OPTION_S("help",.FALSE.,'h')
-
- DO
- ch=getopt("h",opts)
- SELECT CASE(ch)
- CASE(CHAR(0))
- EXIT
- CASE(CHAR(20))
- ! option no-proj-output
- in%isoutputproj=.FALSE.
- CASE(CHAR(21))
- ! option no-relax-output
- in%isoutputrelax=.FALSE.
- CASE(CHAR(22))
- ! option no-txt-output
- in%isoutputtxt=.FALSE.
- CASE(CHAR(23))
- ! option no-vtk-output
- in%isoutputvtk=.FALSE.
- CASE(CHAR(24))
- ! option no-grd-output
- in%isoutputgrd=.FALSE.
- CASE(CHAR(25))
- ! option no-xyz-output
- in%isoutputxyz=.FALSE.
- CASE(CHAR(26))
- ! option stress output
- in%isoutputstress=.FALSE.
- CASE(CHAR(27))
- ! option dry-run
- in%isoutputstress=.TRUE.
- CASE(CHAR(28))
- ! option with-output-vtk
- in%isoutputvtk=.TRUE.
- CASE(CHAR(29))
- ! option with-output-vtk-relax
- in%isoutputvtkrelax=.TRUE.
- CASE(CHAR(30))
- ! option dry-run
- in%isdryrun=.TRUE.
- CASE('h')
- ! option help
- in%ishelp=.TRUE.
- CASE('?')
- WRITE_DEBUG_INFO
- in%ishelp=.TRUE.
- EXIT
- CASE DEFAULT
- WRITE (0,'("unhandled option ", a, " (this is a bug")') optopt
- WRITE_DEBUG_INFO
- STOP 3
- END SELECT
- END DO
-
- IF (in%ishelp) THEN
- PRINT '("usage:")'
- PRINT '("relax [-h] [--dry-run] [--help] [--no-grd-output] [--no-proj-output]")'
- PRINT '(" [--no-relax-output] [--no-stress-output] [--no-txt-output]")'
- PRINT '(" [--no-vtk-output] [--no-xyz-output]")'
- PRINT '("")'
- PRINT '("options:")'
- PRINT '(" -h prints this message and aborts calculation")'
- PRINT '(" --dry-run abort calculation, only output geometry")'
- PRINT '(" --help prints this message and aborts calculation")'
- PRINT '(" --no-grd-output cancel output in GMT grd binary format")'
- PRINT '(" --no-proj-output cancel output in geographic projection")'
- PRINT '(" --no-relax-output cancel output of the postseismic contribution")'
- PRINT '(" --no-stress-output cancel output of stress tensor in any format")'
- PRINT '(" --no-txt-output cancel output in text format")'
- PRINT '(" --no-vtk-output cancel output in Paraview VTK format")'
- PRINT '(" --no-xyz-output cancel output in GMT xyz format")'
- PRINT '(" --with-stress-output export stress tensor")'
- PRINT '(" --with-vtk-output export output in Paraview VTK format")'
- PRINT '(" --with-vtk-relax-output export relaxation to VTK format")'
- PRINT '("")'
- PRINT '("description:")'
- PRINT '(" Evaluates the deformation due to fault slip, surface loading")'
- PRINT '(" or inflation and the time series of postseismic relaxation")'
- PRINT '(" that follows due to fault creep or viscoelastic flow.")'
- RETURN
- END IF
- PRINT 2000
- PRINT '(" RELAX: nonlinear postseismic relaxation with Fourier-domain Green''s function")'
-#ifdef FFTW3
-#ifdef FFTW3_THREADS
- PRINT '(" * FFTW3 (multi-threaded) implementation of the FFT")'
-#else
- PRINT '(" * FFTW3 implementation of the FFT")'
-#endif
-#else
-#ifdef SGI_FFT
- PRINT '(" * SGI_FFT implementation of the FFT")'
-#else
-#ifdef IMKL_FFT
- PRINT '(" * Intel MKL implementation of the FFT")'
-#else
- PRINT '(" * fourt implementation of the FFT")'
-#endif
-#endif
-#endif
-!$ PRINT '(" * parallel OpenMP implementation with ",I3.3,"/",I3.3," threads")', &
-!$ omp_get_max_threads(),omp_get_num_procs()
-#ifdef PROJ
- IF (in%isoutputproj) THEN
- PRINT '(" * export to longitude/latitude text format")'
- ELSE
- PRINT '(" * export to longitude/latitude text format cancelled (--",a,")")', trim(opts(1)%name)
- END IF
-#endif
-#ifdef TXT
- IF (in%isoutputtxt) THEN
- PRINT '(" * export to TXT format")'
- ELSE
- PRINT '(" * export to TXT format cancelled (--",a,")")', trim(opts(3)%name)
- END IF
-#ifdef GRD
- IF (in%isoutputgrd) THEN
- PRINT '(" * export to GRD format")'
- ELSE
- PRINT '(" * export to GRD format cancelled (--",a,")")', trim(opts(5)%name)
- END IF
-#endif
-#ifdef XYZ
- IF (in%isoutputxyz) THEN
- PRINT '(" * export to XYZ format")'
- ELSE
- PRINT '(" * export to XYZ format cancelled (--",a,")")', trim(opts(6)%name)
- END IF
-#endif
-#endif
-#ifdef VTK
- IF (in%isoutputvtk) THEN
- PRINT '(" * export to VTK format")'
- ELSE
- PRINT '(" * export to VTK format cancelled (--",a,")")', trim(opts(4)%name)
- END IF
- IF (in%isoutputvtkrelax) THEN
- PRINT '(" * export relaxation component to VTK format (--",a,")")', trim(opts(10)%name)
- END IF
-#endif
- PRINT 2000
-
- PRINT '(a)', "grid dimension (sx1,sx2,sx3)"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%sx1,in%sx2,in%sx3
- PRINT '(3I5)', in%sx1,in%sx2,in%sx3
-
- PRINT '(a)', "sampling (dx1,dx2,dx3), smoothing (beta, nyquist)"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%dx1,in%dx2,in%dx3,in%beta,in%nyquist
- PRINT '(5ES9.2E1)', in%dx1,in%dx2,in%dx3,in%beta,in%nyquist
-
- PRINT '(a)', "origin position (x0,y0) and rotation"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%x0,in%y0,in%rot
- PRINT '(3ES9.2E1)', in%x0,in%y0,in%rot
-
-#ifdef PROJ
- IF (in%isoutputproj) THEN
- PRINT '(a)', "geographic origin (longitude, latitude, UTM zone, unit)"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%lon0,in%lat0,in%zone,in%umult
- PRINT '(2ES9.2E1,I3.2,ES9.2E1)',in%lon0,in%lat0,in%zone,in%umult
- IF (in%zone.GT.60 .OR. in%zone.LT.1) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("invalid UTM zone ",I3," (1<=zone<=60. exiting.)")') in%zone
- STOP 1
- END IF
- END IF
-#endif
-
- PRINT '(a)', "observation depth (displacement and stress)"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%oz,in%ozs
- PRINT '(2ES9.2E1)', in%oz,in%ozs
-
- PRINT '(a)', "output directory"
- CALL getdata(iunit,dataline)
- READ (dataline,'(a)') in%wdir
-
- in%reporttimefilename=trim(in%wdir)//"/time.txt"
- in%reportfilename=trim(in%wdir)//"/report.txt"
-#ifdef TXT
- PRINT '(" ",a," (report: ",a,")")', trim(in%wdir),trim(in%reportfilename)
-#else
- PRINT '(" ",a," (time report: ",a,")")', trim(in%wdir),trim(in%reporttimefilename)
-#endif
-
- ! test write permissions on output directory
- OPEN (UNIT=14,FILE=in%reportfilename,POSITION="APPEND",&
- IOSTAT=iostatus,FORM="FORMATTED")
- IF (iostatus>0) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("unable to access ",a)') trim(in%reporttimefilename)
- STOP 1
- END IF
- CLOSE(14)
- ! end test
-
-#ifdef VTK
- filename=trim(in%wdir)//"/cgrid.vtp"
- CALL exportvtk_grid(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3,filename)
-#endif
-
- PRINT '(a)', "lambda, mu, gamma (gamma = (1 - nu) rho g / mu)"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%lambda,in%mu,in%gam
- PRINT '(3ES10.2E2)',in%lambda,in%mu,in%gam
-
- PRINT '(a)', "time interval, (positive time step) or (negative skip, scaling)"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%interval, in%odt
-
- IF (in%odt .LT. 0.) THEN
- READ (dataline,*) dum1, dum2, in%tscale
- in%skip=ceiling(-in%odt)
- PRINT '(ES9.2E1," (output every ",I3.3," steps, dt scaled by ",ES7.2E1,")")', &
- in%interval,in%skip,in%tscale
- ELSE
- PRINT '(ES9.2E1," (output every ",ES9.2E1," time unit)")', in%interval,in%odt
- END IF
-
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! O B S E R V A T I O N P L A N E S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of observation planes"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%nop
- PRINT '(I5)', in%nop
- IF (in%nop .gt. 0) THEN
- ALLOCATE(in%op(in%nop),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the observation plane list"
- PRINT 2000
- PRINT 2100
- PRINT 2000
- DO k=1,in%nop
- CALL getdata(iunit,dataline)
- READ (dataline,*) i,in%op(k)%x,in%op(k)%y,in%op(k)%z,&
- in%op(k)%length,in%op(k)%width,in%op(k)%strike,in%op(k)%dip
-
- PRINT '(I3.3," ",5ES9.2E1,2f7.1)', &
- k,in%op(k)%x,in%op(k)%y,in%op(k)%z, &
- in%op(k)%length,in%op(k)%width,in%op(k)%strike,in%op(k)%dip
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,*) "error in input file: plane index misfit", k,"<>",i
- WRITE (0,*) in%op(k)
- STOP 1
- END IF
-
- ! comply to Wang's convention
- CALL wangconvention(dummy,in%op(k)%x,in%op(k)%y,in%op(k)%z,&
- in%op(k)%length,in%op(k)%width,in%op(k)%strike,in%op(k)%dip, &
- dummy,in%x0,in%y0,in%rot)
-
- END DO
- END IF
-
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! O B S E R V A T I O N P O I N T S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of observation points"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%npts
- PRINT '(I5)', in%npts
- IF (in%npts .gt. 0) THEN
- ALLOCATE(in%opts(in%npts),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the observation point list"
- ALLOCATE(in%ptsname(in%npts),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the list of point name"
-
- PRINT 2000
- PRINT 2300
- PRINT 2000
- DO k=1,in%npts
- CALL getdata(iunit,dataline)
- READ (dataline,*) i,in%ptsname(k),in%opts(k)%v1,in%opts(k)%v2,in%opts(k)%v3
-
- PRINT '(I3.3," ",A4,3ES9.2E1)', i,in%ptsname(k), &
- in%opts(k)%v1,in%opts(k)%v2,in%opts(k)%v3
-
- ! shift and rotate coordinates
- in%opts(k)%v1=in%opts(k)%v1-in%x0
- in%opts(k)%v2=in%opts(k)%v2-in%y0
- CALL rotation(in%opts(k)%v1,in%opts(k)%v2,in%rot)
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: points index misfit")')
- STOP 1
- END IF
- END DO
-
- ! export the lits of observation points for display
- filename=trim(in%wdir)//"/opts.dat"
- CALL exportoptsdat(in%npts,in%opts,in%ptsname,filename)
-
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! C O U L O M B O B S E R V A T I O N S E G M E N T S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of stress observation segments"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%nsop
- PRINT '(I5)', in%nsop
- IF (in%nsop .gt. 0) THEN
- ALLOCATE(in%sop(in%nsop),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the segment list"
- PRINT 2000
- PRINT '(a)',"no. xs ys zs length width strike dip friction"
- PRINT 2000
- DO k=1,in%nsop
- CALL getdata(iunit,dataline)
- READ (dataline,*) i, &
- in%sop(k)%x,in%sop(k)%y,in%sop(k)%z, &
- in%sop(k)%length,in%sop(k)%width, &
- in%sop(k)%strike,in%sop(k)%dip,in%sop(k)%friction
- in%sop(k)%sig0=TENSOR(0.d0,0.d0,0.d0,0.d0,0.d0,0.d0)
-
- PRINT '(I4.4,3ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1)',i, &
- in%sop(k)%x,in%sop(k)%y,in%sop(k)%z, &
- in%sop(k)%length,in%sop(k)%width, &
- in%sop(k)%strike,in%sop(k)%dip, &
- in%sop(k)%friction
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("invalid segment definition ")')
- WRITE (0,'("error in input file: source index misfit")')
- STOP 1
- END IF
- IF (MAX(in%sop(k)%length,in%sop(k)%width) .LE. 0._8) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: length and width must be positive.")')
- STOP 1
- END IF
-
- ! comply to Wang's convention
- CALL wangconvention(dummy, &
- in%sop(k)%x,in%sop(k)%y,in%sop(k)%z, &
- in%sop(k)%length,in%sop(k)%width, &
- in%sop(k)%strike,in%sop(k)%dip, &
- dummy, &
- in%x0,in%y0,in%rot)
- END DO
-
- ! export patches to vtk/vtp
- filename=trim(in%wdir)//"/rfaults-dsigma-0000.vtp"
- CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,filename,convention=1)
-
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! P R E S T R E S S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of prestress interfaces"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%nps
- PRINT '(I5)', in%nps
-
- IF (in%nps .GT. 0) THEN
- ALLOCATE(in%stresslayer(in%nps),in%stressstruc(in%sx3/2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the stress layer structure"
-
- PRINT 2000
- PRINT '(a)', "no. depth sigma11 sigma12 sigma13 sigma22 sigma23 sigma33"
- PRINT 2000
- DO k=1,in%nps
- CALL getdata(iunit,dataline)
- READ (dataline,*) i,in%stresslayer(k)%z, &
- in%stresslayer(k)%t%s11, in%stresslayer(k)%t%s12, &
- in%stresslayer(k)%t%s13, in%stresslayer(k)%t%s22, &
- in%stresslayer(k)%t%s23, in%stresslayer(k)%t%s33
-
- PRINT '(I3.3,7ES9.2E1)', i, &
- in%stresslayer(k)%z, &
- in%stresslayer(k)%t%s11, in%stresslayer(k)%t%s12, &
- in%stresslayer(k)%t%s13, in%stresslayer(k)%t%s22, &
- in%stresslayer(k)%t%s23, in%stresslayer(k)%t%s33
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: index misfit")')
- STOP 1
- END IF
- END DO
- END IF
-
-
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! L I N E A R V I S C O U S I N T E R F A C E
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of linear viscous interfaces"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%nv
- PRINT '(I5)', in%nv
-
- IF (in%nv .GT. 0) THEN
- ALLOCATE(in%linearlayer(in%nv),in%linearstruc(in%sx3/2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the layer structure"
-
- PRINT 2000
- PRINT '(a)', "no. depth gamma0 cohesion"
- PRINT 2000
- DO k=1,in%nv
- CALL getdata(iunit,dataline)
- READ (dataline,*) i,in%linearlayer(k)%z, &
- in%linearlayer(k)%gammadot0, in%linearlayer(k)%cohesion
-
- in%linearlayer(k)%stressexponent=1
-
- PRINT '(I3.3,3ES10.2E2)', i, &
- in%linearlayer(k)%z, &
- in%linearlayer(k)%gammadot0, &
- in%linearlayer(k)%cohesion
-
- ! check positive strain rates
- IF (in%linearlayer(k)%gammadot0 .LT. 0) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: strain rates must be positive")')
- STOP 1
- END IF
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: index misfit")')
- STOP 1
- END IF
-#ifdef VTK
- ! export the viscous layer in VTK format
- WRITE (digit,'(I3.3)') k
-
- rffilename=trim(in%wdir)//"/linearlayer-"//digit//".vtp"
- CALL exportvtk_rectangle(0.d0,0.d0,in%linearlayer(k)%z, &
- DBLE(in%sx1)*in%dx1,DBLE(in%sx2)*in%dx2, &
- 0._8,1.5708d0,rffilename)
-#endif
- END DO
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! L I N E A R W E A K Z O N E S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of linear weak zones"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%nlwz
- PRINT '(I5)', in%nlwz
- IF (in%nlwz .GT. 0) THEN
- ALLOCATE(in%linearweakzone(in%nlwz),in%linearweakzonec(in%nlwz),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the linear weak zones"
- PRINT 2000
- PRINT '(a)', "no. dgammadot0 x1 x2 x3 length width thickn. strike dip"
- PRINT 2000
- DO k=1,in%nlwz
- CALL getdata(iunit,dataline)
- READ (dataline,*) i, &
- in%linearweakzone(k)%dgammadot0, &
- in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z,&
- in%linearweakzone(k)%length,in%linearweakzone(k)%width,in%linearweakzone(k)%thickness, &
- in%linearweakzone(k)%strike,in%linearweakzone(k)%dip
-
- in%linearweakzonec(k)=in%linearweakzone(k)
-
- PRINT '(I3.3,4ES9.2E1,3ES8.2E1,f7.1,f6.1)',k,&
- in%linearweakzone(k)%dgammadot0, &
- in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z, &
- in%linearweakzone(k)%length,in%linearweakzone(k)%width, &
- in%linearweakzone(k)%thickness, &
- in%linearweakzone(k)%strike,in%linearweakzone(k)%dip
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: source index misfit")')
- STOP 1
- END IF
- ! comply to Wang's convention
- CALL wangconvention( &
- dummy, &
- in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z, &
- in%linearweakzone(k)%length,in%linearweakzone(k)%width, &
- in%linearweakzone(k)%strike,in%linearweakzone(k)%dip, &
- dummy,in%x0,in%y0,in%rot)
-
- WRITE (digit,'(I3.3)') k
-
-#ifdef VTK
- ! export the ductile zone in VTK format
- rffilename=trim(in%wdir)//"/weakzone-"//digit//".vtp"
- CALL exportvtk_brick(in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z, &
- in%linearweakzone(k)%length,in%linearweakzone(k)%width,in%linearweakzone(k)%thickness, &
- in%linearweakzone(k)%strike,in%linearweakzone(k)%dip,rffilename)
-#endif
- ! export the ductile zone in GMT .xy format
- rffilename=trim(in%wdir)//"/weakzone-"//digit//".xy"
- CALL exportxy_brick(in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z, &
- in%linearweakzone(k)%length,in%linearweakzone(k)%width,in%linearweakzone(k)%thickness, &
- in%linearweakzone(k)%strike,in%linearweakzone(k)%dip,rffilename)
- END DO
- END IF
- END IF ! end linear viscous
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! N O N L I N E A R V I S C O U S I N T E R F A C E
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of nonlinear viscous interfaces"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%npl
- PRINT '(I5)', in%npl
-
- IF (in%npl .GT. 0) THEN
- ALLOCATE(in%nonlinearlayer(in%npl),in%nonlinearstruc(in%sx3/2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the layer structure"
-
- PRINT 2000
- PRINT '(a)', "no. depth gamma0 power cohesion"
- PRINT 2000
- DO k=1,in%npl
- CALL getdata(iunit,dataline)
-
- READ (dataline,*) i,in%nonlinearlayer(k)%z, &
- in%nonlinearlayer(k)%gammadot0, &
- in%nonlinearlayer(k)%stressexponent, &
- in%nonlinearlayer(k)%cohesion
-
- PRINT '(I3.3,4ES10.2E2)', i, &
- in%nonlinearlayer(k)%z, &
- in%nonlinearlayer(k)%gammadot0, &
- in%nonlinearlayer(k)%stressexponent, &
- in%nonlinearlayer(k)%cohesion
-
- ! check positive strain rates
- IF (in%nonlinearlayer(k)%gammadot0 .LT. 0) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: strain rates must be positive")')
- STOP 1
- END IF
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: index misfit")')
- STOP 1
- END IF
-
-#ifdef VTK
- WRITE (digit,'(I3.3)') k
-
- ! export the viscous layer in VTK format
- rffilename=trim(in%wdir)//"/nonlinearlayer-"//digit//".vtp"
- CALL exportvtk_rectangle(0.d0,0.d0,in%nonlinearlayer(k)%z, &
- DBLE(in%sx1)*in%dx1,DBLE(in%sx2)*in%dx2, &
- 0._8,1.57d0,rffilename)
-#endif
- END DO
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! N O N L I N E A R W E A K Z O N E S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of nonlinear weak zones"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%nnlwz
- PRINT '(I5)', in%nnlwz
- IF (in%nnlwz .GT. 0) THEN
- ALLOCATE(in%nonlinearweakzone(in%nnlwz),in%nonlinearweakzonec(in%nnlwz),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the nonlinear weak zones"
- PRINT 2000
- PRINT '(a)', "no. dgammadot0 x1 x2 x3 length width thickn. strike dip"
- PRINT 2000
- DO k=1,in%nnlwz
- CALL getdata(iunit,dataline)
- READ (dataline,*) i, &
- in%nonlinearweakzone(k)%dgammadot0, &
- in%nonlinearweakzone(k)%x,in%nonlinearweakzone(k)%y,in%nonlinearweakzone(k)%z,&
- in%nonlinearweakzone(k)%length,in%nonlinearweakzone(k)%width,in%nonlinearweakzone(k)%thickness, &
- in%nonlinearweakzone(k)%strike,in%nonlinearweakzone(k)%dip
-
- in%nonlinearweakzonec(k)=in%nonlinearweakzone(k)
-
- PRINT '(I3.3,4ES9.2E1,3ES8.2E1,f7.1,f6.1)',k,&
- in%nonlinearweakzone(k)%dgammadot0, &
- in%nonlinearweakzone(k)%x,in%nonlinearweakzone(k)%y,in%nonlinearweakzone(k)%z, &
- in%nonlinearweakzone(k)%length,in%nonlinearweakzone(k)%width, &
- in%nonlinearweakzone(k)%thickness, &
- in%nonlinearweakzone(k)%strike,in%nonlinearweakzone(k)%dip
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: source index misfit")')
- STOP 1
- END IF
- ! comply to Wang's convention
- CALL wangconvention( &
- dummy, &
- in%nonlinearweakzone(k)%x,in%nonlinearweakzone(k)%y,in%nonlinearweakzone(k)%z, &
- in%nonlinearweakzone(k)%length,in%nonlinearweakzone(k)%width, &
- in%nonlinearweakzone(k)%strike,in%nonlinearweakzone(k)%dip, &
- dummy,in%x0,in%y0,in%rot)
-
- WRITE (digit,'(I3.3)') k
-
-#ifdef VTK
- ! export the ductile zone in VTK format
- rffilename=trim(in%wdir)//"/weakzone-nl-"//digit//".vtp"
- CALL exportvtk_brick(in%nonlinearweakzone(k)%x, &
- in%nonlinearweakzone(k)%y, &
- in%nonlinearweakzone(k)%z, &
- in%nonlinearweakzone(k)%length, &
- in%nonlinearweakzone(k)%width, &
- in%nonlinearweakzone(k)%thickness, &
- in%nonlinearweakzone(k)%strike, &
- in%nonlinearweakzone(k)%dip,rffilename)
-#endif
- ! export the ductile zone in GMT .xy format
- rffilename=trim(in%wdir)//"/weakzone-nl-"//digit//".xy"
- CALL exportxy_brick(in%nonlinearweakzone(k)%x, &
- in%nonlinearweakzone(k)%y, &
- in%nonlinearweakzone(k)%z, &
- in%nonlinearweakzone(k)%length, &
- in%nonlinearweakzone(k)%width, &
- in%nonlinearweakzone(k)%thickness, &
- in%nonlinearweakzone(k)%strike, &
- in%nonlinearweakzone(k)%dip,rffilename)
- END DO
- END IF
- END IF ! end nonlinear viscous
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! F A U L T C R E E P
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of fault creep interfaces"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%nfc
- PRINT '(I5)', in%nfc
-
- IF (in%nfc .GT. 0) THEN
- ALLOCATE(in%faultcreeplayer(in%nfc),in%faultcreepstruc(in%sx3/2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the layer structure"
-
- PRINT 2000
- PRINT '(a)', "no. depth gamma0 (a-b)sig friction cohesion"
- PRINT 2000
- DO k=1,in%nfc
- CALL getdata(iunit,dataline)
- READ (dataline,*) i,in%faultcreeplayer(k)%z, &
- in%faultcreeplayer(k)%gammadot0, &
- in%faultcreeplayer(k)%stressexponent, &
- in%faultcreeplayer(k)%friction, &
- in%faultcreeplayer(k)%cohesion
-
- PRINT '(I3.3,5ES9.2E1)', i, &
- in%faultcreeplayer(k)%z, &
- in%faultcreeplayer(k)%gammadot0, &
- in%faultcreeplayer(k)%stressexponent, &
- in%faultcreeplayer(k)%friction, &
- in%faultcreeplayer(k)%cohesion
-
- ! check positive strain rates
- IF (in%faultcreeplayer(k)%gammadot0 .LT. 0) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: slip rates must be positive")')
- STOP 1
- END IF
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: index misfit")')
- STOP 1
- END IF
-
- END DO
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! A F T E R S L I P P L A N E S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of afterslip planes"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%np
- PRINT '(I5)', in%np
-
- IF (in%np .gt. 0) THEN
- ALLOCATE(in%n(in%np),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the plane list"
-
- PRINT 2000
- PRINT 2500
- PRINT 2000
-
- DO k=1,in%np
- CALL getdata(iunit,dataline)
- READ (dataline,*) i, &
- in%n(k)%x,in%n(k)%y,in%n(k)%z,&
- in%n(k)%length,in%n(k)%width, &
- in%n(k)%strike,in%n(k)%dip,in%n(k)%rake
-
- PRINT '(I3.3," ",5ES9.2E1,3f7.1)',i, &
- in%n(k)%x,in%n(k)%y,in%n(k)%z, &
- in%n(k)%length,in%n(k)%width, &
- in%n(k)%strike,in%n(k)%dip,in%n(k)%rake
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: plane index misfit")')
- STOP 1
- END IF
-
- ! modify rake for consistency with slip model
- IF (in%n(k)%rake .GE. 0.d0) THEN
- in%n(k)%rake=in%n(k)%rake-180.d0
- ELSE
- in%n(k)%rake=in%n(k)%rake+180.d0
- END IF
-
- ! comply to Wang's convention
- CALL wangconvention(dummy,in%n(k)%x,in%n(k)%y,in%n(k)%z,&
- in%n(k)%length,in%n(k)%width, &
- in%n(k)%strike,in%n(k)%dip,in%n(k)%rake, &
- in%x0,in%y0,in%rot)
-
-#ifdef VTK
- ! export the afterslip segment in VTK format
- WRITE (digit4,'(I4.4)') k
-
- rffilename=trim(in%wdir)//"/aplane-"//digit4//".vtp"
- CALL exportvtk_rectangle(in%n(k)%x,in%n(k)%y,in%n(k)%z, &
- in%n(k)%length,in%n(k)%width, &
- in%n(k)%strike,in%n(k)%dip,rffilename)
-#endif
-
- END DO
- END IF
-
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! I N T E R - S E I S M I C L O A D I N G
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- minlength=in%sx1*in%dx1+in%sx2*in%dx2
- minwidth=in%sx3*in%dx3
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! S H E A R S O U R C E S R A T E
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of inter-seismic strike-slip segments"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%inter%ns
- PRINT '(I5)', in%inter%ns
- IF (in%inter%ns .GT. 0) THEN
- ALLOCATE(in%inter%s(in%inter%ns),in%inter%sc(in%inter%ns),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the source list"
- PRINT 2000
- PRINT '(a)',"no. slip/time xs ys zs length width strike dip rake"
- PRINT 2000
- DO k=1,in%inter%ns
- CALL getdata(iunit,dataline)
- READ (dataline,*) i,in%inter%s(k)%slip, &
- in%inter%s(k)%x,in%inter%s(k)%y,in%inter%s(k)%z, &
- in%inter%s(k)%length,in%inter%s(k)%width, &
- in%inter%s(k)%strike,in%inter%s(k)%dip,in%inter%s(k)%rake
-
- ! copy the input format for display
- in%inter%sc(k)=in%inter%s(k)
-
- PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1)',i, &
- in%inter%sc(k)%slip,&
- in%inter%sc(k)%x,in%inter%sc(k)%y,in%inter%sc(k)%z, &
- in%inter%sc(k)%length,in%inter%sc(k)%width, &
- in%inter%sc(k)%strike,in%inter%sc(k)%dip, &
- in%inter%sc(k)%rake
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: source index misfit")')
- STOP 1
- END IF
- IF (MAX(in%inter%s(k)%length,in%inter%s(k)%width) .LE. 0._8) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: lengths must be positive.")')
- STOP 1
- END IF
- IF (in%inter%s(k)%length .lt. minlength) THEN
- minlength=in%inter%s(k)%length
- END IF
- IF (in%inter%s(k)%width .lt. minwidth ) THEN
- minwidth =in%inter%s(k)%width
- END IF
-
- ! smooth out the slip distribution
- CALL antialiasingfilter(in%inter%s(k)%slip, &
- in%inter%s(k)%length,in%inter%s(k)%width, &
- in%dx1,in%dx2,in%dx3,in%nyquist)
-
- ! comply to Wang's convention
- CALL wangconvention(in%inter%s(k)%slip, &
- in%inter%s(k)%x,in%inter%s(k)%y,in%inter%s(k)%z, &
- in%inter%s(k)%length,in%inter%s(k)%width, &
- in%inter%s(k)%strike,in%inter%s(k)%dip, &
- in%inter%s(k)%rake, &
- in%x0,in%y0,in%rot)
-
- END DO
- PRINT 2000
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! T E N S I L E S O U R C E S R A T E
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of inter-seismic tensile segments"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%inter%nt
- PRINT '(I5)', in%inter%nt
- IF (in%inter%nt .GT. 0) THEN
- ALLOCATE(in%inter%ts(in%inter%nt),in%inter%tsc(in%inter%nt),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the tensile source list"
- PRINT 2000
- PRINT '(a)',"no. opening xs ys ", &
- "zs length width strike dip"
- PRINT 2000
- DO k=1,in%inter%nt
- CALL getdata(iunit,dataline)
- READ (dataline,*) i,in%inter%ts(k)%slip, &
- in%inter%ts(k)%x,in%inter%ts(k)%y,in%inter%ts(k)%z, &
- in%inter%ts(k)%length,in%inter%ts(k)%width, &
- in%inter%ts(k)%strike,in%inter%ts(k)%dip
- ! copy the input format for display
- in%inter%tsc(k)=in%inter%ts(k)
-
- PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1)', i, &
- in%inter%tsc(k)%slip,&
- in%inter%tsc(k)%x,in%inter%tsc(k)%y,in%inter%tsc(k)%z, &
- in%inter%tsc(k)%length,in%inter%tsc(k)%width, &
- in%inter%tsc(k)%strike,in%inter%tsc(k)%dip
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: tensile source index misfit")')
- STOP 1
- END IF
- IF (MAX(in%inter%ts(k)%length,in%inter%ts(k)%width) .LE. 0._8) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: lengths must be positive.")')
- STOP 1
- END IF
- IF (in%inter%ts(k)%length .lt. minlength) THEN
- minlength=in%inter%ts(k)%length
- END IF
- IF (in%inter%ts(k)%width .lt. minwidth) THEN
- minwidth =in%inter%ts(k)%width
- END IF
-
- ! smooth out the slip distribution
- CALL antialiasingfilter(in%inter%ts(k)%slip, &
- in%inter%ts(k)%length,in%inter%ts(k)%width, &
- in%dx1,in%dx2,in%dx3,in%nyquist)
-
- ! comply to Wang's convention
- CALL wangconvention(in%inter%ts(k)%slip, &
- in%inter%ts(k)%x,in%inter%ts(k)%y,in%inter%ts(k)%z, &
- in%inter%ts(k)%length,in%inter%ts(k)%width, &
- in%inter%ts(k)%strike,in%inter%ts(k)%dip,dummy, &
- in%x0,in%y0,in%rot)
-
- END DO
- PRINT 2000
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! C 0 - S E I S M I C E V E N T S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of events"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%ne
- PRINT '(I5)', in%ne
- IF (in%ne .GT. 0) ALLOCATE(in%events(in%ne),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the event list"
-
- DO e=1,in%ne
- IF (1 .NE. e) THEN
- PRINT '("time of next coseismic event")'
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%events(e)%time
-
- IF (0 .EQ. in%skip) THEN
- ! change event time to multiples of output time step
- in%events(e)%time=int(in%events(e)%time/in%odt)*in%odt
- END IF
-
- PRINT '(ES9.2E1," (multiple of ",ES9.2E1,")")', &
- in%events(e)%time,in%odt
-
- IF (in%events(e)%time .LE. in%events(e-1)%time) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'(a,a)') "input file error. ", &
- "coseismic source time must increase. interrupting."
- STOP 1
- END IF
- ELSE
- in%events(1)%time=0._8
- in%events(1)%i=0
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! S H E A R S O U R C E S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of coseismic strike-slip segments"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%events(e)%ns
- PRINT '(I5)', in%events(e)%ns
- IF (in%events(e)%ns .GT. 0) THEN
- ALLOCATE(in%events(e)%s(in%events(e)%ns),in%events(e)%sc(in%events(e)%ns), &
- STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the source list"
- PRINT 2000
- PRINT '(a)',"no. slip xs ys zs length width strike dip rake"
- PRINT 2000
- DO k=1,in%events(e)%ns
- CALL getdata(iunit,dataline)
- READ (dataline,*,IOSTAT=iostatus) i,in%events(e)%s(k)%slip, &
- in%events(e)%s(k)%x,in%events(e)%s(k)%y,in%events(e)%s(k)%z, &
- in%events(e)%s(k)%length,in%events(e)%s(k)%width, &
- in%events(e)%s(k)%strike,in%events(e)%s(k)%dip,in%events(e)%s(k)%rake, &
- in%events(e)%s(k)%beta
-
- SELECT CASE(iostatus)
- CASE (1:)
- WRITE_DEBUG_INFO
- WRITE (0,'("invalid shear source definition at line")')
- WRITE (0,'(a)') dataline
- STOP 1
- CASE (0)
- IF (in%events(e)%s(k)%beta.GT.0.5d8) STOP "invalid smoothing parameter (beta)."
- CASE (:-1)
- ! use default value for smoothing
- in%events(e)%s(k)%beta=in%beta
- END SELECT
-
- ! copy the input format for display
- in%events(e)%sc(k)=in%events(e)%s(k)
-
- IF (iostatus.NE.0) THEN
- PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1)',i, &
- in%events(e)%sc(k)%slip,&
- in%events(e)%sc(k)%x,in%events(e)%sc(k)%y,in%events(e)%sc(k)%z, &
- in%events(e)%sc(k)%length,in%events(e)%sc(k)%width, &
- in%events(e)%sc(k)%strike,in%events(e)%sc(k)%dip, &
- in%events(e)%sc(k)%rake
- ELSE
- ! print the smoothing value for this patch
- PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1,f6.1)',i, &
- in%events(e)%sc(k)%slip,&
- in%events(e)%sc(k)%x,in%events(e)%sc(k)%y,in%events(e)%sc(k)%z, &
- in%events(e)%sc(k)%length,in%events(e)%sc(k)%width, &
- in%events(e)%sc(k)%strike,in%events(e)%sc(k)%dip, &
- in%events(e)%sc(k)%rake,in%events(e)%sc(k)%beta
- END IF
-
- IF (i .ne. k) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("invalid shear source definition ")')
- WRITE (0,'("error in input file: source index misfit")')
- STOP 1
- END IF
- IF (MAX(in%events(e)%s(k)%length,in%events(e)%s(k)%width) .LE. 0._8) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("error in input file: lengths must be positive.")')
- STOP 1
- END IF
- IF (in%events(e)%s(k)%length .lt. minlength) THEN
- minlength=in%events(e)%s(k)%length
- END IF
- IF (in%events(e)%s(k)%width .lt. minwidth ) THEN
- minwidth =in%events(e)%s(k)%width
- END IF
-
- ! smooth out the slip distribution
- CALL antialiasingfilter(in%events(e)%s(k)%slip, &
- in%events(e)%s(k)%length,in%events(e)%s(k)%width, &
- in%dx1,in%dx2,in%dx3,in%nyquist)
-
- ! comply to Wang's convention
- CALL wangconvention(in%events(e)%s(k)%slip, &
- in%events(e)%s(k)%x,in%events(e)%s(k)%y,in%events(e)%s(k)%z, &
- in%events(e)%s(k)%length,in%events(e)%s(k)%width, &
- in%events(e)%s(k)%strike,in%events(e)%s(k)%dip, &
- in%events(e)%s(k)%rake, &
- in%x0,in%y0,in%rot)
-
- END DO
-
-#ifdef VTK
- ! export the fault segments in VTK format for the current event
- WRITE (digit,'(I3.3)') e
-
- rffilename=trim(in%wdir)//"/rfaults-"//digit//".vtp"
- CALL exportvtk_rfaults(in%events(e),rffilename)
-#endif
- rffilename=trim(in%wdir)//"/rfaults-"//digit//".xy"
- CALL exportxy_rfaults(in%events(e),in%x0,in%y0,rffilename)
-
- PRINT 2000
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! T E N S I L E S O U R C E S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of coseismic tensile segments"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%events(e)%nt
- PRINT '(I5)', in%events(e)%nt
- IF (in%events(e)%nt .GT. 0) THEN
- ALLOCATE(in%events(e)%ts(in%events(e)%nt),in%events(e)%tsc(in%events(e)%nt), &
- STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the tensile source list"
- PRINT 2000
- PRINT '(a)',"no. opening xs ys zs length width strike dip"
- PRINT 2000
- DO k=1,in%events(e)%nt
-
- CALL getdata(iunit,dataline)
- READ (dataline,*) i,in%events(e)%ts(k)%slip, &
- in%events(e)%ts(k)%x,in%events(e)%ts(k)%y,in%events(e)%ts(k)%z, &
- in%events(e)%ts(k)%length,in%events(e)%ts(k)%width, &
- in%events(e)%ts(k)%strike,in%events(e)%ts(k)%dip
- ! copy the input format for display
- in%events(e)%tsc(k)=in%events(e)%ts(k)
-
- PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1)',k, &
- in%events(e)%tsc(k)%slip,&
- in%events(e)%tsc(k)%x,in%events(e)%tsc(k)%y,in%events(e)%tsc(k)%z, &
- in%events(e)%tsc(k)%length,in%events(e)%tsc(k)%width, &
- in%events(e)%tsc(k)%strike,in%events(e)%tsc(k)%dip
-
- IF (i .ne. k) THEN
- PRINT *, "error in input file: source index misfit"
- STOP 1
- END IF
- IF (in%events(e)%ts(k)%length .lt. minlength) THEN
- minlength=in%events(e)%ts(k)%length
- END IF
- IF (in%events(e)%ts(k)%width .lt. minwidth) THEN
- minwidth =in%events(e)%ts(k)%width
- END IF
-
- ! smooth out the slip distribution
- CALL antialiasingfilter(in%events(e)%ts(k)%slip, &
- in%events(e)%ts(k)%length,in%events(e)%ts(k)%width, &
- in%dx1,in%dx2,in%dx3,in%nyquist)
-
- ! comply to Wang's convention
- CALL wangconvention(in%events(e)%ts(k)%slip, &
- in%events(e)%ts(k)%x,in%events(e)%ts(k)%y,in%events(e)%ts(k)%z, &
- in%events(e)%ts(k)%length,in%events(e)%ts(k)%width, &
- in%events(e)%ts(k)%strike,in%events(e)%ts(k)%dip,dummy, &
- in%x0,in%y0,in%rot)
-
- END DO
- PRINT 2000
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! M O G I S O U R C E S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of coseismic dilatation point sources"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%events(e)%nm
- PRINT '(I5)', in%events(e)%nm
- IF (in%events(e)%nm .GT. 0) THEN
- ALLOCATE(in%events(e)%m(in%events(e)%nm),in%events(e)%mc(in%events(e)%nm), &
- STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the tensile source list"
- PRINT 2000
- PRINT '(a)',"no. strain (positive for extension) xs ys zs"
- PRINT 2000
- DO k=1,in%events(e)%nm
- CALL getdata(iunit,dataline)
- READ (dataline,*) i,in%events(e)%m(k)%slip, &
- in%events(e)%m(k)%x,in%events(e)%m(k)%y,in%events(e)%m(k)%z
- ! copy the input format for display
- in%events(e)%mc(k)=in%events(e)%m(k)
-
- PRINT '(I3.3,4ES9.2E1)',k, &
- in%events(e)%mc(k)%slip,&
- in%events(e)%mc(k)%x,in%events(e)%mc(k)%y,in%events(e)%mc(k)%z
-
- IF (i .ne. k) THEN
- PRINT *, "error in input file: source index misfit"
- STOP 1
- END IF
-
- ! rotate the source in the computational reference frame
- CALL rotation(in%events(e)%m(k)%x,in%events(e)%m(k)%y,in%rot)
- END DO
- PRINT 2000
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! S U R F A C E L O A D S
- ! - - - - - - - - - - - - - - - - - - - - - - - - - -
- PRINT '(a)', "number of surface loads"
- CALL getdata(iunit,dataline)
- READ (dataline,*) in%events(e)%nl
- PRINT '(I5)', in%events(e)%nl
- IF (in%events(e)%nl .GT. 0) THEN
- ALLOCATE(in%events(e)%l(in%events(e)%nl),in%events(e)%lc(in%events(e)%nl), &
- STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the load list"
- PRINT 2000
- PRINT '(a)',"t3 in units of force/surface/rigidity, positive down"
- PRINT '(a)',"T>0 for t3 sin(2pi/T+phi), T<=0 for t3 H(t)"
- PRINT '(a)',"no. xs ys length width t3 T phi"
- PRINT 2000
- DO k=1,in%events(e)%nl
- CALL getdata(iunit,dataline)
- READ (dataline,*,IOSTAT=iostatus) i, &
- in%events(e)%l(k)%x,in%events(e)%l(k)%y, &
- in%events(e)%l(k)%length,in%events(e)%l(k)%width, &
- in%events(e)%l(k)%slip, &
- in%events(e)%l(k)%period,in%events(e)%l(k)%phase, &
- in%events(e)%l(k)%beta
-
- SELECT CASE(iostatus)
- CASE (1:)
- WRITE_DEBUG_INFO
- WRITE (0,'("invalid surface load definition at line")')
- WRITE (0,'(a)') dataline
- STOP 1
- CASE (0)
- IF (in%events(e)%l(k)%beta.GT.0.5d8) STOP "invalid smoothing parameter beta."
- CASE (:-1)
- ! use default value for smoothing
- in%events(e)%l(k)%beta=in%beta
- END SELECT
-
- ! copy the input format for display
- in%events(e)%lc(k)=in%events(e)%l(k)
-
- IF (iostatus.EQ.0) THEN
- PRINT '(I3.3,9ES9.2E1)',k, &
- in%events(e)%lc(k)%x,in%events(e)%lc(k)%y, &
- in%events(e)%lc(k)%length,in%events(e)%lc(k)%width, &
- in%events(e)%lc(k)%slip, &
- in%events(e)%lc(k)%period,in%events(e)%lc(k)%phase, &
- in%events(e)%lc(k)%beta
- ELSE
- PRINT '(I3.3,8ES9.2E1)',k, &
- in%events(e)%lc(k)%x,in%events(e)%lc(k)%y, &
- in%events(e)%lc(k)%length,in%events(e)%lc(k)%width, &
- in%events(e)%lc(k)%slip, &
- in%events(e)%lc(k)%period,in%events(e)%lc(k)%phase
- END IF
-
- IF (i .NE. k) THEN
- PRINT *, "error in input file: source index misfit"
- STOP 1
- END IF
-
- ! rotate the source in the computational reference frame
- CALL rotation(in%events(e)%l(k)%x,in%events(e)%l(k)%y,in%rot)
- END DO
- PRINT 2000
- END IF
-
- END DO
-
- ! test the presence of dislocations for coseismic calculation
- IF ((in%events(1)%nt .EQ. 0) .AND. &
- (in%events(1)%ns .EQ. 0) .AND. &
- (in%events(1)%nm .EQ. 0) .AND. &
- (in%events(1)%nl .EQ. 0) .AND. &
- (in%interval .LE. 0._8)) THEN
-
- WRITE_DEBUG_INFO
- WRITE (0,'("**** error **** ")')
- WRITE (0,'("no input dislocations or dilatation point sources")')
- WRITE (0,'("or surface tractions for first event . exiting.")')
- STOP 1
- END IF
-
- ! maximum recommended sampling size
- PRINT '(a,2ES8.2E1)', &
- "max sampling size (hor.,vert.):", minlength/2.5_8,minwidth/2.5_8
-
- PRINT 2000
-
-2000 FORMAT ("----------------------------------------------------------------------------")
-2100 FORMAT ("no. x1 x2 x3 length width strike dip")
-2200 FORMAT ("no. slip x1 x2 x3 length width strike dip rake")
-2300 FORMAT ("no. name x1 x2 x3 (name is a 4-character string)")
-2400 FORMAT ("no. strain x1 x2 x3 (positive for extension)")
-2500 FORMAT ("no. x1 x2 x3 length width strike dip rake")
-
- END SUBROUTINE init
-
- !------------------------------------------------------------------
- !> subroutine WangConvention
- !! converts a fault slip model from a geologic description including
- !! fault length, width, strike, dip and rake into a description
- !! compatible with internal convention of the program.
- !!
- !! Internal convention describes a fault patch by the location of
- !! its center, instead of an upper corner and its orientation by
- !! the deviation from the vertical, instead of the angle from the
- !! horizontal and by the angle from the x2 axis (East-West)
- !------------------------------------------------------------------
- SUBROUTINE wangconvention(slip,x,y,z,length,width,strike,dip,rake,x0,y0,rot)
- REAL*8, INTENT(OUT) :: slip, x,y,z,strike,dip,rake
- REAL*8, INTENT(IN) :: length,width,x0,y0,rot
-
- slip=-slip
- strike=-90._8-strike
- dip = 90._8-dip
-
- strike=strike*DEG2RAD
- dip=dip*DEG2RAD
- rake=rake*DEG2RAD
-
- x=x-x0-length/2._8*sin(strike)+width /2._8*sin(dip)*cos(strike)
- y=y-y0-length/2._8*cos(strike)-width /2._8*sin(dip)*sin(strike)
- z=z+width /2._8*cos(dip)
-
- CALL rotation(x,y,rot)
-
- strike=strike+rot*DEG2RAD
-
- END SUBROUTINE wangconvention
-
- !------------------------------------------------------------------
- !> subroutine Rotation
- !! rotates a point coordinate into the computational reference
- !! system.
- !!
- !! \author sylvain barbot (04/16/09) - original form
- !------------------------------------------------------------------
- SUBROUTINE rotation(x,y,rot)
- REAL*8, INTENT(INOUT) :: x,y
- REAL*8, INTENT(IN) :: rot
-
- REAL*8 :: alpha,xx,yy
-
- alpha=rot*DEG2RAD
- xx=x
- yy=y
-
- x=+xx*cos(alpha)+yy*sin(alpha)
- y=-xx*sin(alpha)+yy*cos(alpha)
-
- END SUBROUTINE rotation
-
- !-------------------------------------------------------------------
- !> subroutine AntiAliasingFilter
- !! smoothes a slip distribution model to avoid aliasing of
- !! the source geometry. Aliasing occurs is a slip patch has
- !! dimensions (width or length) smaller than the grid sampling.
- !!
- !! if a patch length is smaller than a critical size L=dx*nyquist, it
- !! is increased to L and the slip (or opening) is scaled accordingly
- !! so that the moment M = s*L*W is conserved.
- !!
- !! \author sylvain barbot (12/08/09) - original form
- !-------------------------------------------------------------------
- SUBROUTINE antialiasingfilter(slip,length,width,dx1,dx2,dx3,nyquist)
- REAL*8, INTENT(INOUT) :: slip,length,width
- REAL*8, INTENT(IN) :: dx1,dx2,dx3,nyquist
-
- REAL*8 :: dx
-
- ! minimum slip patch dimension
- dx=MIN(dx1,dx2,dx3)*nyquist
-
- ! update length
- IF (length .LT. dx) THEN
- slip=slip*length/dx
- length=dx
- END IF
- ! update width
- IF (width .LT. dx) THEN
- slip=slip*width/dx
- width=dx
- END IF
-
- END SUBROUTINE antialiasingfilter
-
-END MODULE input
diff -r 405d8f4fa05f -r e7295294f654 kernel1.inc
--- a/kernel1.inc Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,3 +0,0 @@
- ! centered finite difference scheme
- REAL*8, PARAMETER, DIMENSION(1) :: &
- fir1= (/ 5.000e-01 /) ! filter kernel
diff -r 405d8f4fa05f -r e7295294f654 kernel11.inc
--- a/kernel11.inc Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,12 +0,0 @@
- REAL*8, PARAMETER, DIMENSION(11) :: &
- fir11=(/ 9.137025467466382e-01, &
- -3.444134215167435e-01, &
- +1.372354550142238e-01, &
- -4.472371911116056e-02, &
- +9.983584006653466e-03, &
- -4.203347378221815e-03, &
- +8.867064453003781e-03, &
- -1.331685333641829e-02, &
- +1.339297753637801e-02, &
- -9.762756789626834e-03, &
- +3.560973264270618e-03 /)
diff -r 405d8f4fa05f -r e7295294f654 kernel14.inc
--- a/kernel14.inc Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,15 +0,0 @@
- REAL*8, PARAMETER, DIMENSION(14) :: &
- fir14=(/ 9.487587545326932e-01, &
- -4.040368216139801e-01, &
- 2.042931326579159e-01, &
- -1.022548584863014e-01, &
- 4.783260352969341e-02, &
- -2.180739012077366e-02, &
- 1.283800669716571e-02, &
- -1.276100476817563e-02, &
- 1.558222334928575e-02, &
- -1.758387786545944e-02, &
- 1.707389141666987e-02, &
- -1.420560243259215e-02, &
- 1.081740233347091e-02, &
- -4.501057368601819e-03/)
diff -r 405d8f4fa05f -r e7295294f654 kernel14bis.inc
--- a/kernel14bis.inc Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,16 +0,0 @@
-
- REAL*8, PARAMETER, DIMENSION(14) :: &
- fir14=(/ 9.739464097198434e-01, &
- -4.492955962260918e-01, &
- 2.606661503992121e-01, &
- -1.590778397098753e-01, &
- 9.524605395168785e-02, &
- -5.279001022321913e-02, &
- 2.452656124714124e-02, &
- -6.434920307760272e-03, &
- -4.122947453390886e-03, &
- 9.245789328795669e-03, &
- -1.060146500976655e-02, &
- 9.786847569837574e-03, &
- -9.114943973080788e-03, &
- 4.398360884720647e-03 /)
\ No newline at end of file
diff -r 405d8f4fa05f -r e7295294f654 kernel7.inc
--- a/kernel7.inc Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
- REAL*8, PARAMETER, DIMENSION(7) :: &
- fir7=(/ 8.77856e-01, &
- -2.81913e-01, &
- +6.22696e-02, &
- +2.82441e-02, &
- -5.09029e-02, &
- +4.20471e-02, &
- -1.59409e-02 /) ! filter kernel
-!0.97125_8*
\ No newline at end of file
diff -r 405d8f4fa05f -r e7295294f654 mkl_dfti.f90
--- a/mkl_dfti.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,862 +0,0 @@
-!*****************************************************************************
-! INTEL CONFIDENTIAL
-! Copyright(C) 2002-2010 Intel Corporation. All Rights Reserved.
-! The source code contained or described herein and all documents related to
-! the source code ("Material") are owned by Intel Corporation or its suppliers
-! or licensors. Title to the Material remains with Intel Corporation or its
-! suppliers and licensors. The Material contains trade secrets and proprietary
-! and confidential information of Intel or its suppliers and licensors. The
-! Material is protected by worldwide copyright and trade secret laws and
-! treaty provisions. No part of the Material may be used, copied, reproduced,
-! modified, published, uploaded, posted, transmitted, distributed or disclosed
-! in any way without Intel's prior express written permission.
-! No license under any patent, copyright, trade secret or other intellectual
-! property right is granted to or conferred upon you by disclosure or delivery
-! of the Materials, either expressly, by implication, inducement, estoppel or
-! otherwise. Any license under such intellectual property rights must be
-! express and approved by Intel in writing.
-!
-!*****************************************************************************
-! Content:
-! Intel(R) Math Kernel Library (MKL)
-! Discrete Fourier Transform Interface (DFTI)
-!*****************************************************************************
-
-MODULE MKL_DFT_TYPE
-
- TYPE, PUBLIC :: DFTI_DESCRIPTOR
- PRIVATE
- INTEGER :: dontuse
- ! Structure of this type is not used in Fortran code
- ! the pointer to this type is used only
- END TYPE DFTI_DESCRIPTOR
-
- !======================================================================
- ! These real type kind parameters are not for direct use
- !======================================================================
-
- INTEGER, PARAMETER :: DFTI_SPKP = SELECTED_REAL_KIND(6,37)
- INTEGER, PARAMETER :: DFTI_DPKP = SELECTED_REAL_KIND(15,307)
-
- !======================================================================
- ! Descriptor configuration parameters [default values in brackets]
- !======================================================================
-
- ! Domain for forward transform. No default value
- INTEGER, PARAMETER :: DFTI_FORWARD_DOMAIN = 0
-
- ! Dimensionality, or rank. No default value
- INTEGER, PARAMETER :: DFTI_DIMENSION = 1
-
- ! Length(s) of transform. No default value
- INTEGER, PARAMETER :: DFTI_LENGTHS = 2
-
- ! Floating point precision. No default value
- INTEGER, PARAMETER :: DFTI_PRECISION = 3
-
- ! Scale factor for forward transform [1.0]
- INTEGER, PARAMETER :: DFTI_FORWARD_SCALE = 4
-
- ! Scale factor for backward transform [1.0]
- INTEGER, PARAMETER :: DFTI_BACKWARD_SCALE = 5
-
- ! Exponent sign for forward transform [DFTI_NEGATIVE]
- ! INTEGER, PARAMETER :: DFTI_FORWARD_SIGN = 6 ! NOT IMPLEMENTED
-
- ! Number of data sets to be transformed [1]
- INTEGER, PARAMETER :: DFTI_NUMBER_OF_TRANSFORMS = 7
-
- ! Storage of finite complex-valued sequences in complex domain
- ! [DFTI_COMPLEX_COMPLEX]
- INTEGER, PARAMETER :: DFTI_COMPLEX_STORAGE = 8
-
- ! Storage of finite real-valued sequences in real domain
- ! [DFTI_REAL_REAL]
- INTEGER, PARAMETER :: DFTI_REAL_STORAGE = 9
-
- ! Storage of finite complex-valued sequences in conjugate-even
- ! domain [DFTI_COMPLEX_REAL]
- INTEGER, PARAMETER :: DFTI_CONJUGATE_EVEN_STORAGE = 10
-
- ! Placement of result [DFTI_INPLACE]
- INTEGER, PARAMETER :: DFTI_PLACEMENT = 11
-
- ! Generalized strides for input data layout
- ! [tigth, col-major for Fortran]
- INTEGER, PARAMETER :: DFTI_INPUT_STRIDES = 12
-
- ! Generalized strides for output data layout
- ! [tigth, col-major for Fortran]
- INTEGER, PARAMETER :: DFTI_OUTPUT_STRIDES = 13
-
- ! Distance between first input elements for multiple transforms [0]
- INTEGER, PARAMETER :: DFTI_INPUT_DISTANCE = 14
-
- ! Distance between first output elements for multiple transforms [0]
- INTEGER, PARAMETER :: DFTI_OUTPUT_DISTANCE = 15
-
- ! Effort spent in initialization [DFTI_MEDIUM]
- ! INTEGER, PARAMETER :: DFTI_INITIALIZATION_EFFORT = 16 ! NOT IMPLEMENTED
-
- ! Use of workspace during computation [DFTI_ALLOW]
- ! INTEGER, PARAMETER :: DFTI_WORKSPACE = 17 ! NOT IMPLEMENTED
-
- ! Ordering of the result [DFTI_ORDERED]
- INTEGER, PARAMETER :: DFTI_ORDERING = 18
-
- ! Possible transposition of result [DFTI_NONE]
- INTEGER, PARAMETER :: DFTI_TRANSPOSE = 19
-
- ! User-settable descriptor name [""]
- INTEGER, PARAMETER :: DFTI_DESCRIPTOR_NAME = 20
-
- ! Packing format for DFTI_COMPLEX_REAL storage of finite
- ! conjugate-even sequences [DFTI_CCS_FORMAT]
- INTEGER, PARAMETER :: DFTI_PACKED_FORMAT = 21
-
- ! Commit status of the descriptor. Read-only parameter
- INTEGER, PARAMETER :: DFTI_COMMIT_STATUS = 22
-
- ! Version string for this DFTI implementation. Read-only parameter
- INTEGER, PARAMETER :: DFTI_VERSION = 23
-
- ! Ordering of the forward transform. Read-only parameter
- ! INTEGER, PARAMETER :: DFTI_FORWARD_ORDERING = 24 ! NOT IMPLEMENTED
-
- ! Ordering of the backward transform. Read-only parameter
- ! INTEGER, PARAMETER :: DFTI_BACKWARD_ORDERING = 25 ! NOT IMPLEMENTED
-
- ! Number of user threads that share the descriptor [1]
- INTEGER, PARAMETER :: DFTI_NUMBER_OF_USER_THREADS = 26
-
- !======================================================================
- ! Values of the descriptor configuration parameters
- !======================================================================
-
- ! DFTI_COMMIT_STATUS
- INTEGER, PARAMETER :: DFTI_COMMITTED = 30
- INTEGER, PARAMETER :: DFTI_UNCOMMITTED = 31
-
- ! DFTI_FORWARD_DOMAIN
- INTEGER, PARAMETER :: DFTI_COMPLEX = 32
- INTEGER, PARAMETER :: DFTI_REAL = 33
- ! INTEGER, PARAMETER :: DFTI_CONJUGATE_EVEN = 34 ! NOT IMPLEMENTED
-
- ! DFTI_PRECISION
- INTEGER, PARAMETER :: DFTI_SINGLE = 35
- INTEGER, PARAMETER :: DFTI_DOUBLE = 36
-
- ! DFTI_PRECISION for reduced size of statically linked application.
- ! Recommended use: modify statement 'USE MKL_DFTI' in your program,
- ! so that it reads as either of:
- ! USE MKL_DFTI, FORGET=>DFTI_SINGLE, DFTI_SINGLE=>DFTI_SINGLE_R
- ! USE MKL_DFTI, FORGET=>DFTI_DOUBLE, DFTI_DOUBLE=>DFTI_DOUBLE_R
- ! where word 'FORGET' can be any name not used in the program.
- REAL(DFTI_SPKP), PARAMETER :: DFTI_SINGLE_R = 35
- REAL(DFTI_DPKP), PARAMETER :: DFTI_DOUBLE_R = 36
-
- ! DFTI_FORWARD_SIGN
- ! INTEGER, PARAMETER :: DFTI_NEGATIVE = 37 ! NOT IMPLEMENTED
- ! INTEGER, PARAMETER :: DFTI_POSITIVE = 38 ! NOT IMPLEMENTED
-
- ! DFTI_COMPLEX_STORAGE and DFTI_CONJUGATE_EVEN_STORAGE
- INTEGER, PARAMETER :: DFTI_COMPLEX_COMPLEX = 39
- INTEGER, PARAMETER :: DFTI_COMPLEX_REAL = 40
-
- ! DFTI_REAL_STORAGE
- INTEGER, PARAMETER :: DFTI_REAL_COMPLEX = 41
- INTEGER, PARAMETER :: DFTI_REAL_REAL = 42
-
- ! DFTI_PLACEMENT
- INTEGER, PARAMETER :: DFTI_INPLACE = 43 ! Result overwrites input
- INTEGER, PARAMETER :: DFTI_NOT_INPLACE = 44 ! Have another place for result
-
- ! DFTI_INITIALIZATION_EFFORT
- ! INTEGER, PARAMETER :: DFTI_LOW = 45 ! NOT IMPLEMENTED
- ! INTEGER, PARAMETER :: DFTI_MEDIUM = 46 ! NOT IMPLEMENTED
- ! INTEGER, PARAMETER :: DFTI_HIGH = 47 ! NOT IMPLEMENTED
-
- ! DFTI_ORDERING
- INTEGER, PARAMETER :: DFTI_ORDERED = 48
- INTEGER, PARAMETER :: DFTI_BACKWARD_SCRAMBLED = 49
- ! INTEGER, PARAMETER :: DFTI_FORWARD_SCRAMBLED = 50 ! NOT IMPLEMENTED
-
- ! Allow/avoid certain usages
- INTEGER, PARAMETER :: DFTI_ALLOW = 51 ! Allow transposition or workspace
- ! INTEGER, PARAMETER :: DFTI_AVOID = 52 ! NOT IMPLEMENTED
- INTEGER, PARAMETER :: DFTI_NONE = 53
-
- ! DFTI_PACKED_FORMAT
- ! (for storing congugate-even finite sequence in real array)
- INTEGER, PARAMETER :: DFTI_CCS_FORMAT = 54 ! Complex conjugate-symmetric
- INTEGER, PARAMETER :: DFTI_PACK_FORMAT = 55 ! Pack format for real DFT
- INTEGER, PARAMETER :: DFTI_PERM_FORMAT = 56 ! Perm format for real DFT
- INTEGER, PARAMETER :: DFTI_CCE_FORMAT = 57 ! Complex conjugate-even
-
- !======================================================================
- ! Error classes
- !======================================================================
- INTEGER, PARAMETER :: DFTI_NO_ERROR = 0
- INTEGER, PARAMETER :: DFTI_MEMORY_ERROR = 1
- INTEGER, PARAMETER :: DFTI_INVALID_CONFIGURATION = 2
- INTEGER, PARAMETER :: DFTI_INCONSISTENT_CONFIGURATION = 3
- INTEGER, PARAMETER :: DFTI_MULTITHREADED_ERROR = 4
- INTEGER, PARAMETER :: DFTI_BAD_DESCRIPTOR = 5
- INTEGER, PARAMETER :: DFTI_UNIMPLEMENTED = 6
- INTEGER, PARAMETER :: DFTI_MKL_INTERNAL_ERROR = 7
- INTEGER, PARAMETER :: DFTI_NUMBER_OF_THREADS_ERROR = 8
- INTEGER, PARAMETER :: DFTI_1D_LENGTH_EXCEEDS_INT32 = 9
-
- ! Maximum length of error string
- INTEGER, PARAMETER :: DFTI_MAX_MESSAGE_LENGTH = 80
-
- ! Maximum length of user-settable descriptor name
- INTEGER, PARAMETER :: DFTI_MAX_NAME_LENGTH = 10
-
- ! Maximum length of MKL version string
- INTEGER, PARAMETER :: DFTI_VERSION_LENGTH = 198
-
- ! (deprecated parameter)
- INTEGER, PARAMETER :: DFTI_ERROR_CLASS = 60
-
-END MODULE MKL_DFT_TYPE
-
-MODULE MKL_DFTI
-
- USE MKL_DFT_TYPE
-
- INTERFACE DftiCreateDescriptor
-
- FUNCTION dfti_create_descriptor_1d(desc, precision, domain, dim, length)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_create_descriptor_1d
- !MS$ATTRIBUTES REFERENCE :: precision
- !MS$ATTRIBUTES REFERENCE :: domain
- !MS$ATTRIBUTES REFERENCE :: dim
- !MS$ATTRIBUTES REFERENCE :: length
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_create_descriptor_1d
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- INTEGER, INTENT(IN) :: precision
- INTEGER, INTENT(IN) :: domain
- INTEGER, INTENT(IN) :: dim, length
- END FUNCTION dfti_create_descriptor_1d
-
- FUNCTION dfti_create_descriptor_highd(desc, precision, domain, dim,length)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_create_descriptor_highd
- !MS$ATTRIBUTES REFERENCE :: precision
- !MS$ATTRIBUTES REFERENCE :: domain
- !MS$ATTRIBUTES REFERENCE :: dim
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_create_descriptor_highd
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- INTEGER, INTENT(IN) :: precision
- INTEGER, INTENT(IN) :: domain
- INTEGER, INTENT(IN) :: dim
- INTEGER, INTENT(IN), DIMENSION(*) :: length
- END FUNCTION dfti_create_descriptor_highd
-
- FUNCTION dfti_create_descriptor_s_1d(desc, s, dom, one, dim)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_create_descriptor_s_1d
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: s
- !MS$ATTRIBUTES REFERENCE :: dom
- !MS$ATTRIBUTES REFERENCE :: one
- !MS$ATTRIBUTES REFERENCE :: dim
- INTEGER dfti_create_descriptor_s_1d
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), INTENT(IN) :: s
- INTEGER, INTENT(IN) :: dom
- INTEGER, INTENT(IN) :: one
- INTEGER, INTENT(IN) :: dim
- END FUNCTION dfti_create_descriptor_s_1d
-
- FUNCTION dfti_create_descriptor_s_md(desc, s, dom, many, dims)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_create_descriptor_s_md
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: s
- !MS$ATTRIBUTES REFERENCE :: dom
- !MS$ATTRIBUTES REFERENCE :: many
- !MS$ATTRIBUTES REFERENCE :: dims
- INTEGER dfti_create_descriptor_s_md
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), INTENT(IN) :: s
- INTEGER, INTENT(IN) :: dom
- INTEGER, INTENT(IN) :: many
- INTEGER, INTENT(IN), DIMENSION(*) :: dims
- END FUNCTION dfti_create_descriptor_s_md
-
- FUNCTION dfti_create_descriptor_d_1d(desc, d, dom, one, dim)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_create_descriptor_d_1d
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: d
- !MS$ATTRIBUTES REFERENCE :: dom
- !MS$ATTRIBUTES REFERENCE :: one
- !MS$ATTRIBUTES REFERENCE :: dim
- INTEGER dfti_create_descriptor_d_1d
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), INTENT(IN) :: d
- INTEGER, INTENT(IN) :: dom
- INTEGER, INTENT(IN) :: one
- INTEGER, INTENT(IN) :: dim
- END FUNCTION dfti_create_descriptor_d_1d
-
- FUNCTION dfti_create_descriptor_d_md(desc, d, dom, many, dims)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_create_descriptor_d_md
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: d
- !MS$ATTRIBUTES REFERENCE :: dom
- !MS$ATTRIBUTES REFERENCE :: many
- !MS$ATTRIBUTES REFERENCE :: dims
- INTEGER dfti_create_descriptor_d_md
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), INTENT(IN) :: d
- INTEGER, INTENT(IN) :: dom
- INTEGER, INTENT(IN) :: many
- INTEGER, INTENT(IN), DIMENSION(*) :: dims
- END FUNCTION dfti_create_descriptor_d_md
-
- END INTERFACE
-
- INTERFACE DftiCopyDescriptor
-
- FUNCTION dfti_copy_descriptor_external(desc, new_desc)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_copy_descriptor_external
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: new_desc
- INTEGER dfti_copy_descriptor_external
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- TYPE(DFTI_DESCRIPTOR), POINTER :: new_desc
- END FUNCTION dfti_copy_descriptor_external
-
- END INTERFACE
-
- INTERFACE DftiCommitDescriptor
-
- FUNCTION dfti_commit_descriptor_external(desc)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_commit_descriptor_external
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_commit_descriptor_external
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_commit_descriptor_external
-
- END INTERFACE
-
- INTERFACE DftiSetValue
-
- FUNCTION dfti_set_value_intval(desc, OptName, IntVal)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_set_value_intval
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: IntVal
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_set_value_intval
- INTEGER, INTENT(IN) :: OptName
- INTEGER, INTENT(IN) :: IntVal
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_set_value_intval
-
- FUNCTION dfti_set_value_sglval(desc, OptName, sglval)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_set_value_sglval
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: sglval
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_set_value_sglval
- INTEGER, INTENT(IN) :: OptName
- REAL(DFTI_SPKP), INTENT(IN) :: sglval
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_set_value_sglval
-
- FUNCTION dfti_set_value_dblval(desc, OptName, DblVal)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_set_value_dblval
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: DblVal
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_set_value_dblval
- INTEGER, INTENT(IN) :: OptName
- REAL(DFTI_DPKP), INTENT(IN) :: DblVal
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_set_value_dblval
-
- FUNCTION dfti_set_value_intvec(desc, OptName, IntVec)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_set_value_intvec
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: IntVec
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_set_value_intvec
- INTEGER, INTENT(IN) :: OptName
- INTEGER, INTENT(IN), DIMENSION(*) :: IntVec
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_set_value_intvec
-
- FUNCTION dfti_set_value_chars(desc, OptName, Chars)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_set_value_chars
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: dfti_set_value_chars
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_set_value_chars
- INTEGER, INTENT(IN) :: OptName
- CHARACTER(*), INTENT(IN) :: Chars
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_set_value_chars
-
- END INTERFACE
-
- INTERFACE DftiGetValue
-
- FUNCTION dfti_get_value_intval(desc, OptName, IntVal)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_get_value_intval
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: IntVal
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_get_value_intval
- INTEGER, INTENT(IN) :: OptName
- INTEGER, INTENT(OUT) :: IntVal
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_get_value_intval
-
- FUNCTION dfti_get_value_sglval(desc, OptName, sglval)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_get_value_sglval
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: sglval
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_get_value_sglval
- INTEGER, INTENT(IN) :: OptName
- REAL(DFTI_SPKP), INTENT(OUT) :: sglval
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_get_value_sglval
-
- FUNCTION dfti_get_value_dblval(desc, OptName, DblVal)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_get_value_dblval
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: DblVal
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_get_value_dblval
- INTEGER, INTENT(IN) :: OptName
- REAL(DFTI_DPKP), INTENT(OUT) :: DblVal
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_get_value_dblval
-
- FUNCTION dfti_get_value_intvec(desc, OptName, IntVec)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_get_value_intvec
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: IntVec
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_get_value_intvec
- INTEGER, INTENT(IN) :: OptName
- INTEGER, INTENT(OUT), DIMENSION(*) :: IntVec
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_get_value_intvec
-
- FUNCTION dfti_get_value_chars(desc, OptName, Chars)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_get_value_chars
- !MS$ATTRIBUTES REFERENCE :: OptName
- !MS$ATTRIBUTES REFERENCE :: dfti_get_value_chars
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_get_value_chars
- INTEGER, INTENT(IN) :: OptName
- CHARACTER(*), INTENT(OUT) :: Chars
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_get_value_chars
-
- END INTERFACE
-
- INTERFACE DftiComputeForward
-
- FUNCTION dfti_compute_forward_s(desc,sSrcDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_s
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: sSrcDst
- INTEGER dfti_compute_forward_s
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: sSrcDst
- END FUNCTION dfti_compute_forward_s
-
- FUNCTION dfti_compute_forward_c(desc,cSrcDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_c
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: cSrcDst
- INTEGER dfti_compute_forward_c
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: cSrcDst
- END FUNCTION dfti_compute_forward_c
-
- FUNCTION dfti_compute_forward_ss(desc,sSrcDstRe,sSrcDstIm)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_ss
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: sSrcDstRe
- !MS$ATTRIBUTES REFERENCE :: sSrcDstIm
- INTEGER dfti_compute_forward_ss
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstRe
- REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstIm
- END FUNCTION dfti_compute_forward_ss
-
- FUNCTION dfti_compute_forward_sc(desc,sSrc,cDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_sc
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: sSrc
- !MS$ATTRIBUTES REFERENCE :: cDst
- INTEGER dfti_compute_forward_sc
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrc
- COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
- END FUNCTION dfti_compute_forward_sc
-
- FUNCTION dfti_compute_forward_cs(desc,cSrc,sDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_cs
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: cSrc
- !MS$ATTRIBUTES REFERENCE :: sDst
- INTEGER dfti_compute_forward_cs
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
- REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDst
- END FUNCTION dfti_compute_forward_cs
-
- FUNCTION dfti_compute_forward_cc(desc,cSrc,cDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_cc
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: cSrc
- !MS$ATTRIBUTES REFERENCE :: cDst
- INTEGER dfti_compute_forward_cc
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
- COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
- END FUNCTION dfti_compute_forward_cc
-
- FUNCTION dfti_compute_forward_ssss(desc,sSrcRe,sSrcIm,sDstRe,sDstIm)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_ssss
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: sSrcRe
- !MS$ATTRIBUTES REFERENCE :: sSrcIm
- !MS$ATTRIBUTES REFERENCE :: sDstRe
- !MS$ATTRIBUTES REFERENCE :: sDstIm
- INTEGER dfti_compute_forward_ssss
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcRe
- REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcIm
- REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstRe
- REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstIm
- END FUNCTION dfti_compute_forward_ssss
-
- FUNCTION dfti_compute_forward_d(desc,dSrcDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_d
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: dSrcDst
- INTEGER dfti_compute_forward_d
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: dSrcDst
- END FUNCTION dfti_compute_forward_d
-
- FUNCTION dfti_compute_forward_z(desc,zSrcDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_z
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: zSrcDst
- INTEGER dfti_compute_forward_z
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: zSrcDst
- END FUNCTION dfti_compute_forward_z
-
- FUNCTION dfti_compute_forward_dd(desc,dSrcDstRe,dSrcDstIm)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_dd
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: dSrcDstRe
- !MS$ATTRIBUTES REFERENCE :: dSrcDstIm
- INTEGER dfti_compute_forward_dd
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstRe
- REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstIm
- END FUNCTION dfti_compute_forward_dd
-
- FUNCTION dfti_compute_forward_dz(desc,dSrc,zDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_dz
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: dSrc
- !MS$ATTRIBUTES REFERENCE :: zDst
- INTEGER dfti_compute_forward_dz
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrc
- COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
- END FUNCTION dfti_compute_forward_dz
-
- FUNCTION dfti_compute_forward_zd(desc,zSrc,dDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_zd
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: zSrc
- !MS$ATTRIBUTES REFERENCE :: dDst
- INTEGER dfti_compute_forward_zd
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
- REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDst
- END FUNCTION dfti_compute_forward_zd
-
- FUNCTION dfti_compute_forward_zz(desc,zSrc,zDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_zz
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: zSrc
- !MS$ATTRIBUTES REFERENCE :: zDst
- INTEGER dfti_compute_forward_zz
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
- COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
- END FUNCTION dfti_compute_forward_zz
-
- FUNCTION dfti_compute_forward_dddd(desc,dSrcRe,dSrcIm,dDstRe,dDstIm)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_forward_dddd
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: dSrcRe
- !MS$ATTRIBUTES REFERENCE :: dSrcIm
- !MS$ATTRIBUTES REFERENCE :: dDstRe
- !MS$ATTRIBUTES REFERENCE :: dDstIm
- INTEGER dfti_compute_forward_dddd
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcRe
- REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcIm
- REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstRe
- REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstIm
- END FUNCTION dfti_compute_forward_dddd
-
- END INTERFACE DftiComputeForward
-
- INTERFACE DftiComputeBackward
-
- FUNCTION dfti_compute_backward_s(desc,sSrcDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_s
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: sSrcDst
- INTEGER dfti_compute_backward_s
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: sSrcDst
- END FUNCTION dfti_compute_backward_s
-
- FUNCTION dfti_compute_backward_c(desc,cSrcDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_c
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: cSrcDst
- INTEGER dfti_compute_backward_c
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: cSrcDst
- END FUNCTION dfti_compute_backward_c
-
- FUNCTION dfti_compute_backward_ss(desc,sSrcDstRe,sSrcDstIm)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_ss
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: sSrcDstRe
- !MS$ATTRIBUTES REFERENCE :: sSrcDstIm
- INTEGER dfti_compute_backward_ss
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstRe
- REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstIm
- END FUNCTION dfti_compute_backward_ss
-
- FUNCTION dfti_compute_backward_sc(desc,sSrc,cDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_sc
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: sSrc
- !MS$ATTRIBUTES REFERENCE :: cDst
- INTEGER dfti_compute_backward_sc
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrc
- COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
- END FUNCTION dfti_compute_backward_sc
-
- FUNCTION dfti_compute_backward_cs(desc,cSrc,sDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_cs
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: cSrc
- !MS$ATTRIBUTES REFERENCE :: sDst
- INTEGER dfti_compute_backward_cs
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
- REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDst
- END FUNCTION dfti_compute_backward_cs
-
- FUNCTION dfti_compute_backward_cc(desc,cSrc,cDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_cc
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: cSrc
- !MS$ATTRIBUTES REFERENCE :: cDst
- INTEGER dfti_compute_backward_cc
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
- COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
- END FUNCTION dfti_compute_backward_cc
-
- FUNCTION dfti_compute_backward_ssss(desc,sSrcRe,sSrcIm,sDstRe,sDstIm)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_ssss
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: sSrcRe
- !MS$ATTRIBUTES REFERENCE :: sSrcIm
- !MS$ATTRIBUTES REFERENCE :: sDstRe
- !MS$ATTRIBUTES REFERENCE :: sDstIm
- INTEGER dfti_compute_backward_ssss
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcRe
- REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcIm
- REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstRe
- REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstIm
- END FUNCTION dfti_compute_backward_ssss
-
- FUNCTION dfti_compute_backward_d(desc,dSrcDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_d
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: dSrcDst
- INTEGER dfti_compute_backward_d
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: dSrcDst
- END FUNCTION dfti_compute_backward_d
-
- FUNCTION dfti_compute_backward_z(desc,zSrcDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_z
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: zSrcDst
- INTEGER dfti_compute_backward_z
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: zSrcDst
- END FUNCTION dfti_compute_backward_z
-
- FUNCTION dfti_compute_backward_dd(desc,dSrcDstRe,dSrcDstIm)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_dd
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: dSrcDstRe
- !MS$ATTRIBUTES REFERENCE :: dSrcDstIm
- INTEGER dfti_compute_backward_dd
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstRe
- REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstIm
- END FUNCTION dfti_compute_backward_dd
-
- FUNCTION dfti_compute_backward_dz(desc,dSrc,zDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_dz
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: dSrc
- !MS$ATTRIBUTES REFERENCE :: zDst
- INTEGER dfti_compute_backward_dz
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrc
- COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
- END FUNCTION dfti_compute_backward_dz
-
- FUNCTION dfti_compute_backward_zd(desc,zSrc,dDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_zd
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: zSrc
- !MS$ATTRIBUTES REFERENCE :: dDst
- INTEGER dfti_compute_backward_zd
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
- REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDst
- END FUNCTION dfti_compute_backward_zd
-
- FUNCTION dfti_compute_backward_zz(desc,zSrc,zDst)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_zz
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: zSrc
- !MS$ATTRIBUTES REFERENCE :: zDst
- INTEGER dfti_compute_backward_zz
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
- COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
- END FUNCTION dfti_compute_backward_zz
-
- FUNCTION dfti_compute_backward_dddd(desc,dSrcRe,dSrcIm,dDstRe,dDstIm)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_compute_backward_dddd
- !MS$ATTRIBUTES REFERENCE :: desc
- !MS$ATTRIBUTES REFERENCE :: dSrcRe
- !MS$ATTRIBUTES REFERENCE :: dSrcIm
- !MS$ATTRIBUTES REFERENCE :: dDstRe
- !MS$ATTRIBUTES REFERENCE :: dDstIm
- INTEGER dfti_compute_backward_dddd
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcRe
- REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcIm
- REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstRe
- REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstIm
- END FUNCTION dfti_compute_backward_dddd
-
- END INTERFACE DftiComputeBackward
-
- INTERFACE DftiFreeDescriptor
-
- FUNCTION dfti_free_descriptor_external(desc)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_free_descriptor_external
- !MS$ATTRIBUTES REFERENCE :: desc
- INTEGER dfti_free_descriptor_external
- TYPE(DFTI_DESCRIPTOR), POINTER :: desc
- END FUNCTION dfti_free_descriptor_external
-
- END INTERFACE
-
- INTERFACE DftiErrorClass
-
- FUNCTION dfti_error_class_external(Status, ErrorClass)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_error_class_external
- !MS$ATTRIBUTES REFERENCE :: Status
- !MS$ATTRIBUTES REFERENCE :: ErrorClass
- LOGICAL dfti_error_class_external
- INTEGER, INTENT(IN) :: Status
- INTEGER, INTENT(IN) :: ErrorClass
- END FUNCTION dfti_error_class_external
-
- END INTERFACE
-
- INTERFACE DftiErrorMessage
-
- FUNCTION dfti_error_message_external(Status)
- USE MKL_DFT_TYPE
- !DEC$ATTRIBUTES C :: dfti_error_message_external
- !MS$ATTRIBUTES REFERENCE :: Status
- CHARACTER(LEN=DFTI_MAX_MESSAGE_LENGTH) :: dfti_error_message_external
- INTEGER, INTENT(IN) :: Status
- END FUNCTION dfti_error_message_external
-
- END INTERFACE
-
-END MODULE MKL_DFTI
diff -r 405d8f4fa05f -r e7295294f654 proj.c
--- a/proj.c Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,64 +0,0 @@
-#include <stdio.h>
-#include <stdlib.h>
-#include <proj_api.h>
-#include <string.h>
-
-/*
- * proj routine to convert arrays of UTM coordinates
- * to longitude/latitude using the PROJ.4 library
- *
- * to do: check the output in the south hemisphere
- *
- * sylvain barbot (22/05/10) - original form
- */
-
-void proj_(double *x, double *y, int * n,
- double * lon0, double * lat0, int * zone) {
-
- projPJ pj_utm, pj_latlong;
- int p, i;
- char zonestr[3];
- char cmd_utm[100], cmd_latlong[100];
- char * to;
-
- // convert integer zone to string zone
- i=sprintf(zonestr, "%d", (*zone));
-
- // construct conversion command (+proj=utm +zone=11)
- to = stpcpy(cmd_utm,"+proj=utm +zone=");
- to = stpcpy(to,zonestr);
- //printf("%s\n",cmd_utm);
-
- // construct conversion command (+proj=latlong +zone=11)
- to = stpcpy(cmd_latlong,"+proj=latlong +zone=");
- to = stpcpy(to,zonestr);
- //printf("%s\n",cmd_latlong);
-
- if (!(pj_utm = pj_init_plus(cmd_utm)) ){
- printf("error initializing input projection driver. exiting.");
- exit(1);
- }
- if (!(pj_latlong = pj_init_plus(cmd_latlong)) ){
- printf("error initializing output projection driver. exiting.");
- exit(1);
- }
-
- // convert to radians
- (*lon0)*=DEG_TO_RAD;
- (*lat0)*=DEG_TO_RAD;
-
- p = pj_transform(pj_latlong, pj_utm, 1, 1, lon0, lat0, NULL);
-
- // add UTM coordinates of the origin
- for (i=0;i<(*n);i++){
- x[i]+=(*lon0);
- y[i]+=(*lat0);
- }
- p = pj_transform(pj_utm, pj_latlong, (*n), 1, x, y, NULL);
-
- // convert longitude and latitude to degrees
- for (i=0;i<(*n);i++){
- x[i]*=RAD_TO_DEG;
- y[i]*=RAD_TO_DEG;
- }
-}
diff -r 405d8f4fa05f -r e7295294f654 relax.f90
--- a/relax.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1121 +0,0 @@
-!-----------------------------------------------------------------------
-! Copyright 2007-2012, Sylvain Barbot
-!
-! This file is part of RELAX
-!
-! RELAX 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 3 of the License, or
-! (at your option) any later version.
-!
-! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
-!-----------------------------------------------------------------------
-
- !-----------------------------------------------------------------------
- !> \mainpage
- !! program relax
- !! <hr>
- !! PURPOSE:
- !! The program RELAX computes nonlinear time-dependent viscoelastic
- !! deformation with powerlaw rheology and rate-strengthening friction
- !! in a cubic, periodic grid due to coseismic stress changes, initial
- !! stress, surface loads, and/or moving faults.
- !!
- !! ONLINE DOCUMENTATION:
- !! generate html documentation from the source directory with the
- !! doxygen (http://www.stack.nl/~dimitri/doxygen/index.html)
- !! program with command:
- !!
- !! doxygen .doxygen
- !!
- !! DESCRIPTION:
- !! Computation is done semi-analytically inside a cartesian grid.
- !! The grid is defined by its size sx1*sx2*sx3 and the sampling
- !! intervals dx1, dx2 and dx3. rule of thumb is to allow for at least
- !! five samples per fault length or width, and to have the tip of any
- !! fault at least 10 fault widths away from any edge of the
- !! computational grid.
- !!
- !! Coseismic stress changes and initial coseismic deformation results
- !! from the presence of dislocations in the brittle layer. Fault
- !! geometry is prescribed following Okada or Wang's convention, with the
- !! usual slip, strike, dip and rake and is converted to a double-couple
- !! equivalent body-force analytically. Current implementation allows
- !! shear fault (strike slip and dip slip), dykes, Mogi source, and
- !! surface traction. Faults and dykes can be of arbitrary orientation
- !! in the half space.
- !!
- !! <hr>
- !!
- !! METHOD:
- !! The current implementation is organized to integrate stress/strain-
- !! rate constitutive laws (rheologies) of the form
- !! \f[
- !! \dot{\epsilon} = f(\sigma)
- !! \f]
- !! as opposed to epsilon^dot = f(sigma,epsilon) wich would include work-
- !! hardening (or weakening). The time-stepping implements a second-order
- !! Runge-Kutta numerical integration scheme with a variable time-step.
- !! The Runge-Kutta method integrating the ODE y'=f(x,y) can be summarized
- !! as follows:
- !! \f[
- !! y_(n+1) = y_n + k_2
- !! k_1 = h * f(x_n, y_n)
- !! k_2 = h * f(x_n + h, y_n + k_1)
- !! \f]
- !! where h is the time-step and n is the time-index. The elastic response
- !! in the computational grid is obtained using elastic Greens functions.
- !! The Greens functions are applied in the Fourier domain. Strain,
- !! stress and body-forces are obtained by application of a finite impulse
- !! response (FIR) differentiator filter in the space domain.
- !!
- !! <hr>
- !!
- !! INPUT:
- !! Static dislocation sources are discretized into a series of planar
- !! segments. Slip patches are defined in terms of position, orientation,
- !! and slip, as illustrated in the following figure:
- !!\verbatim
- !! N (x1)
- !! /
- !! /| Strike
- !! x1,x2,x3 ->@------------------------ (x2)
- !! |\ p . \ W
- !! :-\ i . \ i
- !! | \ l . \ d
- !! :90 \ S . \ t
- !! |-Dip\ . \ h
- !! : \. | Rake \
- !! | -------------------------
- !! : L e n g t h
- !! Z (x3)
- !!\endverbatim
- !! Dislocations are converted to double-couple equivalent body-force
- !! analytically. Solution displacement is obtained by application of
- !! the Greens functions in the Fourier domain.
- !!
- !! For friction faults where slip rates are evaluated from stress and
- !! a constitutive law, the rake corresponds to the orientation of slip.
- !! That is, if r_i is the rake vector and v_i is the instantaneous
- !! velocity vector, then r_j v_j >= 0.
- !!
- !! <hr>
- !!
- !! OUTPUT:
- !! The vector-valued deformation is computed everywhere in a cartesian
- !! grid. The vector field is sampled 1) along a horizontal surface at a
- !! specified depth and 2) at specific points. Format is always North (x1),
- !! East (x2) and Down (x3) components, following the right-handed reference
- !! system convention. North corresponds to x1-direction, East to the
- !! x2-direction and down to the x3-direction. The Generic Mapping Tool
- !! output files are labeled explicitely ???-north.grd, ???-east.grd and
- !! ???-up.grd (or say, ???-geo-up.grd for outputs in geographic
- !! coordinates), where ??? stands for an output index: 001, 002, ...
- !!
- !! The amplitude of the inelastic (irreversible) deformation is also
- !! tracked and can be output along a plane of arbitrary orientation.
- !! The inelastic deformation includes the initial, constrained, slip on
- !! fault surfaces, the time-dependent slip on frictional surfaces and
- !! the cumulative amplitude of bulk strain in viscoelastic regions.
- !! Slip is provided as a function of local coordinates along strike and
- !! dip as well as a function of the Cartesian coordinates for three-
- !! dimensional display.
- !!
- !! Time integration uses adaptive time steps to ensure accuracy but
- !! results can be output either 1) at specified uniform time intervals
- !! or 2) at the same intervals as computed. In the later case, output
- !! intervals is chosen internally depending on instantaneous relaxation
- !! rates.
- !!
- !! <hr>
- !!
- !! TECHNICAL ASPECTS:
- !! Most of the computational burden comes from 1) applying the elastic
- !! Green function and 2) computing the current strain from a displacement
- !! field. The convolution of body forces with the Green function is
- !! performed in the Fourier domain and the efficiency of the computation
- !! depends essentially upon a choice of the discrete Fourier transform.
- !! Current implementation is compatible with the Couley-Tuckey, the
- !! Fast Fourier transform of the West (FFTW), the SGI FFT and the intel
- !! FFT from the intel MKL library. Among these choices, the MKL FFT is
- !! the most efficient. The FFTW, SGI FFT and MKL FFT can all be ran
- !! in parallel on shared-memory computers.
- !!
- !! Strain is computed using a Finite Impulse Response differentiator
- !! filter in the space domain. Use of FIR filter give rise to very
- !! accurate derivatives but is computationally expensive. The filter
- !! kernels are provided in the kernel???.inc files. Use of a compact
- !! kernel may accelerate computation significantly.
- !!
- !! Compilation options are defined in the include.f90 file and specify
- !! for instance the choice of DFT and the kind of output provided.
- !!
- !! MODIFICATIONS:
- !! \author Sylvain Barbot
- !! (07-06-07) - original form <br>
- !! (08-28-08) - FFTW/SGI_FFT support, FIR derivatives,
- !! Runge-Kutta integration, tensile cracks,
- !! GMT output, comments in input file <br>
- !! (10-24-08) - interseismic loading, postseismic signal
- !! output in separate files <br>
- !! (12-08-09) - slip distribution smoothing <br>
- !! (05-05-10) - lateral variations in viscous properties
- !! Intel MKL implementation of the FFT <br>
- !! (06-04-10) - output in geographic coordinates
- !! and output components of stress tensor <br>
- !! (07-19-10) - includes surface tractions initial condition
- !! output geometry in VTK format for Paraview <br>
- !! (02-28-11) - add constraints on the broad direction of
- !! afterslip, export faults to GMT xy format
- !! and allow scaling of computed time steps. <br>
- !! (04-26-11) - include command-line arguments
- !! (11-04-11) - compatible with gfortran <br>
- !!
- !! \todo
- !! - homogenize VTK output so that geometry of events match event index
- !! - evaluate Green's function, stress and body forces in GPU
- !! - write the code for MPI multi-thread
- !! - fix the vtk export to grid for anisotropic sampling
- !! - export position of observation points to long/lat in opts-geo.dat
- !! - check the projected output on the south hemisphere
- !! - check the fully-relaxed afterslip for uniform stress change
- !! - include topography of parameter interface
- !! - export afterslip output in VTK
- !------------------------------------------------------------------------
-PROGRAM relax
-
- USE types
- USE input
- USE green
- USE elastic3d
- USE viscoelastic3d
- USE friction3d
- USE export
-
-#include "include.f90"
-
- IMPLICIT NONE
-
- INTEGER, PARAMETER :: ITERATION_MAX = 9900
- REAL*8, PARAMETER :: STEP_MAX = 1e7
-
- INTEGER :: i,k,e,oi,iostatus,mech(3)
-#ifdef FFTW3_THREADS
- INTEGER :: iret
-!$ INTEGER :: omp_get_max_threads
-#endif
- REAL*8 :: maxwell(3)
- TYPE(SIMULATION_STRUC) :: in
-#ifdef VTK
- CHARACTER(80) :: filename,title,name
- CHARACTER(3) :: digit
-#endif
- CHARACTER(4) :: digit4
- REAL*8 :: t,Dt,tm
-
- ! arrays
- REAL*4, DIMENSION(:,:,:), ALLOCATABLE :: v1,v2,v3,u1,u2,u3,gamma
- REAL*4, DIMENSION(:,:,:), ALLOCATABLE :: u1r,u2r,u3r
- REAL*4, DIMENSION(:,:), ALLOCATABLE :: t1,t2,t3
- REAL*4, DIMENSION(:,:,:), ALLOCATABLE :: inter1,inter2,inter3
- TYPE(TENSOR), DIMENSION(:,:,:), ALLOCATABLE :: tau,sig,moment
-
-#ifdef FFTW3_THREADS
- CALL sfftw_init_threads(iret)
-#ifdef _OPENMP
- CALL sfftw_plan_with_nthreads(omp_get_max_threads())
-#else
- CALL sfftw_plan_with_nthreads(4)
-#endif
-#endif
-
- ! read input parameters
- CALL init(in)
-
- ! abort calculation after help message
- ! or for dry runs
- IF (in%isdryrun) THEN
- PRINT '("dry run: abort calculation")'
- END IF
- IF (in%isdryrun .OR. in%ishelp) THEN
- ! exit program
- GOTO 100
- END IF
-
- ! allocate memory
- ALLOCATE (v1(in%sx1+2,in%sx2,in%sx3),v2(in%sx1+2,in%sx2,in%sx3),v3(in%sx1+2,in%sx2,in%sx3), &
- u1(in%sx1+2,in%sx2,in%sx3/2),u2(in%sx1+2,in%sx2,in%sx3/2),u3(in%sx1+2,in%sx2,in%sx3/2), &
- tau(in%sx1,in%sx2,in%sx3/2),sig(in%sx1,in%sx2,in%sx3/2),gamma(in%sx1+2,in%sx2,in%sx3/2), &
- t1(in%sx1+2,in%sx2),t2(in%sx1+2,in%sx2),t3(in%sx1+2,in%sx2), &
- STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate memory"
-#ifdef VTK
- IF (in%isoutputvtkrelax) THEN
- ALLOCATE(u1r(in%sx1+2,in%sx2,in%sx3/2),u2r(in%sx1+2,in%sx2,in%sx3/2), &
- u3r(in%sx1+2,in%sx2,in%sx3/2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate memory for VTK relax output"
- u1r=0
- u2r=0
- u3r=0
- END IF
-#endif
-
- IF (in%isoutputrelax) THEN
- ALLOCATE(inter1(in%sx1+2,in%sx2,2),inter2(in%sx1+2,in%sx2,2),inter3(in%sx1+2,in%sx2,2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate memory for postseismic displacement"
- END IF
-
- v1=0;v2=0;v3=0;u1=0;u2=0;u3=0;gamma=0;t1=0;t2=0;t3=0
- CALL tensorfieldadd(tau,tau,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=0._4)
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! - construct pre-stress structure
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- IF (ALLOCATED(in%stresslayer)) THEN
- CALL tensorstructure(in%stressstruc,in%stresslayer,in%dx3)
- DEALLOCATE(in%stresslayer)
-
- DO k=1,in%sx3/2
- tau(:,:,k)=(-1._4) .times. in%stressstruc(k)%t
- END DO
- DEALLOCATE(in%stressstruc)
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! - construct linear viscoelastic structure
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- IF (ALLOCATED(in%linearlayer)) THEN
- CALL viscoelasticstructure(in%linearstruc,in%linearlayer,in%dx3)
- DEALLOCATE(in%linearlayer)
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! - construct nonlinear viscoelastic structure
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- IF (ALLOCATED(in%nonlinearlayer)) THEN
- CALL viscoelasticstructure(in%nonlinearstruc,in%nonlinearlayer,in%dx3)
- DEALLOCATE(in%nonlinearlayer)
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! - construct nonlinear fault creep structure (rate-strenghtening)
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- IF (ALLOCATED(in%faultcreeplayer)) THEN
- CALL viscoelasticstructure(in%faultcreepstruc,in%faultcreeplayer,in%dx3)
- DEALLOCATE(in%faultcreeplayer)
- END IF
-
- ! first event
- e=1
- ! first output
- oi=1;
- ! initial condition
- t=0
-
- ! sources
- CALL dislocations(in%events(e),in%lambda,in%mu,in%beta,in%sx1,in%sx2,in%sx3, &
- in%dx1,in%dx2,in%dx3,v1,v2,v3,t1,t2,t3,tau)
- CALL traction(in%mu,in%events(e),in%sx1,in%sx2,in%dx1,in%dx2,t,0.d0,t3)
-
- PRINT '("coseismic event ",I3.3)', e
- PRINT 0990
-
- ! export the amplitude of eigenstrain
- CALL exporteigenstrain(gamma,in%nop,in%op,in%x0,in%y0, &
- in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,in%wdir,0)
-
- ! export equivalent body forces
- IF (isoutput(in%skip,t,i,in%odt,oi,in%events(e)%time)) THEN
-#ifdef GRD_EQBF
- IF (in%isoutputgrd) THEN
- CALL exportgrd(v1,v2,v3,in%sx1,in%sx2,in%sx3/2, &
- in%dx1,in%dx2,in%dx3,0.7_8,in%x0,in%y0,in%wdir,0,convention=3)
- END IF
-#endif
- END IF
-
- ! test the presence of dislocations for coseismic calculation
- IF ((in%events(e)%nt .NE. 0) .OR. &
- (in%events(e)%ns .NE. 0) .OR. &
- (in%events(e)%nm .NE. 0) .OR. &
- (in%events(e)%nl .NE. 0)) THEN
-
- ! apply the 3d elastic transfer function
- CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3, &
- in%dx1,in%dx2,in%dx3,in%lambda,in%mu,in%gam)
- END IF
-
- ! transfer solution
- CALL fieldrep(u1,v1,in%sx1+2,in%sx2,in%sx3/2)
- CALL fieldrep(u2,v2,in%sx1+2,in%sx2,in%sx3/2)
- CALL fieldrep(u3,v3,in%sx1+2,in%sx2,in%sx3/2)
-
- ! evaluate stress
- CALL tensorfieldadd(sig,tau,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=-1._4)
- CALL stressupdate(u1,u2,u3,in%lambda,in%mu, &
- in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,sig)
-
- ! export displacements
-#ifdef TXT
- IF (in%isoutputtxt) THEN
- CALL exporttxt(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%oz,in%dx3,0,0._8,in%wdir,in%reportfilename)
- END IF
-#endif
-#ifdef XYZ
- IF (in%isoutputxyz) THEN
- CALL exportxyz(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%oz,in%dx1,in%dx2,in%dx3,0,in%wdir)
- END IF
-#endif
-#ifdef GRD
- IF (in%isoutputgrd) THEN
- CALL exportgrd(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,in%x0,in%y0,in%wdir,0)
- IF (in%isoutputrelax) THEN
- CALL exportgrd(inter1,inter2,inter3,in%sx1,in%sx2,in%sx3/2, &
- in%dx1,in%dx2,in%dx3,0._8,in%x0,in%y0,in%wdir,0,convention=2)
- END IF
- END IF
-#endif
-#ifdef PROJ
- IF (in%isoutputproj) THEN
- CALL exportproj(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz, &
- in%x0,in%y0,in%lon0,in%lat0,in%zone,in%umult,in%wdir,0)
- END IF
-#endif
-#ifdef VTK
- IF (in%isoutputvtk) THEN
- !filename=trim(in%wdir)//"/disp-000.vtr"
- !CALL exportvtk_vectors(u1,u2,u3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3,8,8,8,filename)
- filename=trim(in%wdir)//"/disp-000.vtk"//char(0)
- title="coseismic displacement vector field"//char(0)
- name="displacement"//char(0)
- CALL exportvtk_vectors_legacy(u1,u2,u3,in%sx1,in%sx2,in%sx3/8,in%dx1,in%dx2,in%dx3, &
- 4,4,8,filename,title,name)
- !CALL exportvtk_vectors_slice(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,8,8,filename)
- END IF
- IF (in%isoutputvtkrelax) THEN
- filename=trim(in%wdir)//"/disp-relax-000.vtk"//char(0)
- title="postseismic displacement vector field"//char(0)
- name="displacement"//char(0)
- CALL exportvtk_vectors_legacy(u1r,u2r,u3r,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3, &
- 4,4,8,filename,title,name)
- END IF
-#endif
- IF (ALLOCATED(in%ptsname)) THEN
- CALL exportpoints(u1,u2,u3,sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- in%opts,in%ptsname,0._8,in%wdir,.true.,in%x0,in%y0,in%rot)
- END IF
-
- ! export initial stress
-#ifdef GRD
- CALL exportplanestress(sig,in%nop,in%op,in%x0,in%y0,in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,in%wdir,oi)
- IF (in%isoutputgrd .AND. in%isoutputstress) THEN
- CALL exportstressgrd(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- in%ozs,in%x0,in%y0,in%wdir,0)
- END IF
-#endif
-#ifdef PROJ
- IF (in%isoutputproj .AND. in%isoutputstress) THEN
- CALL exportstressproj(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%ozs, &
- in%x0,in%y0,in%lon0,in%lat0,in%zone,in%umult,in%wdir,0)
- END IF
-#endif
- ! initialize stress conditions
- CALL export_rfaults_stress_init(sig,in%sx1,in%sx2,in%sx3, &
- in%dx1,in%dx2,in%dx3,in%nsop,in%sop)
- WRITE (digit4,'(I4.4)') 0
-#ifdef VTK
- IF (in%isoutputvtk .AND. in%isoutputstress) THEN
- filename=trim(in%wdir)//"/sigma-"//digit4//".vtk"//char(0)
- title="stress tensor field"//char(0)
- name="stress"//char(0)
- CALL exportvtk_tensors_legacy(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- 4,4,8,filename,title,name)
- END IF
- ! coseismic stress change on predefined planes for 3-D visualization w/ Paraview
- filename=trim(in%wdir)//"/rfaults-sigma-"//digit4//".vtp"
- CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,filename,sig=sig)
- ! postseismic stress change on predefined planes (zero by definition)
- filename=trim(in%wdir)//"/rfaults-dsigma-"//digit4//".vtp"
- CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,filename)
-#endif
- ! coseismic stress change on predefined planes for gmt
- filename=trim(in%wdir)//"/rfaults-sigma-"//digit4//".xy"
- CALL exportgmt_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,filename,sig=sig)
- ! postseismic stress change on predefined planes for gmt (zero by definition)
- filename=trim(in%wdir)//"/rfaults-dsigma-"//digit4//".xy"
- CALL exportgmt_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,filename)
- ! time series of stress in ASCII format
- CALL exportcoulombstress(sig,in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,0._8,in%wdir,.TRUE.)
- CALL reporttime(0,0._8,in%reporttimefilename)
-
- PRINT 1101,0,0._8,0._8,0._8,0._8,0._8,in%interval,0._8,tensoramplitude(tau,in%dx1,in%dx2,in%dx3)
- IF (in%interval .LE. 0) THEN
- GOTO 100 ! no time integration
- END IF
-
- ALLOCATE(moment(in%sx1,in%sx2,in%sx3/2),STAT=iostatus)
- IF (iostatus>0) STOP "could not allocate the mechanical structure"
-
- !CALL tensorfieldadd(sig,sig,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=0._4)
- CALL tensorfieldadd(moment,moment,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=0._4)
-
- DO i=1,ITERATION_MAX
- IF (t .GE. in%interval) GOTO 100 ! proper exit
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! predictor
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
- ! initialize large time step
- tm=STEP_MAX;
- maxwell(:)=STEP_MAX;
-
- ! active mechanism flag
- mech(:)=0
-
- ! initialize no forcing term in tensor space
- CALL tensorfieldadd(moment,moment,in%sx1,in%sx2,in%sx3/2,0._4,0._4)
-
- ! power density from three mechanisms (linear and power-law viscosity
- ! and fault creep)
- ! 1- linear viscosity
- IF (ALLOCATED(in%linearstruc)) THEN
- CALL viscouseigenstress(in%mu,in%linearstruc,in%linearweakzone,in%nlwz, &
- sig,in%sx1,in%sx2,in%sx3/2, &
- in%dx1,in%dx2,in%dx3,moment,0.01_8,MAXWELLTIME=maxwell(1))
- mech(1)=1
- END IF
-
- ! 2- powerlaw viscosity
- IF (ALLOCATED(in%nonlinearstruc)) THEN
- CALL viscouseigenstress(in%mu,in%nonlinearstruc,in%nonlinearweakzone,in%nnlwz, &
- sig,in%sx1,in%sx2,in%sx3/2, &
- in%dx1,in%dx2,in%dx3,moment,0.01_8,MAXWELLTIME=maxwell(2))
- mech(2)=1
- END IF
-
- ! 3- nonlinear fault creep with rate-strengthening friction
- IF (ALLOCATED(in%faultcreepstruc)) THEN
- DO k=1,in%np
- CALL frictioneigenstress(in%n(k)%x,in%n(k)%y,in%n(k)%z, &
- in%n(k)%width,in%n(k)%length, &
- in%n(k)%strike,in%n(k)%dip,in%n(k)%rake,in%beta, &
- sig,in%mu,in%faultcreepstruc, &
- in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- moment,maxwelltime=maxwell(3))
- END DO
- mech(3)=1
- END IF
-
-#ifdef VTK
- IF (in%isoutputvtk .AND. in%isoutputstress) THEN
- WRITE (digit,'(I3.3)') oi-1
- filename=trim(in%wdir)//"/power-"//digit//".vtk"//char(0)
- title="stress rate tensor field"//char(0)
- name="power"//char(0)
- CALL exportvtk_tensors_legacy(moment,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- 4,4,8,filename,title,name)
- END IF
-#endif
-
- ! identify the required time step
- tm=1._8/(REAL(mech(1))/maxwell(1)+ &
- REAL(mech(2))/maxwell(2)+ &
- REAL(mech(3))/maxwell(3))
- ! force finite time step
- tm=MIN(tm,STEP_MAX)
-
- ! modify
- IF ((in%inter%ns .GT. 0) .OR. (in%inter%nt .GT. 0)) THEN
- IF (tm .EQ. STEP_MAX) THEN
- ! no relaxation occurs, pick a small integration time
- tm=in%interval/20._8
- END IF
- END IF
-
- ! choose an integration time step
- CALL integrationstep(tm,Dt,t,oi,in%odt,in%skip,in%tscale,in%events,e,in%ne)
-
- CALL tensorfieldadd(sig,moment,in%sx1,in%sx2,in%sx3/2,c1=0.0_4,c2=1._4)
-
- v1=0;v2=0;v3=0;t1=0;t2=0;t3=0;
- CALL equivalentbodyforce(sig,in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,v1,v2,v3,t1,t2,t3)
-
- ! add time-dependent surface loads
- CALL traction(in%mu,in%events(e),in%sx1,in%sx2,in%dx1,in%dx2,t,Dt/2.d8,t3,rate=.TRUE.)
-
- CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3,in%dx1,in%dx2,in%dx3,in%lambda,in%mu,in%gam)
-
- ! v1,v2,v3 contain the predictor displacement
- CALL fieldadd(v1,u1,in%sx1+2,in%sx2,in%sx3/2,c1=REAL(Dt/2))
- CALL fieldadd(v2,u2,in%sx1+2,in%sx2,in%sx3/2,c1=REAL(Dt/2))
- CALL fieldadd(v3,u3,in%sx1+2,in%sx2,in%sx3/2,c1=REAL(Dt/2))
- CALL tensorfieldadd(sig,tau,in%sx1,in%sx2,in%sx3/2,c1=-REAL(Dt/2),c2=-1._4)
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! corrector
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- CALL stressupdate(v1,v2,v3,in%lambda,in%mu, &
- in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,sig)
-
- ! reinitialize moment density tensor
- CALL tensorfieldadd(moment,moment,in%sx1,in%sx2,in%sx3/2,0._4,0._4)
-
- IF (ALLOCATED(in%linearstruc)) THEN
- ! linear viscosity
- v1=0
- CALL viscouseigenstress(in%mu,in%linearstruc,in%linearweakzone,in%nlwz,sig, &
- in%sx1,in%sx2,in%sx3/2, &
- in%dx1,in%dx2,in%dx3,moment,0.01_8,GAMMA=v1)
-
- ! update slip history
- CALL fieldadd(gamma,v1,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
- END IF
-
- IF (ALLOCATED(in%nonlinearstruc)) THEN
- ! powerlaw viscosity
- v1=0
- CALL viscouseigenstress(in%mu,in%nonlinearstruc,in%nonlinearweakzone,in%nnlwz,sig, &
- in%sx1,in%sx2,in%sx3/2, &
- in%dx1,in%dx2,in%dx3,moment,0.01_8,GAMMA=v1)
-
- ! update slip history
- CALL fieldadd(gamma,v1,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
- END IF
-
- ! nonlinear fault creep with rate-strengthening friction
- IF (ALLOCATED(in%faultcreepstruc)) THEN
-
- ! use v1 as placeholders for the afterslip planes
- DO k=1,in%np
- ! one may use optional arguments ...,VEL=v1) to convert
- ! fault slip to eigenstrain (scalar)
- CALL frictioneigenstress(in%n(k)%x,in%n(k)%y,in%n(k)%z, &
- in%n(k)%width,in%n(k)%length, &
- in%n(k)%strike,in%n(k)%dip,in%n(k)%rake,in%beta, &
- sig,in%mu,in%faultcreepstruc,in%sx1,in%sx2,in%sx3/2, &
- in%dx1,in%dx2,in%dx3,moment)
- END DO
-
- ! export strike and dip creep velocity
- IF (isoutput(in%skip,t,i,in%odt,oi,in%events(e)%time)) THEN
- CALL exportcreep(in%np,in%n,in%beta,sig,in%faultcreepstruc, &
- in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%x0,in%y0,in%wdir,oi)
- END IF
-
- END IF
-
- ! interseismic loading
- IF ((in%inter%ns .GT. 0) .OR. (in%inter%nt .GT. 0)) THEN
- ! vectors v1,v2,v3 are not affected.
- CALL dislocations(in%inter,in%lambda,in%mu,in%beta,in%sx1,in%sx2,in%sx3, &
- in%dx1,in%dx2,in%dx3,v1,v2,v3,t1,t2,t3,tau,eigenstress=moment)
- END IF
-
- v1=0;v2=0;v3=0;t1=0;t2=0;t3=0;
- CALL equivalentbodyforce(moment,in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,v1,v2,v3,t1,t2,t3)
-
- ! add time-dependent surface loads
- CALL traction(in%mu,in%events(e),in%sx1,in%sx2,in%dx1,in%dx2,t,Dt,t3,rate=.true.)
-
- ! export equivalent body forces
- IF (isoutput(in%skip,t,i,in%odt,oi,in%events(e)%time)) THEN
-#ifdef VTK_EQBF
- IF (in%isoutputvtk) THEN
- WRITE (digit,'(I3.3)') oi
- !filename=trim(in%wdir)//"/eqbf-"//digit//".vtr"
- !CALL exportvtk_vectors(v1,v2,v3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3,8,8,8,filename)
- filename=trim(in%wdir)//"/eqbf-"//digit//".vtk"//char(0)
- title="instantaneous equivalent body-force rate vector field"//char(0)
- name="body-force-rate"//char(0)
- CALL exportvtk_vectors_legacy(v1,v2,v3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3, &
- 4,4,8,filename,title,name)
- END IF
-#endif
-#ifdef GRD_EQBF
- IF (in%isoutputgrd) THEN
- CALL exportgrd(v1,v2,v3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- in%oz,in%x0,in%y0,in%wdir,oi,convention=3)
- END IF
-#endif
- END IF
-
- CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3,in%dx1,in%dx2,in%dx3,in%lambda,in%mu,in%gam)
-
- ! update deformation field
- CALL fieldadd(u1,v1,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
- CALL fieldadd(u2,v2,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
- CALL fieldadd(u3,v3,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
- CALL tensorfieldadd(tau,moment,in%sx1,in%sx2,in%sx3/2,c2=REAL(Dt))
-
- ! keep track of the viscoelastic contribution alone
- IF (in%isoutputrelax) THEN
- CALL sliceadd(inter1(:,:,1),v1,in%sx1+2,in%sx2,in%sx3,int(in%oz/in%dx3)+1,c2=REAL(Dt))
- CALL sliceadd(inter2(:,:,1),v2,in%sx1+2,in%sx2,in%sx3,int(in%oz/in%dx3)+1,c2=REAL(Dt))
- CALL sliceadd(inter3(:,:,1),v3,in%sx1+2,in%sx2,in%sx3,int(in%oz/in%dx3)+1,c2=REAL(Dt))
- END IF
-
-#ifdef VTK
- IF (in%isoutputvtkrelax) THEN
- u1r=u1r+Dt*v1
- u2r=u2r+Dt*v2
- u3r=u3r+Dt*v3
- END IF
-#endif
-
- ! time increment
- t=t+Dt
-
- ! next event
- IF (e .LT. in%ne) THEN
- IF (abs(t-in%events(e+1)%time) .LT. 1e-6) THEN
- e=e+1
- in%events(e)%i=i
-
- PRINT '("coseismic event ",I3.3)', e
- PRINT 0990
-
- v1=0;v2=0;v3=0;t1=0;t2=0;t3=0;
- CALL dislocations(in%events(e),in%lambda,in%mu, &
- in%beta,in%sx1,in%sx2,in%sx3, &
- in%dx1,in%dx2,in%dx3,v1,v2,v3,t1,t2,t3,tau)
- CALL traction(in%mu,in%events(e),in%sx1,in%sx2,in%dx1,in%dx2,t,0.d0,t3)
-
- ! apply the 3d elastic transfert function
- CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3, &
- in%dx1,in%dx2,in%dx3,in%lambda,in%mu,in%gam)
-
- ! transfer solution
- CALL fieldadd(u1,v1,in%sx1+2,in%sx2,in%sx3/2)
- CALL fieldadd(u2,v2,in%sx1+2,in%sx2,in%sx3/2)
- CALL fieldadd(u3,v3,in%sx1+2,in%sx2,in%sx3/2)
-
- END IF
- END IF
-
- CALL tensorfieldadd(sig,tau,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=-1._4)
- CALL stressupdate(u1,u2,u3,in%lambda,in%mu, &
- in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,sig)
-
- ! points are exported at all time steps
- IF (ALLOCATED(in%ptsname)) THEN
- CALL exportpoints(u1,u2,u3,sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- in%opts,in%ptsname,t,in%wdir,.FALSE.,in%x0,in%y0,in%rot)
- END IF
-
- ! output only at discrete intervals (skip=0, odt>0),
- ! or every "skip" computational steps (skip>0, odt<0),
- ! or anytime a coseismic event occurs
- IF (isoutput(in%skip,t,i,in%odt,oi,in%events(e)%time)) THEN
-
- CALL reporttime(1,t,in%reporttimefilename)
-
- ! export
-#ifdef TXT
- IF (in%isoutputtxt) THEN
- CALL exporttxt(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%oz,in%dx3,oi,t,in%wdir,in%reportfilename)
- END IF
-#endif
-#ifdef XYZ
- IF (in%isoutputxyz) THEN
- CALL exportxyz(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%oz,in%dx1,in%dx2,in%dx3,i,in%wdir)
- IF (in%isoutputrelax) THEN
- !CALL exportxyz(inter1,inter2,inter3,in%sx1,in%sx2,in%sx3/2,0.0_8,in%dx1,in%dx2,in%dx3,i,in%wdir)
- END IF
- END IF
-#endif
- CALL exporteigenstrain(gamma,in%nop,in%op,in%x0,in%y0,in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,in%wdir,oi)
-#ifdef GRD
- IF (in%isoutputgrd) THEN
- IF (in%isoutputrelax) THEN
- CALL exportgrd(inter1,inter2,inter3,in%sx1,in%sx2,in%sx3/2, &
- in%dx1,in%dx2,in%dx3,0._8,in%x0,in%y0,in%wdir,oi,convention=2)
- END IF
- CALL exportgrd(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,in%x0,in%y0,in%wdir,oi)
- END IF
-#endif
-#ifdef PROJ
- IF (in%isoutputproj) THEN
- IF (in%isoutputrelax) THEN
- CALL exportproj(inter1,inter2,inter3,in%sx1,in%sx2,in%sx3/2, &
- in%dx1,in%dx2,in%dx3,in%oz,in%x0,in%y0, &
- in%lon0,in%lat0,in%zone,in%umult,in%wdir,oi,convention=2)
- END IF
- CALL exportproj(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,in%x0,in%y0, &
- in%lon0,in%lat0,in%zone,in%umult,in%wdir,oi)
- END IF
-#endif
-#ifdef VTK
- IF (in%isoutputvtk) THEN
- WRITE (digit,'(I3.3)') oi
- ! export total displacement in VTK XML format
- !filename=trim(in%wdir)//"/disp-"//digit//".vtr"
- !CALL exportvtk_vectors(u1,u2,u3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3,8,8,8,filename)
- filename=trim(in%wdir)//"/disp-"//digit//".vtk"//char(0)
- title="cumulative displacement vector field"//char(0)
- name="displacement"//char(0)
- CALL exportvtk_vectors_legacy(u1,u2,u3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3, &
- 4,4,8,filename,title,name)
- !CALL exportvtk_vectors_slice(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,8,8,filename)
-
- ! export instantaneous velocity in VTK XML format
- !filename=trim(in%wdir)//"/vel-"//digit//".vtr"
- !CALL exportvtk_vectors(v1,v2,v3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3,8,8,8,filename)
- filename=trim(in%wdir)//"/vel-"//digit//".vtk"//char(0)
- title="instantaneous velocity vector field"//char(0)
- name="velocity"//char(0)
- CALL exportvtk_vectors_legacy(v1,v2,v3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- 8,8,16,filename,title,name)
- !CALL exportvtk_vectors_slice(v1,v2,v3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,8,8,filename)
- END IF
- IF (in%isoutputvtkrelax) THEN
- WRITE (digit,'(I3.3)') oi
- filename=trim(in%wdir)//"/disp-relax-"//digit//".vtk"//char(0)
- title="postseismic displacement vector field"//char(0)
- name="displacement"//char(0)
- CALL exportvtk_vectors_legacy(u1r,u2r,u3r,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3, &
- 4,4,8,filename,title,name)
- END IF
-#endif
-
- ! export stress
-#ifdef GRD
- IF (in%isoutputgrd .AND. in%isoutputstress) THEN
- CALL exportstressgrd(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- in%ozs,in%x0,in%y0,in%wdir,oi)
- END IF
-#endif
-#ifdef PROJ
- IF (in%isoutputproj .AND. in%isoutputstress) THEN
- CALL exportstressproj(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%ozs, &
- in%x0,in%y0,in%lon0,in%lat0,in%zone,in%umult,in%wdir,oi)
- END IF
-#endif
- WRITE (digit4,'(I4.4)') oi
-#ifdef VTK
- IF (in%isoutputvtk .AND. in%isoutputstress) THEN
- filename=trim(in%wdir)//"/sigma-"//digit4//".vtk"//char(0)
- title="stress tensor field"//char(0)
- name="stress"//char(0)
- CALL exportvtk_tensors_legacy(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
- 4,4,8,filename,title,name)
- END IF
- filename=trim(in%wdir)//"/rfaults-sigma-"//digit4//".vtp"
- CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,filename,sig=sig)
- filename=trim(in%wdir)//"/rfaults-dsigma-"//digit4//".vtp"
- CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,filename,convention=1,sig=sig)
-#endif
- ! total stress on predefined planes for gmt
- filename=trim(in%wdir)//"/rfaults-sigma-"//digit4//".xy"
- CALL exportgmt_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,filename,sig=sig)
- ! postseismic stress change on predefined planes for gm
- filename=trim(in%wdir)//"/rfaults-dsigma-"//digit4//".xy"
- CALL exportgmt_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,filename,convention=1,sig=sig)
- ! time series of stress in ASCII format
- CALL exportcoulombstress(sig,in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
- in%nsop,in%sop,t,in%wdir,.FALSE.)
-
- PRINT 1101,i,Dt,maxwell,t,in%interval, &
- tensoramplitude(moment,in%dx1,in%dx2,in%dx3), &
- tensoramplitude(tau,in%dx1,in%dx2,in%dx3)
-
- ! update output counter
- oi=oi+1
- ELSE
- PRINT 1100,i,Dt,maxwell,t,in%interval, &
- tensoramplitude(moment,in%dx1,in%dx2,in%dx3), &
- tensoramplitude(tau,in%dx1,in%dx2,in%dx3)
- END IF
-
- END DO
-
-100 CONTINUE
-
- DO i=1,in%ne
- IF (ALLOCATED(in%events(i)%s)) DEALLOCATE(in%events(i)%s,in%events(i)%sc)
- IF (ALLOCATED(in%events(i)%ts)) DEALLOCATE(in%events(i)%ts,in%events(i)%tsc)
- END DO
- IF (ALLOCATED(in%events)) DEALLOCATE(in%events)
-
- ! free memory
- IF (ALLOCATED(gamma)) DEALLOCATE(gamma)
- IF (ALLOCATED(in%opts)) DEALLOCATE(in%opts)
- IF (ALLOCATED(in%ptsname)) DEALLOCATE(in%ptsname)
- IF (ALLOCATED(in%op)) DEALLOCATE(in%op)
- IF (ALLOCATED(in%sop)) DEALLOCATE(in%sop)
- IF (ALLOCATED(in%n)) DEALLOCATE(in%n)
- IF (ALLOCATED(in%stressstruc)) DEALLOCATE(in%stressstruc)
- IF (ALLOCATED(in%stresslayer)) DEALLOCATE(in%stresslayer)
- IF (ALLOCATED(in%linearstruc)) DEALLOCATE(in%linearstruc)
- IF (ALLOCATED(in%linearlayer)) DEALLOCATE(in%linearlayer)
- IF (ALLOCATED(in%linearweakzone)) DEALLOCATE(in%linearweakzone)
- IF (ALLOCATED(in%nonlinearstruc)) DEALLOCATE(in%nonlinearstruc)
- IF (ALLOCATED(in%nonlinearlayer)) DEALLOCATE(in%nonlinearlayer)
- IF (ALLOCATED(in%nonlinearweakzone)) DEALLOCATE(in%nonlinearweakzone)
- IF (ALLOCATED(in%faultcreepstruc)) DEALLOCATE(in%faultcreepstruc)
- IF (ALLOCATED(in%faultcreeplayer)) DEALLOCATE(in%faultcreeplayer)
- IF (ALLOCATED(sig)) DEALLOCATE(sig)
- IF (ALLOCATED(tau)) DEALLOCATE(tau)
- IF (ALLOCATED(moment)) DEALLOCATE(moment)
- IF (ALLOCATED(in%stresslayer)) DEALLOCATE(in%stresslayer)
- IF (ALLOCATED(in%linearlayer)) DEALLOCATE(in%linearlayer)
- IF (ALLOCATED(in%nonlinearlayer)) DEALLOCATE(in%nonlinearlayer)
- IF (ALLOCATED(in%faultcreeplayer)) DEALLOCATE(in%faultcreeplayer)
- IF (ALLOCATED(v1)) DEALLOCATE(v1,v2,v3,t1,t2,t3)
- IF (ALLOCATED(u1)) DEALLOCATE(u1,u2,u3)
- IF (ALLOCATED(inter1)) DEALLOCATE(inter1,inter2,inter3)
-
-
-#ifdef FFTW3_THREADS
- CALL sfftw_cleanup_threads()
-#endif
-
-0990 FORMAT (" I | Dt | tm(ve) | tm(pl) | tm(as) | t/tmax | power | C:E^i | ")
-1000 FORMAT (I3.3,"*",ES9.2E2," ",ES9.2E2,"/",ES7.2E1)
-1100 FORMAT (I3.3," ",ES9.2E2,3ES9.2E2,ES9.2E2,"/",ES7.2E1,2ES9.2E2)
-1101 FORMAT (I3.3,"*",ES9.2E2,3ES9.2E2,ES9.2E2,"/",ES7.2E1,2ES9.2E2)
-1200 FORMAT ("----------------------------------------------------------------------------")
-
-CONTAINS
-
- !--------------------------------------------------------------------
- !> subroutine dislocations
- !! assigns equivalent body forces or moment density to simulate
- !! shear dislocations and fault opening. add the corresponding moment
- !! density in the cumulative relaxed moment so that fault slip does
- !! not reverse in the postseismic time.
- !--------------------------------------------------------------------
- SUBROUTINE dislocations(event,lambda,mu,beta,sx1,sx2,sx3,dx1,dx2,dx3, &
- v1,v2,v3,t1,t2,t3,tau,factor,eigenstress)
- TYPE(EVENT_STRUC), INTENT(IN) :: event
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: lambda,mu,beta,dx1,dx2,dx3
- REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: v1,v2,v3
- REAL*4, DIMENSION(:,:), INTENT(INOUT) :: t1,t2,t3
- TYPE(TENSOR), DIMENSION(:,:,:), INTENT(INOUT) :: tau
- REAL*8, INTENT(IN), OPTIONAL :: factor
- TYPE(TENSOR), DIMENSION(:,:,:), INTENT(INOUT), OPTIONAL :: eigenstress
-
- INTEGER :: i
- REAL*8 :: slip_factor
-
- IF (PRESENT(factor)) THEN
- slip_factor=factor
- ELSE
- slip_factor=1._8
- END IF
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! - load shear dislocations
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- IF (.NOT. (PRESENT(eigenstress))) THEN
- ! forcing term in equivalent body force
- DO i=1,event%ns
- ! adding sources in the space domain
- CALL source(mu,slip_factor*event%s(i)%slip, &
- event%s(i)%x,event%s(i)%y,event%s(i)%z, &
- event%s(i)%width,event%s(i)%length, &
- event%s(i)%strike,event%s(i)%dip,event%s(i)%rake, &
- event%s(i)%beta,sx1,sx2,sx3,dx1,dx2,dx3,v1,v2,v3,t1,t2,t3)
- END DO
- ELSE
- ! forcing term in moment density
- DO i=1,event%ns
- CALL momentdensityshear(mu,slip_factor*event%s(i)%slip, &
- event%s(i)%x,event%s(i)%y,event%s(i)%z, &
- event%s(i)%width,event%s(i)%length, &
- event%s(i)%strike,event%s(i)%dip,event%s(i)%rake, &
- event%s(i)%beta,sx1,sx2,sx3/2,dx1,dx2,dx3,eigenstress)
- END DO
- END IF
-
- DO i=1,event%ns
- ! remove corresponding eigenmoment
- CALL momentdensityshear(mu,slip_factor*event%s(i)%slip, &
- event%s(i)%x,event%s(i)%y,event%s(i)%z, &
- event%s(i)%width,event%s(i)%length, &
- event%s(i)%strike,event%s(i)%dip,event%s(i)%rake, &
- event%s(i)%beta,sx1,sx2,sx3/2,dx1,dx2,dx3,tau)
- END DO
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! - load tensile cracks
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- IF (.NOT. (PRESENT(eigenstress))) THEN
- ! forcing term in equivalent body force
- DO i=1,event%nt
- ! adding sources in the space domain
- CALL tensilesource(lambda,mu,slip_factor*event%ts(i)%slip, &
- event%ts(i)%x,event%ts(i)%y,event%ts(i)%z, &
- event%ts(i)%width,event%ts(i)%length, &
- event%ts(i)%strike,event%ts(i)%dip, &
- beta,sx1,sx2,sx3,dx1,dx2,dx3,v1,v2,v3)
- END DO
- ELSE
- ! forcing term in moment density
- DO i=1,event%nt
- CALL momentdensitytensile(lambda,mu,slip_factor*event%ts(i)%slip, &
- event%ts(i)%x,event%ts(i)%y,event%ts(i)%z,&
- event%ts(i)%width,event%ts(i)%length, &
- event%ts(i)%strike,event%ts(i)%dip,event%ts(i)%rake, &
- beta,sx1,sx2,sx3/2,dx1,dx2,dx3,eigenstress)
- END DO
- END IF
-
- DO i=1,event%nt
- ! removing corresponding eigenmoment
- CALL momentdensitytensile(lambda,mu,slip_factor*event%ts(i)%slip, &
- event%ts(i)%x,event%ts(i)%y,event%ts(i)%z,&
- event%ts(i)%width,event%ts(i)%length, &
- event%ts(i)%strike,event%ts(i)%dip,event%ts(i)%rake, &
- beta,sx1,sx2,sx3/2,dx1,dx2,dx3,tau)
- END DO
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ! - load point dilatation sources
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- IF (.NOT. (PRESENT(eigenstress))) THEN
- ! forcing term in equivalent body force
- DO i=1,event%nm
- ! adding sources in the space domain
- CALL mogisource(lambda,mu,slip_factor*event%m(i)%slip, &
- event%m(i)%x,event%m(i)%y,event%m(i)%z, &
- sx1,sx2,sx3,dx1,dx2,dx3,v1,v2,v3)
- END DO
- ELSE
- ! forcing term in moment density
- DO i=1,event%nm
- CALL momentdensitymogi(lambda,mu,slip_factor*event%m(i)%slip, &
- event%m(i)%x,event%m(i)%y,event%m(i)%z, &
- sx1,sx2,sx3/2,dx1,dx2,dx3,eigenstress)
- END DO
- END IF
-
- DO i=1,event%nm
- ! remove corresponding eigenmoment
- CALL momentdensitymogi(lambda,mu,slip_factor*event%m(i)%slip, &
- event%m(i)%x,event%m(i)%y,event%m(i)%z, &
- sx1,sx2,sx3/2,dx1,dx2,dx3,tau)
- END DO
-
- END SUBROUTINE dislocations
-
- !--------------------------------------------------------------------
- !> function IsOutput
- !! checks if output should be written based on user choices: if output
- !! time interval (odt) is positive, output is written only if time
- !! is an integer of odt. If odt is negative output is written at times
- !! corresponding to internally chosen time steps.
- !!
- !! @return IsOutput is true only at discrete intervals (skip=0,odt>0),
- !! or at every "skip" computational steps (skip>0,odt<0),
- !! or anytime a coseismic event occurs
- !
- ! Sylvain Barbot (07/06/09) - original form
- !--------------------------------------------------------------------
- LOGICAL FUNCTION isoutput(skip,t,i,odt,oi,etime)
- INTEGER, INTENT(IN) :: skip,i,oi
- REAL*8, INTENT(IN) :: t,odt,etime
-
- IF (((0 .EQ. skip) .AND. (abs(t-oi*odt) .LT. 1e-6*odt)) .OR. &
- ((0 .LT. skip) .AND. (MOD(i-1,skip) .EQ. 0)) .OR. &
- (abs(t-etime) .LT. 1e-6)) THEN
- isoutput=.TRUE.
- ELSE
- isoutput=.FALSE.
- END IF
-
- END FUNCTION isoutput
-
- !--------------------------------------------------------------------
- !> subroutine IntegrationStep
- !! find the time-integration forward step for the predictor-corrector
- !! scheme.
- !!
- !! input file line
- !!
- !! time interval, (positive dt step) or (negative skip and scaling)
- !!
- !! can be filled by either 1)
- !!
- !! T, dt
- !!
- !! where T is the time interval of the simulation and dt is the
- !! output time step, or 2)
- !!
- !! T, -n, t_s
- !!
- !! where n indicates the number of computational steps before
- !! outputing results, t_s is a scaling applied to internally
- !! computed time step.
- !!
- !! for case 1), an optimal time step is evaluated internally to
- !! ensure stability (t_m/10) of time integration. The actual
- !! time step Dt is chosen as
- !!
- !! Dt = min( t_m/10, ((t%odt)+1)*odt-t )
- !!
- !! where t is the current time in the simulation. regardless of
- !! time step Dt, results are output if t is a multiple of dt.
- !!
- !! for case 2), the time step is chosen internally based on an
- !! estimate of the relaxation time (t_m/10). Results are output
- !! every n steps. The actual time step is chosen as
- !!
- !! Dt = min( t_m/10*t_s, t(next event)-t )
- !!
- !! where index is the number of computational steps after a coseismic
- !! event and t(next event) is the time of the next coseismic event.
- !!
- !! \author sylvain barbot (01/01/08) - original form
- !--------------------------------------------------------------------
- SUBROUTINE integrationstep(tm,Dt,t,oi,odt,skip,tscale,events,e,ne)
- REAL*8, INTENT(INOUT) :: tm,Dt,odt
- REAL*8, INTENT(IN) :: t,tscale
- INTEGER, INTENT(IN) :: oi,e,ne,skip
- TYPE(EVENT_STRUC), INTENT(IN), DIMENSION(:) :: events
-
- ! output at optimal computational intervals
- Dt=tm/10._8
-
- ! reduce time in case something happens in [ t, t+Dt ]
- IF (0 .EQ. skip) THEN
- ! reduce time step so that t+Dt is time at next
- ! user-required output time
- IF ((t+Dt) .GE. (dble(oi)*odt)-Dt*0.04d0) THEN
- ! pick a smaller time step to reach :
- ! integers of odt
- Dt=dble(oi)*odt-t
- END IF
- ELSE
- ! scale the estimate of optimal time step
- Dt=Dt*tscale
-
- ! reduce time step so that t+Dt is time to next event
- IF (e .LT. ne) THEN
- IF ((t+Dt-events(e+1)%time) .GE. 0._8) THEN
- ! pick a smaller time step to reach
- ! next event time
- Dt=events(e+1)%time-t
- END IF
- END IF
- END IF
-
- END SUBROUTINE integrationstep
-
-END PROGRAM relax
diff -r 405d8f4fa05f -r e7295294f654 src/ctfft.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/ctfft.f Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,618 @@
+ subroutine ctfft (data,n,ndim,isign,iform,work,nwork) fft 1
+c cooley-tukey fast fourier transform in usasi basic fortran. fft 2
+c multi-dimensional transform, dimensions of arbitrary size, fft 3
+c complex or real data. n points can be transformed in time fft 4
+c proportional to n*log(n), whereas other methods take n**2 time. fft 5
+c furthermore, less error is built up. written by norman brenner fft 6
+c of mit lincoln laboratory, june 1968. fft 7
+c fft 8
+c dimension data(n(1),n(2),...),transform(n(1),n(2),...),n(ndim) fft 9
+c transform(k1,k2,...) = sum(data(j1,j2,...)*exp(isign*2*pi*sqrt(-1)fft 10
+c *((j1-1)*(k1-1)/n(1)+(j2-1)*(k2-1)/n(2)+...))), summed for all fft 11
+c j1 and k1 from 1 to n(1), j2 and k2 from 1 to n(2), etc. for all fft 12
+c ndim subscripts. ndim must be positive and each n(idim) may be fft 13
+c any integer. isign is +1 or -1. let ntot = n(1)*n(2)... fft 14
+c ...*n(ndim). then a -1 transform followed by a +1 one fft 15
+c (or vice versa) returns ntot times the original data. fft 16
+c iform = 1, 0 or -1, as data is complex, real or the fft 17
+c first half of a complex array. transform values are fft 18
+c returned to array data. they are complex, real or fft 19
+c the first half of a complex array, as iform = 1, -1 or 0. fft 20
+c the transform of a real array (iform = 0) dimensioned n(1) by n(2)fft 21
+c by ... will be returned in the same array, now considered to fft 22
+c be complex of dimensions n(1)/2+1 by n(2) by .... note that if fft 23
+c iform = 0 or -1, n(1) must be even, and enough room must be fft 24
+c reserved. the missing values may be obtained by complex conju- fft 25
+c gation. the reverse transformation, of a half complex array fft 26
+c dimensioned n(1)/2+1 by n(2) by ..., is accomplished setting iformfft 27
+c to -1. in the n array, n(1) must be the true n(1), not n(1)/2+1. fft 28
+c the transform will be real and returned to the input array. fft 29
+c work is a one-dimensional complex array used for working storage. fft 30
+c its length, nwork, need never be larger than the largest n(idim) fft 31
+c and frequently may be much smaller. fourt computes the minimum fft 32
+c length working storage required and checks that nwork is at least fft 33
+c as long. this minimum length is ccomputed as shown below. fft 34
+c fft 35
+c for example-- fft 36
+c dimension data(1960),work(10) fft 37
+c complex data,work fft 38
+c call fourt(data,1960,1,-1,+1,work,10) fft 39
+c fft 40
+c the multi-dimensional transform is broken down into one-dimen- fft 41
+c sional transforms of length n(idim). these are further broken fft 42
+c down into transforms of length ifact(if), where these are the fft 43
+c prime factors of n(idim). for example, n(1) = 1960, ifact(if) = fft 44
+c 2, 2, 2, 5, 7 and 7. the running time is proportional to ntot * fft 45
+c sum(ifact(if)), though factors of two and three will run espe- fft 46
+c cially fast. naive transform programs will run in time ntot**2. fft 47
+c arrays whose size ntot is prime will run much slower than those fft 48
+c with composite ntot. for example, ntot = n(1) = 1951 (a prime), fft 49
+c running time will be 1951*1951, while for ntot = 1960, it will fft 50
+c be 1960*(2+2+2+5+7+7), a speedup of eighty times. naive calcul- fft 51
+c ation will run both in the slower time. if an array is of fft 52
+c inconvenient length, simply add zeroes to pad it out. the resultsfft 53
+c will be interpolated according to the new length (see below). fft 54
+c fft 55
+c a fourier transform of length ifact(if) requires a work array fft 56
+c of that length. therefore, nwork must be as big as the largest fft 57
+c prime factor. further, work is needed for digit reversal-- fft 58
+c each n(idim) (but n(1)/2 if iform = 0 or -1) is factored symmetri-fft 59
+c cally, and nwork must be as big as the center factor. (to factor fft 60
+c symmetrically, separate pairs of identical factors to the flanks, fft 61
+c combining all leftovers in the center.) for example, n(1) = 1960 fft 62
+c =2*2*2*5*7*7=2*7*10*7*2, so nwork must at least max(7,10) = 10. fft 63
+c fft 64
+c an upper bound for the rms relative error is given by gentleman fft 65
+c and sande (3)-- 3 * 2**(-b) * sum(f**1.5), where 2**(-b) is the fft 66
+c smallest bit in the floating point fraction and the sum is over fft 67
+c the prime factors of ntot. fft 68
+c fft 69
+c if the input data are a time series, with index j representing fft 70
+c a time (j-1)*deltat, then the corresponding index k in the fft 71
+c transform represents the frequency (k-1)*2*pi/(n*deltat), which fft 72
+c by periodicity, is the same as frequency -(n-k+1)*2*pi/(n*deltat).fft 73
+c this is true for n = each n(idim) independently. fft 74
+c fft 75
+c references-- fft 76
+c 1. cooley, j.w. and tukey, j.w., an algorithm for the machine fft 77
+c calculation of complex fourier series. math. comp., 19, 90, fft 78
+c (april 1967), 297-301. fft 79
+c 2. rader, c., et al., what is the fast fourier transform, ieee fft 80
+c transactions on audio and electroacoustics, au-15, 2 (june 1967). fft 81
+c (special issue on the fast fourier transform and its applications)fft 82
+c 3. gentleman, w.m. and sande, g., fast fourier transforms-- fft 83
+c for fun and profit. 1966 fall joint comp. conf., spartan books, fft 84
+c washington, 1966. fft 85
+c 4. goertzel, g., an algorithm for the evaluation of finite fft 86
+c trigonometric series. am. math. mo., 65, (1958), 34-35. fft 87
+c 5. singleton, r.c., a method for computing the fast fourier fft 88
+c transform with auxiliary memory and limited high-speed storage. fft 89
+c in (2). fft 90
+ dimension data(*), n(1), work(*), ifsym(32), ifcnt(10), ifact(32) fft 91
+ if (iform) 10,10,40 fft 92
+ 10 if (n(1)-2*(n(1)/2)) 20,40,20 fft 93
+ 20 continue
+c20 write (6,30) iform,(n(idim),idim=1,ndim) fft 94
+c30 format ('error in fourt. iform = ',i2,'(real or half-complex)'
+c $' but n(1) is not even./14h dimensions = ',20i5) fft 96
+ return fft 97
+ 40 ntot=1 fft 98
+ do 50 idim=1,ndim fft 99
+ 50 ntot=ntot*n(idim) fft 100
+ nrem=ntot fft 101
+ if (iform) 60,70,70 fft 102
+ 60 nrem=1 fft 103
+ ntot=(ntot/n(1))*(n(1)/2+1) fft 104
+c loop over all dimensions. fft 105
+ 70 do 230 jdim=1,ndim fft 106
+ if (iform) 80,90,90 fft 107
+ 80 idim=ndim+1-jdim fft 108
+ go to 100 fft 109
+ 90 idim=jdim fft 110
+ nrem=nrem/n(idim) fft 111
+ 100 ncurr=n(idim) fft 112
+ if (idim-1) 110,110,140 fft 113
+ 110 if (iform) 120,130,140 fft 114
+ 120 call fixrl (data,n(1),nrem,isign,iform) fft 115
+ ntot=(ntot/(n(1)/2+1))*n(1) fft 116
+ 130 ncurr=ncurr/2 fft 117
+ 140 if (ncurr-1) 190,190,150 fft 118
+c factor n(idim), the length of this dimension. fft 119
+ 150 call factr (ncurr,ifact,nfact) fft 120
+ ifmax=ifact(nfact) fft 121
+c arrange the factors symmetrically for simpler digit reversal. fft 122
+ call smfac (ifact,nfact,isym,ifsym,nfsym,icent,ifcnt,nfcnt) fft 123
+ ifmax=max0(ifmax,icent) fft 124
+ if (ifmax-nwork) 180,180,160 fft 125
+ 160 continue
+c 160 write (6,170) nwork,idim,ncurr,icent,(ifact(if),if=1,nfact) fft 126
+c 170 format (26h0error in fourt. nwork = ,i4,20h is too small for n(, fft 127
+c $i1,4h) = ,i5,17h, whose center = ,i4,31h, and whose prime factors fft 128
+c $are--/(1x,20i5)) fft 129
+ return fft 130
+ 180 nprev=ntot/(n(idim)*nrem) fft 131
+c digit reverse on symmetric factors, for example 2*7*6*7*2. fft 132
+ call symrv (data,nprev,ncurr,nrem,ifsym,nfsym) fft 133
+c digit reverse the asymmetric center, for example, on 6 = 2*3. fft 134
+ call asmrv (data,nprev*isym,icent,isym*nrem,ifcnt,nfcnt,work) fft 135
+c fourier transform on each factor, for example, on 2,7,2,3,7 and 2.fft 136
+ call cool (data,nprev,ncurr,nrem,isign,ifact,work) fft 137
+ 190 if (iform) 200,210,230 fft 138
+ 200 nrem=nrem*n(idim) fft 139
+ go to 230 fft 140
+ 210 if (idim-1) 220,220,230 fft 141
+ 220 call fixrl (data,n(1),nrem,isign,iform) fft 142
+ ntot=ntot/n(1)*(n(1)/2+1) fft 143
+ 230 continue fft 144
+ return fft 145
+ end fft 146-
+ subroutine asmrv (data,nprev,n,nrem,ifact,nfact,work) asm 1
+c shuffle the data array by reversing the digits of one index. asm 2
+c the operation is the same as in symrv, except that the factors asm 3
+c need not be symmetrically arranged, i.e., generally ifact(if) not=asm 4
+c ifact(nfact+1-if). consequently, a work array of length n is asm 5
+c needed. asm 6
+ dimension data(*), work(*), ifact(1) asm 7
+ if (nfact-1) 60,60,10 asm 8
+ 10 ip0=2 asm 9
+ ip1=ip0*nprev asm 10
+ ip4=ip1*n asm 11
+ ip5=ip4*nrem asm 12
+ do 50 i1=1,ip1,ip0 asm 13
+ do 50 i5=i1,ip5,ip4 asm 14
+ iwork=1 asm 15
+ i4rev=i5 asm 16
+ i4max=i5+ip4-ip1 asm 17
+ do 40 i4=i5,i4max,ip1 asm 18
+ work(iwork)=data(i4rev) asm 19
+ work(iwork+1)=data(i4rev+1) asm 20
+ ip3=ip4 asm 21
+ do 30 if=1,nfact asm 22
+ ip2=ip3/ifact(if) asm 23
+ i4rev=i4rev+ip2 asm 24
+ if (i4rev-ip3-i5) 40,20,20 asm 25
+ 20 i4rev=i4rev-ip3 asm 26
+ 30 ip3=ip2 asm 27
+ 40 iwork=iwork+ip0 asm 28
+ iwork=1 asm 29
+ do 50 i4=i5,i4max,ip1 asm 30
+ data(i4)=work(iwork) asm 31
+ data(i4+1)=work(iwork+1) asm 32
+ 50 iwork=iwork+ip0 asm 33
+ 60 return asm 34
+ end asm 35-
+ subroutine cool (data,nprev,n,nrem,isign,ifact,work) coo 1
+c fourier transform of length n. in place cooley-tukey method, coo 2
+c digit-reversed to normal order, sande-tukey factoring (2). coo 3
+c dimension data(nprev,n,nrem) coo 4
+c complex data coo 5
+c data(i1,j2,i3) = sum(data(i1,i2,i3)*exp(isign*2*pi*i*((i2-1)* coo 6
+c (j2-1)/n))), summed over i2 = 1 to n for all i1 from 1 to nprev, coo 7
+c j2 from 1 to n and i3 from 1 to nrem. the factors of n are given coo 8
+c in any order in array ifact. factors of two are done in pairs coo 9
+c as much as possible (fourier transform of length four), factors ofcoo 10
+c three are done separately, and all factors five or higher coo 11
+c are done by goertzel's algorithm (4). coo 12
+ dimension data(*), work(*), ifact(1) coo 13
+ twopi=6.283185307*float(isign) coo 14
+ ip0=2 coo 15
+ ip1=ip0*nprev coo 16
+ ip4=ip1*n coo 17
+ ip5=ip4*nrem coo 18
+ if=0 coo 19
+ ip2=ip1 coo 20
+ 10 if (ip2-ip4) 20,240,240 coo 21
+ 20 if=if+1 coo 22
+ ifcur=ifact(if) coo 23
+ if (ifcur-2) 60,30,60 coo 24
+ 30 if (4*ip2-ip4) 40,40,60 coo 25
+ 40 if (ifact(if+1)-2) 60,50,60 coo 26
+ 50 if=if+1 coo 27
+ ifcur=4 coo 28
+ 60 ip3=ip2*ifcur coo 29
+ theta=twopi/float(ifcur) coo 30
+ sinth=sin(theta/2.) coo 31
+ rootr=-2.*sinth*sinth coo 32
+c cos(theta)-1, for accuracy. coo 33
+ rooti=sin(theta) coo 34
+ theta=twopi/float(ip3/ip1) coo 35
+ sinth=sin(theta/2.) coo 36
+ wstpr=-2.*sinth*sinth coo 37
+ wstpi=sin(theta) coo 38
+ wr=1. coo 39
+ wi=0. coo 40
+ do 230 i2=1,ip2,ip1 coo 41
+ if (ifcur-4) 70,70,210 coo 42
+ 70 if ((i2-1)*(ifcur-2)) 240,90,80 coo 43
+ 80 w2r=wr*wr-wi*wi coo 44
+ w2i=2.*wr*wi coo 45
+ w3r=w2r*wr-w2i*wi coo 46
+ w3i=w2r*wi+w2i*wr coo 47
+ 90 i1max=i2+ip1-ip0 coo 48
+ do 200 i1=i2,i1max,ip0 coo 49
+ do 200 i5=i1,ip5,ip3 coo 50
+ j0=i5 coo 51
+ j1=j0+ip2 coo 52
+ j2=j1+ip2 coo 53
+ j3=j2+ip2 coo 54
+ if (i2-1) 140,140,100 coo 55
+ 100 if (ifcur-3) 130,120,110 coo 56
+c apply the phase shift factors coo 57
+ 110 tempr=data(j3) coo 58
+ data(j3)=w3r*tempr-w3i*data(j3+1) coo 59
+ data(j3+1)=w3r*data(j3+1)+w3i*tempr coo 60
+ tempr=data(j2) coo 61
+ data(j2)=wr*tempr-wi*data(j2+1) coo 62
+ data(j2+1)=wr*data(j2+1)+wi*tempr coo 63
+ tempr=data(j1) coo 64
+ data(j1)=w2r*tempr-w2i*data(j1+1) coo 65
+ data(j1+1)=w2r*data(j1+1)+w2i*tempr coo 66
+ go to 140 coo 67
+ 120 tempr=data(j2) coo 68
+ data(j2)=w2r*tempr-w2i*data(j2+1) coo 69
+ data(j2+1)=w2r*data(j2+1)+w2i*tempr coo 70
+ 130 tempr=data(j1) coo 71
+ data(j1)=wr*tempr-wi*data(j1+1) coo 72
+ data(j1+1)=wr*data(j1+1)+wi*tempr coo 73
+ 140 if (ifcur-3) 150,160,170 coo 74
+c do a fourier transform of length two coo 75
+ 150 tempr=data(j1) coo 76
+ tempi=data(j1+1) coo 77
+ data(j1)=data(j0)-tempr coo 78
+ data(j1+1)=data(j0+1)-tempi coo 79
+ data(j0)=data(j0)+tempr coo 80
+ data(j0+1)=data(j0+1)+tempi coo 81
+ go to 200 coo 82
+c do a fourier transform of length three coo 83
+ 160 sumr=data(j1)+data(j2) coo 84
+ sumi=data(j1+1)+data(j2+1) coo 85
+ tempr=data(j0)-.5*sumr coo 86
+ tempi=data(j0+1)-.5*sumi coo 87
+ data(j0)=data(j0)+sumr coo 88
+ data(j0+1)=data(j0+1)+sumi coo 89
+ difr=rooti*(data(j2+1)-data(j1+1)) coo 90
+ difi=rooti*(data(j1)-data(j2)) coo 91
+ data(j1)=tempr+difr coo 92
+ data(j1+1)=tempi+difi coo 93
+ data(j2)=tempr-difr coo 94
+ data(j2+1)=tempi-difi coo 95
+ go to 200 coo 96
+c do a fourier transform of length four (from bit reversed order) coo 97
+ 170 t0r=data(j0)+data(j1) coo 98
+ t0i=data(j0+1)+data(j1+1) coo 99
+ t1r=data(j0)-data(j1) coo 100
+ t1i=data(j0+1)-data(j1+1) coo 101
+ t2r=data(j2)+data(j3) coo 102
+ t2i=data(j2+1)+data(j3+1) coo 103
+ t3r=data(j2)-data(j3) coo 104
+ t3i=data(j2+1)-data(j3+1) coo 105
+ data(j0)=t0r+t2r coo 106
+ data(j0+1)=t0i+t2i coo 107
+ data(j2)=t0r-t2r coo 108
+ data(j2+1)=t0i-t2i coo 109
+ if (isign) 180,180,190 coo 110
+ 180 t3r=-t3r coo 111
+ t3i=-t3i coo 112
+ 190 data(j1)=t1r-t3i coo 113
+ data(j1+1)=t1i+t3r coo 114
+ data(j3)=t1r+t3i coo 115
+ data(j3+1)=t1i-t3r coo 116
+ 200 continue coo 117
+ go to 220 coo 118
+c do a fourier transform of length five or more coo 119
+ 210 call goert (data(i2),nprev,ip2/ip1,ifcur,ip5/ip3,work,wr,wi,rootr,coo 120
+ $rooti) coo 121
+ 220 tempr=wr coo 122
+ wr=wstpr*tempr-wstpi*wi+tempr coo 123
+ 230 wi=wstpr*wi+wstpi*tempr+wi coo 124
+ ip2=ip3 coo 125
+ go to 10 coo 126
+ 240 return coo 127
+ end coo 128-
+ subroutine factr (n,ifact,nfact) fac 1
+c factor n into its prime factors, nfact in number. for example, fac 2
+c for n = 1960, nfact = 6 and ifact(if) = 2, 2, 2, 5, 7 and 7. fac 3
+ dimension ifact(1) fac 4
+ if=0 fac 5
+ npart=n fac 6
+ do 50 id=1,n,2 fac 7
+ idiv=id fac 8
+ if (id-1) 10,10,20 fac 9
+ 10 idiv=2 fac 10
+ 20 iquot=npart/idiv fac 11
+ if (npart-idiv*iquot) 40,30,40 fac 12
+ 30 if=if+1 fac 13
+ ifact(if)=idiv fac 14
+ npart=iquot fac 15
+ go to 20 fac 16
+ 40 if (iquot-idiv) 60,60,50 fac 17
+ 50 continue fac 18
+ 60 if (npart-1) 80,80,70 fac 19
+ 70 if=if+1 fac 20
+ ifact(if)=npart fac 21
+ 80 nfact=if fac 22
+ return fac 23
+ end fac 24-
+ subroutine fixrl (data,n,nrem,isign,iform) fix 1
+c for iform = 0, convert the transform of a doubled-up real array, fix 2
+c considered complex, into its true transform. supply only the fix 3
+c first half of the complex transform, as the second half has fix 4
+c conjugate symmetry. for iform = -1, convert the first half fix 5
+c of the true transform into the transform of a doubled-up real fix 6
+c array. n must be even. fix 7
+c using complex notation and subscripts starting at zero, the fix 8
+c transformation is-- fix 9
+c dimension data(n,nrem) fix 10
+c zstp = exp(isign*2*pi*i/n) fix 11
+c do 10 i2=0,nrem-1 fix 12
+c data(0,i2) = conj(data(0,i2))*(1+i) fix 13
+c do 10 i1=1,n/4 fix 14
+c z = (1+(2*iform+1)*i*zstp**i1)/2 fix 15
+c i1cnj = n/2-i1 fix 16
+c dif = data(i1,i2)-conj(data(i1cnj,i2)) fix 17
+c temp = z*dif fix 18
+c data(i1,i2) = (data(i1,i2)-temp)*(1-iform) fix 19
+c 10 data(i1cnj,i2) = (data(i1cnj,i2)+conj(temp))*(1-iform) fix 20
+c if i1=i1cnj, the calculation for that value collapses into fix 21
+c a simple conjugation of data(i1,i2). fix 22
+ dimension data(*) fix 23
+ twopi=6.283185307*float(isign) fix 24
+ ip0=2 fix 25
+ ip1=ip0*(n/2) fix 26
+ ip2=ip1*nrem fix 27
+ if (iform) 10,70,70 fix 28
+c pack the real input values (two per column) fix 29
+ 10 j1=ip1+1 fix 30
+ data(2)=data(j1) fix 31
+ if (nrem-1) 70,70,20 fix 32
+ 20 j1=j1+ip0 fix 33
+ i2min=ip1+1 fix 34
+ do 60 i2=i2min,ip2,ip1 fix 35
+ data(i2)=data(j1) fix 36
+ j1=j1+ip0 fix 37
+ if (n-2) 50,50,30 fix 38
+ 30 i1min=i2+ip0 fix 39
+ i1max=i2+ip1-ip0 fix 40
+ do 40 i1=i1min,i1max,ip0 fix 41
+ data(i1)=data(j1) fix 42
+ data(i1+1)=data(j1+1) fix 43
+ 40 j1=j1+ip0 fix 44
+ 50 data(i2+1)=data(j1) fix 45
+ 60 j1=j1+ip0 fix 46
+ 70 do 80 i2=1,ip2,ip1 fix 47
+ tempr=data(i2) fix 48
+ data(i2)=data(i2)+data(i2+1) fix 49
+ 80 data(i2+1)=tempr-data(i2+1) fix 50
+ if (n-2) 200,200,90 fix 51
+ 90 theta=twopi/float(n) fix 52
+ sinth=sin(theta/2.) fix 53
+ zstpr=-2.*sinth*sinth fix 54
+ zstpi=sin(theta) fix 55
+ zr=(1.-zstpi)/2. fix 56
+ zi=(1.+zstpr)/2. fix 57
+ if (iform) 100,110,110 fix 58
+ 100 zr=1.-zr fix 59
+ zi=-zi fix 60
+ 110 i1min=ip0+1 fix 61
+ i1max=ip0*(n/4)+1 fix 62
+ do 190 i1=i1min,i1max,ip0 fix 63
+ do 180 i2=i1,ip2,ip1 fix 64
+ i2cnj=ip0*(n/2+1)-2*i1+i2 fix 65
+ if (i2-i2cnj) 150,120,120 fix 66
+ 120 if (isign*(2*iform+1)) 130,140,140 fix 67
+ 130 data(i2+1)=-data(i2+1) fix 68
+ 140 if (iform) 170,180,180 fix 69
+ 150 difr=data(i2)-data(i2cnj) fix 70
+ difi=data(i2+1)+data(i2cnj+1) fix 71
+ tempr=difr*zr-difi*zi fix 72
+ tempi=difr*zi+difi*zr fix 73
+ data(i2)=data(i2)-tempr fix 74
+ data(i2+1)=data(i2+1)-tempi fix 75
+ data(i2cnj)=data(i2cnj)+tempr fix 76
+ data(i2cnj+1)=data(i2cnj+1)-tempi fix 77
+ if (iform) 160,180,180 fix 78
+ 160 data(i2cnj)=data(i2cnj)+data(i2cnj) fix 79
+ data(i2cnj+1)=data(i2cnj+1)+data(i2cnj+1) fix 80
+ 170 data(i2)=data(i2)+data(i2) fix 81
+ data(i2+1)=data(i2+1)+data(i2+1) fix 82
+ 180 continue fix 83
+ tempr=zr-.5 fix 84
+ zr=zstpr*tempr-zstpi*zi+zr fix 85
+ 190 zi=zstpr*zi+zstpi*tempr+zi fix 86
+c recursion saves time, at a slight loss in accuracy. if available,fix 87
+c use double precision to compute zr and zi. fix 88
+ 200 if (iform) 270,210,210 fix 89
+c unpack the real transform values (two per column) fix 90
+ 210 i2=ip2+1 fix 91
+ i1=i2 fix 92
+ j1=ip0*(n/2+1)*nrem+1 fix 93
+ go to 250 fix 94
+ 220 data(j1)=data(i1) fix 95
+ data(j1+1)=data(i1+1) fix 96
+ i1=i1-ip0 fix 97
+ j1=j1-ip0 fix 98
+ 230 if (i2-i1) 220,240,240 fix 99
+ 240 data(j1)=data(i1) fix 100
+ data(j1+1)=0. fix 101
+ 250 i2=i2-ip1 fix 102
+ j1=j1-ip0 fix 103
+ data(j1)=data(i2+1) fix 104
+ data(j1+1)=0. fix 105
+ i1=i1-ip0 fix 106
+ j1=j1-ip0 fix 107
+ if (i2-1) 260,260,230 fix 108
+ 260 data(2)=0. fix 109
+ 270 return fix 110
+ end fix 111-
+ subroutine goert(data,nprev,iprod,ifact,irem,work,wminr,wmini, goe 1
+ $ rootr,rooti) goe 2
+c phase-shifted fourier transform of length ifact by the goertzel goe 3
+c algorithm (4). ifact must be odd and at least 5. further speed goe 4
+c is gained by computing two transform values at the same time. goe 5
+c dimension data(nprev,iprod,ifact,irem) goe 6
+c data(i1,1,j3,i5) = sum(data(i1,1,i3,i5) * w**(i3-1)), summed goe 7
+c over i3 = 1 to ifact for all i1 from 1 to nprev, j3 from 1 to goe 8
+c ifact and i5 from 1 to irem. goe 9
+c w = wmin * exp(isign*2*pi*i*(j3-1)/ifact). goe 10
+ dimension data(*), work(*) goe 11
+ ip0=2 goe 12
+ ip1=ip0*nprev goe 13
+ ip2=ip1*iprod goe 14
+ ip3=ip2*ifact goe 15
+ ip5=ip3*irem goe 16
+ if (wmini) 10,40,10 goe 17
+c apply the phase shift factors goe 18
+ 10 wr=wminr goe 19
+ wi=wmini goe 20
+ i3min=1+ip2 goe 21
+ do 30 i3=i3min,ip3,ip2 goe 22
+ i1max=i3+ip1-ip0 goe 23
+ do 20 i1=i3,i1max,ip0 goe 24
+ do 20 i5=i1,ip5,ip3 goe 25
+ tempr=data(i5) goe 26
+ data(i5)=wr*tempr-wi*data(i5+1) goe 27
+ 20 data(i5+1)=wr*data(i5+1)+wi*tempr goe 28
+ tempr=wr goe 29
+ wr=wminr*tempr-wmini*wi goe 30
+ 30 wi=wminr*wi+wmini*tempr goe 31
+ 40 do 90 i1=1,ip1,ip0 goe 32
+ do 90 i5=i1,ip5,ip3 goe 33
+c straight summation for the first term goe 34
+ sumr=0. goe 35
+ sumi=0. goe 36
+ i3max=i5+ip3-ip2 goe 37
+ do 50 i3=i5,i3max,ip2 goe 38
+ sumr=sumr+data(i3) goe 39
+ 50 sumi=sumi+data(i3+1) goe 40
+ work(1)=sumr goe 41
+ work(2)=sumi goe 42
+ wr=rootr+1. goe 43
+ wi=rooti goe 44
+ iwmin=1+ip0 goe 45
+ iwmax=ip0*((ifact+1)/2)-1 goe 46
+ do 80 iwork=iwmin,iwmax,ip0 goe 47
+ twowr=wr+wr goe 48
+ i3=i3max goe 49
+ oldsr=0. goe 50
+ oldsi=0. goe 51
+ sumr=data(i3) goe 52
+ sumi=data(i3+1) goe 53
+ i3=i3-ip2 goe 54
+ 60 tempr=sumr goe 55
+ tempi=sumi goe 56
+ sumr=twowr*sumr-oldsr+data(i3) goe 57
+ sumi=twowr*sumi-oldsi+data(i3+1) goe 58
+ oldsr=tempr goe 59
+ oldsi=tempi goe 60
+ i3=i3-ip2 goe 61
+ if (i3-i5) 70,70,60 goe 62
+c in a fourier transform the w corresponding to the point at k goe 63
+c is the conjugate of that at ifact-k (that is, exp(twopi*i* goe 64
+c k/ifact) = conj(exp(twopi*i*(ifact-k)/ifact))). since the goe 65
+c main loop of goertzels algorithm is indifferent to the imaginary goe 66
+c part of w, it need be supplied only at the end. goe 67
+ 70 tempr=-wi*sumi goe 68
+ tempi=wi*sumr goe 69
+ sumr=wr*sumr-oldsr+data(i3) goe 70
+ sumi=wr*sumi-oldsi+data(i3+1) goe 71
+ work(iwork)=sumr+tempr goe 72
+ work(iwork+1)=sumi+tempi goe 73
+ iwcnj=ip0*(ifact+1)-iwork goe 74
+ work(iwcnj)=sumr-tempr goe 75
+ work(iwcnj+1)=sumi-tempi goe 76
+c singleton's recursion, for accuracy and speed (5). goe 77
+ tempr=wr goe 78
+ wr=wr*rootr-wi*rooti+wr goe 79
+ 80 wi=tempr*rooti+wi*rootr+wi goe 80
+ iwork=1 goe 81
+ do 90 i3=i5,i3max,ip2 goe 82
+ data(i3)=work(iwork) goe 83
+ data(i3+1)=work(iwork+1) goe 84
+ 90 iwork=iwork+ip0 goe 85
+ return goe 86
+ end goe 87-
+ subroutine smfac (ifact,nfact,isym,ifsym,nfsym,icent,ifcnt,nfcnt) smf 1
+c rearrange the prime factors of n into a square and a non- smf 2
+c square. n = isym*icent*isym, where icent is square-free. smf 3
+c isym = ifsym(1)*...*ifsym(nfsym), each a prime factor. smf 4
+c icent = ifcnt(1)*...*ifcnt(nfcnt), each a prime factor. smf 5
+c for example, n = 1960 = 14*10*14. then isym = 14, icent = 10, smf 6
+c nfsym = 2, nfcnt = 2, nfact = 6, ifsym(ifs) = 2, 7, ifcnt(ifc) = smf 7
+c 2, 5 and ifact(if) = 2, 7, 2, 5, 7, 2. smf 8
+ dimension ifsym(1), ifcnt(1), ifact(1) smf 9
+ isym=1 smf 10
+ icent=1 smf 11
+ ifs=0 smf 12
+ ifc=0 smf 13
+ if=1 smf 14
+ 10 if (if-nfact) 20,40,50 smf 15
+ 20 if (ifact(if)-ifact(if+1)) 40,30,40 smf 16
+ 30 ifs=ifs+1 smf 17
+ ifsym(ifs)=ifact(if) smf 18
+ isym=ifact(if)*isym smf 19
+ if=if+2 smf 20
+ go to 10 smf 21
+ 40 ifc=ifc+1 smf 22
+ ifcnt(ifc)=ifact(if) smf 23
+ icent=ifact(if)*icent smf 24
+ if=if+1 smf 25
+ go to 10 smf 26
+ 50 nfsym=ifs smf 27
+ nfcnt=ifc smf 28
+ nfsm2=2*nfsym smf 29
+ nfact=2*nfsym+nfcnt smf 30
+ if (nfcnt) 80,80,60 smf 31
+ 60 nfsm2=nfsm2+1 smf 32
+ ifsym(nfsym+1)=icent smf 33
+ do 70 ifc=1,nfcnt smf 34
+ if=nfsym+ifc smf 35
+ 70 ifact(if)=ifcnt(ifc) smf 36
+ 80 if (nfsym) 110,110,90 smf 37
+ 90 do 100 ifs=1,nfsym smf 38
+ ifscj=nfsm2+1-ifs smf 39
+ ifsym(ifscj)=ifsym(ifs) smf 40
+ ifact(ifs)=ifsym(ifs) smf 41
+ ifcnj=nfact+1-ifs smf 42
+ 100 ifact(ifcnj)=ifsym(ifs) smf 43
+ 110 nfsym=nfsm2 smf 44
+ return smf 45
+ end smf 46-
+ subroutine symrv (data,nprev,n,nrem,ifact,nfact) sym 1
+c shuffle the data array by reversing the digits of one index. sym 2
+c dimension data(nprev,n,nrem) sym 3
+c replace data(i1,i2,i3) by data(i1,i2rev,i3) for all i1 from 1 to sym 4
+c nprev, i2 from 1 to n and i3 from 1 to nrem. i2rev-1 is the sym 5
+c integer whose digit representation in the multi-radix notation sym 6
+c of factors ifact(if) is the reverse of the representation of i2-1.sym 7
+c for example, if all ifact(if) = 2, i2-1 = 11001, i2rev-1 = 10011. sym 8
+c the factors must be symmetrically arranged, i.e., ifact(if) = sym 9
+c ifact(nfact+1-if). sym 10
+ dimension data(*), ifact(1) sym 11
+ if (nfact-1) 80,80,10 sym 12
+ 10 ip0=2 sym 13
+ ip1=ip0*nprev sym 14
+ ip4=ip1*n sym 15
+ ip5=ip4*nrem sym 16
+ i4rev=1 sym 17
+ do 70 i4=1,ip4,ip1 sym 18
+ if (i4-i4rev) 20,40,40 sym 19
+ 20 i1max=i4+ip1-ip0 sym 20
+ do 30 i1=i4,i1max,ip0 sym 21
+ do 30 i5=i1,ip5,ip4 sym 22
+ i5rev=i4rev+i5-i4 sym 23
+ tempr=data(i5)
+ tempi=data(i5+1) sym 25
+ data(i5)=data(i5rev) sym 26
+ data(i5+1)=data(i5rev+1) sym 27
+ data(i5rev)=tempr sym 28
+ 30 data(i5rev+1)=tempi sym 29
+ 40 ip3=ip4 sym 30
+ do 60 if=1,nfact sym 31
+ ip2=ip3/ifact(if) sym 32
+ i4rev=i4rev+ip2 sym 33
+ if (i4rev-ip3) 70,70,50 sym 34
+ 50 i4rev=i4rev-ip3 sym 35
+ 60 ip3=ip2 sym 36
+ 70 continue sym 37
+ 80 return sym 38
+ end sym 39-
diff -r 405d8f4fa05f -r e7295294f654 src/elastic3d.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/elastic3d.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,3423 @@
+!-----------------------------------------------------------------------
+! Copyright 2007, 2008, 2009 Sylvain Barbot
+!
+! This file is part of RELAX
+!
+! RELAX 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 3 of the License, or
+! (at your option) any later version.
+!
+! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
+!-----------------------------------------------------------------------
+
+MODULE elastic3d
+
+ USE types
+ USE fourier
+
+ IMPLICIT NONE
+
+#include "include.f90"
+
+ REAL*8, PRIVATE, PARAMETER :: pi = 3.141592653589793115997963468544185161_8
+ REAL*8, PRIVATE, PARAMETER :: pi2 = 6.28318530717958623199592693708837032318_8
+ REAL*8, PRIVATE, PARAMETER :: pid2 = 1.57079632679489655799898173427209258079_8
+ REAL*8, PRIVATE, PARAMETER :: DEG2RAD = 0.01745329251994329547437168059786927_8
+
+ INTERFACE OPERATOR (.times.)
+ MODULE PROCEDURE tensorscalarprod
+ END INTERFACE
+
+ INTERFACE OPERATOR (.minus.)
+ MODULE PROCEDURE tensordiff
+ END INTERFACE
+
+ INTERFACE OPERATOR (.plus.)
+ MODULE PROCEDURE tensorplus
+ END INTERFACE
+
+ INTERFACE OPERATOR (.sdyad.)
+ MODULE PROCEDURE tensorsymmetricdyadprod
+ END INTERFACE
+
+ INTERFACE OPERATOR (.tdot.)
+ MODULE PROCEDURE tensorvectordotprod
+ END INTERFACE
+
+CONTAINS
+
+ !------------------------------------------------------------
+ !> function SIGN
+ !! returns the sign of the input -1 for negtive, 0 for zero
+ !! and +1 for positive arguments.
+ !------------------------------------------------------------
+ REAL*8 FUNCTION sign(x)
+ REAL*8, INTENT(IN) :: x
+
+ IF (x .gt. 0._8) THEN
+ sign=1._8
+ ELSE
+ IF (x .lt. 0._8) THEN
+ sign=-1._8
+ ELSE
+ sign=0._8
+ END IF
+ END IF
+ END FUNCTION sign
+
+ !------------------------------------------------------------
+ !> function fix
+ !! returns the closest integer scalar
+ !
+ ! sylvain barbot (08/25/07) - original form
+ !------------------------------------------------------------
+ INTEGER FUNCTION fix(number)
+ REAL*8, INTENT(IN) :: number
+
+ INTEGER :: c,f
+ f=FLOOR(number)
+ c=CEILING(number)
+
+ IF ((number-f) .gt. 0.5_8) THEN
+ fix=c
+ ELSE
+ fix=f
+ END IF
+
+ END FUNCTION fix
+
+ !------------------------------------------------------------
+ !> function SINH
+ !! computes the hyperbolic sine
+ !------------------------------------------------------------
+ REAL*8 FUNCTION sinh(x)
+ REAL*8, INTENT(IN) :: x
+
+ IF (abs(x) .GT. 85._8) THEN
+ sinh=sign(x)*exp(85._8)/2._8
+ ELSE
+ sinh=(exp(x)-exp(-x))/2._8
+ END IF
+ END FUNCTION sinh
+
+ !------------------------------------------------------------
+ !> function ASINH
+ !! computes the inverse hyperbolic sine
+ !------------------------------------------------------------
+ REAL*8 FUNCTION asinh(x)
+ REAL*8, INTENT(IN) :: x
+ asinh=log(x+sqrt(x*x+1))
+ END FUNCTION asinh
+
+ !-----------------------------------------------------------------
+ !> subroutine Neighbor
+ !! computes the indices of neighbor samples (l points away)
+ !! bracketing the current samples location i1,i2,i3 and
+ !! assuming periodic boundary condition.
+ !!
+ !! i1m < i1 < i1p
+ !! i2m < i2 < i2p
+ !! i3m < i3 < i3p
+ !-----------------------------------------------------------------
+ SUBROUTINE neighbor(i1,i2,i3,sx1,sx2,sx3,l,i1m,i1p,i2m,i2p,i3m,i3p)
+ INTEGER, INTENT(IN) :: i1,i2,i3,sx1,sx2,sx3,l
+ INTEGER, INTENT(OUT) :: i1m,i1p,i2m,i2p,i3m,i3p
+
+ i1m=mod(sx1+i1-1-l,sx1)+1
+ i1p=mod(i1-1+l,sx1)+1
+ i2m=mod(sx2+i2-1-l,sx2)+1
+ i2p=mod(i2-1+l,sx2)+1
+ i3m=mod(sx3+i3-1-l,sx3)+1
+ i3p=mod(i3-1+l,sx3)+1
+
+ END SUBROUTINE neighbor
+
+ !---------------------------------------------------------------
+ !> subroutine IsotropicStressStrain
+ !! computes in place the isotropic stress tensor from a given
+ !! strain tensor using Hooke's law stress-strain relationship.
+ !
+ ! sylvain barbot (10/14/07) - original form
+ !---------------------------------------------------------------
+ SUBROUTINE isotropicstressstrain(t,lambda,mu)
+ TYPE(TENSOR), INTENT(INOUT) :: t
+ REAL*8, INTENT(IN) :: lambda, mu
+
+ REAL*8 :: epskk
+
+ epskk=tensortrace(t)
+
+ t = REAL(2._8*mu) .times. t
+ t%s11=t%s11+lambda*epskk
+ t%s22=t%s22+lambda*epskk
+ t%s33=t%s33+lambda*epskk
+
+ END SUBROUTINE isotropicstressstrain
+
+ !------------------------------------------------------------
+ !> function TensorDiff
+ !! computes the difference between two tensors: t=t1-t2
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ TYPE(TENSOR) FUNCTION tensordiff(t1,t2)
+ TYPE(TENSOR), INTENT(IN) :: t1,t2
+
+ tensordiff=TENSOR(t1%s11-t2%s11, & ! 11
+ t1%s12-t2%s12, & ! 12
+ t1%s13-t2%s13, & ! 13
+ t1%s22-t2%s22, & ! 22
+ t1%s23-t2%s23, & ! 23
+ t1%s33-t2%s33) ! 33
+
+ END FUNCTION tensordiff
+
+ !------------------------------------------------------------
+ !> function TensorPlus
+ !! computes the sum of two tensors: t=t1-t2
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ TYPE(TENSOR) FUNCTION tensorplus(t1,t2)
+ TYPE(TENSOR), INTENT(IN) :: t1,t2
+
+ tensorplus=TENSOR(t1%s11+t2%s11, & ! 11
+ t1%s12+t2%s12, & ! 12
+ t1%s13+t2%s13, & ! 13
+ t1%s22+t2%s22, & ! 22
+ t1%s23+t2%s23, & ! 23
+ t1%s33+t2%s33) ! 33
+
+ END FUNCTION tensorplus
+
+ !------------------------------------------------------------
+ !> function TensorScalarProd
+ !! multiplies a tensor with a scalar
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ TYPE(TENSOR) FUNCTION tensorscalarprod(scalar,t)
+ TYPE(TENSOR), INTENT(IN) :: t
+ REAL*4, INTENT(IN) :: scalar
+
+ tensorscalarprod=TENSOR(scalar*t%s11, & ! 11
+ scalar*t%s12, & ! 12
+ scalar*t%s13, & ! 13
+ scalar*t%s22, & ! 22
+ scalar*t%s23, & ! 23
+ scalar*t%s33) ! 33
+
+ END FUNCTION tensorscalarprod
+
+ !------------------------------------------------------------
+ !> function TensorSymmetricDyadProd
+ !! computes the dyadic product of two vectors to obtain a
+ !! symmetric second order tensor
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ TYPE(TENSOR) FUNCTION tensorsymmetricdyadprod(a,b)
+ REAL*8, DIMENSION(3), INTENT(IN) :: a,b
+
+ tensorsymmetricdyadprod=TENSOR( &
+ a(1)*b(1), & ! 11
+ (a(1)*b(2)+a(2)*b(1))/2._8, & ! 12
+ (a(1)*b(3)+a(3)*b(1))/2._8, & ! 13
+ a(2)*b(2), & ! 22
+ (a(2)*b(3)+a(3)*b(2))/2._8, & ! 23
+ a(3)*b(3) & ! 33
+ )
+
+ END FUNCTION tensorsymmetricdyadprod
+
+ !------------------------------------------------------------
+ !> function TensorVectorDotProd
+ !! compute the dot product T.v where T is a second-order
+ !! tensor and v is a vector.
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ FUNCTION tensorvectordotprod(t,v)
+ TYPE(TENSOR), INTENT(IN) :: t
+ REAL*8, DIMENSION(3), INTENT(IN) :: v
+ REAL*8, DIMENSION(3) :: tensorvectordotprod
+
+ tensorvectordotprod= &
+ (/ t%s11*v(1)+t%s12*v(2)+t%s13*v(3), &
+ t%s12*v(1)+t%s22*v(2)+t%s23*v(3), &
+ t%s13*v(1)+t%s23*v(2)+t%s33*v(3) /)
+
+ END FUNCTION tensorvectordotprod
+
+ !------------------------------------------------------------
+ !> function TensorVectorDotProd
+ !! compute the dot product T.v where T is a second-order
+ !! tensor and v is a vector.
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ FUNCTION tensordeviatoric(t)
+ TYPE(TENSOR), INTENT(IN) :: t
+ TYPE(TENSOR) :: tensordeviatoric
+
+ REAL*4 :: diag
+
+ diag=REAL(tensortrace(t)/3._8)
+
+ tensordeviatoric%s11=t%s11-diag
+ tensordeviatoric%s12=t%s12
+ tensordeviatoric%s13=t%s13
+ tensordeviatoric%s22=t%s22-diag
+ tensordeviatoric%s23=t%s23
+ tensordeviatoric%s33=t%s33-diag
+
+ END FUNCTION tensordeviatoric
+
+ !------------------------------------------------------------
+ !> function TensorTrace
+ !! computes the trace of a second order tensor
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ REAL*8 FUNCTION tensortrace(t)
+ TYPE(TENSOR), INTENT(IN) :: t
+
+ tensortrace=t%s11+t%s22+t%s33
+
+ END FUNCTION tensortrace
+
+ !------------------------------------------------------------
+ !> function TensorNorm
+ !! computes the Frobenius norm of a second order tensor
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ REAL*8 FUNCTION tensornorm(t)
+ TYPE(TENSOR), INTENT(IN) :: t
+
+ tensornorm=SQRT(( &
+ t%s11**2+2._8*t%s12**2+2._8*t%s13**2+ &
+ t%s22**2+2._8*t%s23**2+ &
+ t%s33**2)/2._8)
+
+ END FUNCTION tensornorm
+
+ !------------------------------------------------------------
+ !> function TensorDecomposition
+ !! writes a tensor t as the product of a norm and a direction
+ !!
+ !! t = gamma * R
+ !!
+ !! where gamma is a scalar, the norm of t, and R is a unitary
+ !! tensor. t is assumed to be a deviatoric tensor.
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ SUBROUTINE tensordecomposition(t,gamma,R)
+ TYPE(TENSOR), INTENT(IN) :: t
+ TYPE(TENSOR), INTENT(OUT) :: R
+ REAL*8, INTENT(OUT) :: gamma
+
+ gamma=tensornorm(t)
+
+ R%s11=t%s11/gamma
+ R%s12=t%s12/gamma
+ R%s13=t%s13/gamma
+ R%s22=t%s22/gamma
+ R%s23=t%s23/gamma
+ R%s33=t%s33/gamma
+
+ END SUBROUTINE tensordecomposition
+
+
+ !------------------------------------------------------------
+ !> function TensorForbeniusNorm
+ !! computes the Frobenius norm of a second order tensor
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !------------------------------------------------------------
+ REAL*8 FUNCTION tensorfrobeniusnorm(t)
+ TYPE(TENSOR), INTENT(IN) :: t
+
+ tensorfrobeniusnorm=SQRT( &
+ t%s11**2+2._8*t%s12**2+2._8*t%s13**2+ &
+ t%s22**2+2._8*t%s23**2+ &
+ t%s33**2)
+
+ END FUNCTION tensorfrobeniusnorm
+
+ !------------------------------------------------------------
+ !> function VectorFieldNormMax
+ !! computes the maximum value of the norm of a vector field
+ !------------------------------------------------------------
+ SUBROUTINE vectorfieldnormmax(v1,v2,v3,sx1,sx2,sx3,maximum,location)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: v1,v2,v3
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v1,v2,v3
+#endif
+ REAL*8, INTENT(OUT) :: maximum
+ INTEGER, INTENT(OUT), DIMENSION(3) :: location
+
+ INTEGER :: i1,i2,i3
+ REAL*8 :: norm
+
+ maximum=-1._8
+ DO i3=1,sx3
+ DO i2=1,sx2
+ DO i1=1,sx1
+ norm=SQRT(v1(i1,i2,i3)**2+v2(i1,i2,i3)**2+v3(i1,i2,i3)**2)
+ IF (norm .GT. maximum) THEN
+ maximum=norm
+ location=(/ i1,i2,i3 /)
+ END IF
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE vectorfieldnormmax
+
+ !------------------------------------------------------------
+ !> function TensorMean
+ !! computesthe mean of the norm of a tensor field
+ !------------------------------------------------------------
+ REAL*8 FUNCTION tensormean(t)
+ TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: t
+
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3
+ sx1=SIZE(t,1)
+ sx2=SIZE(t,2)
+ sx3=SIZE(t,3)
+
+ DO i3=1,sx3
+ DO i2=1,sx2
+ DO i1=1,sx1
+ tensormean=tensormean+tensornorm(t(i1,i2,i3))
+ END DO
+ END DO
+ END DO
+ tensormean=tensormean/DBLE(sx1*sx2*sx3)
+
+ END FUNCTION tensormean
+
+ !------------------------------------------------------------
+ !> function TensorAmplitude
+ !! computes the integral of the norm of a tensor field
+ !------------------------------------------------------------
+ REAL*8 FUNCTION tensoramplitude(t,dx1,dx2,dx3)
+ TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: t
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3
+ sx1=SIZE(t,1)
+ sx2=SIZE(t,2)
+ sx3=SIZE(t,3)
+
+ tensoramplitude=0._8
+ DO i3=1,sx3
+ DO i2=1,sx2
+ DO i1=1,sx1
+ tensoramplitude=tensoramplitude &
+ +tensornorm(t(i1,i2,i3))
+ END DO
+ END DO
+ END DO
+ tensoramplitude=tensoramplitude*DBLE(dx1*dx2*dx3)
+
+ END FUNCTION tensoramplitude
+
+ !------------------------------------------------------------
+ !> function TensorMeanTrace
+ !! computesthe mean of the norm of a tensor field
+ !------------------------------------------------------------
+ REAL*8 FUNCTION tensormeantrace(t)
+ TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: t
+
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3
+ sx1=SIZE(t,1)
+ sx2=SIZE(t,2)
+ sx3=SIZE(t,3)
+
+ DO i3=1,sx3
+ DO i2=1,sx2
+ DO i1=1,sx1
+ tensormeantrace= &
+ tensormeantrace+tensortrace(t(i1,i2,i3))
+ END DO
+ END DO
+ END DO
+ tensormeantrace=tensormeantrace/DBLE(sx1*sx2*sx3)
+
+ END FUNCTION tensormeantrace
+
+ !------------------------------------------------------------
+ !> sinc function
+ !! computes sin(pi*x)/(pi*x)
+ !
+ ! sylvain barbot (04-14-07) - original form
+ !------------------------------------------------------------
+ FUNCTION sinc(x)
+ REAL*8 :: sinc
+ REAL*8, INTENT(IN) :: x
+ IF (x /= 0) THEN
+ sinc=sin(pi*x)/(pi*x)
+ ELSE
+ sinc=1._8
+ END IF
+ END FUNCTION sinc
+
+ !-------------------------------------------------------------------------
+ !> function gauss computes the normalized gaussian function
+ !
+ ! Sylvain Barbot (06-29-07)
+ !-------------------------------------------------------------------------
+ FUNCTION gauss(x,sigma)
+ REAL*8 :: gauss
+ REAL*8, INTENT(IN) :: x,sigma
+
+ gauss=exp(-0.5_8*(x/sigma)**2)/sqrt(pi2)/sigma
+ END FUNCTION gauss
+
+ !-------------------------------------------------------------------------
+ !> function gaussp computes the normalized gaussian derivative
+ !
+ ! Sylvain Barbot (06-29-07)
+ !-------------------------------------------------------------------------
+ FUNCTION gaussp(x,sigma)
+ REAL*8 :: gaussp
+ REAL*8, INTENT(IN) :: x,sigma
+
+ gaussp=-x*exp(-0.5_8*(x/sigma)**2)/sqrt(pi2)/sigma**3
+ END FUNCTION gaussp
+
+ !-------------------------------------------------------------------------
+ !> function omega computes raised-cosine taper in the space domain
+ !
+ ! Sylvain Barbot (06-29-07)
+ !-------------------------------------------------------------------------
+ FUNCTION omega(x,beta)
+ REAL*8 :: omega
+ REAL*8, INTENT(IN) :: x,beta
+
+ IF (abs(x) .le. (1._8-2._8*beta)/(1._8-beta)/2._8) THEN
+ omega=1._8
+ ELSE
+ IF (abs(x) .lt. 1._8/(1-beta)/2._8) THEN
+ omega=cos(pi*((1._8-beta)*abs(x)-0.5_8+beta)/2._8/beta)**2
+ ELSE
+ omega=0._8
+ END IF
+ END IF
+ END FUNCTION omega
+
+ !-------------------------------------------------------------------------
+ !> function omegap computes raised-cosine taper derivative
+ !! in the space domain
+ !
+ ! Sylvain Barbot (06-29-07)
+ !-------------------------------------------------------------------------
+ FUNCTION omegap(x,beta)
+ REAL*8 :: omegap
+ REAL*8, INTENT(IN) :: x,beta
+
+ omegap=0
+ IF (abs(x) .gt. (1._8-2._8*beta)/(1._8-beta)/2._8) THEN
+ IF (abs(x) .lt. 1._8/(1-beta)/2._8) THEN
+ omegap=-DSIGN(1._8,x)*pi*(1._8-beta)/2._8/beta* &
+ sin(pi*((1._8-beta)*abs(x)-0.5_8+beta)/beta)
+ END IF
+ END IF
+ END FUNCTION omegap
+
+ !-------------------------------------------------------------------------
+ !> tapered step function (raised-cosine) of unit area in the Fourier domain
+ !!
+ !! INPUT
+ !! @param k wavenumber
+ !! @param beta roll-off parameter 0<beta<0.5
+ !! no smoothing for beta close to 0
+ !! string smoothing for beta close to 0.5
+ !
+ ! sylvain barbot (04-14-07) - original form
+ !-------------------------------------------------------------------------
+ FUNCTION omegak(k,beta)
+ REAL*8 :: omegak
+ REAL*8, INTENT(IN) :: k, beta
+ REAL*8 :: gamma,denom,om1,om2
+
+ gamma=(1._8-beta)
+ denom=(gamma-(4._8*beta**2._8/gamma)*k**2._8)*2._8
+ om1=sinc(k/gamma)
+ om2=(1._8-2._8*beta)*sinc(((1._8-2._8*beta)/gamma)*k)
+ omegak=(om1+om2)/denom
+
+ END FUNCTION omegak
+
+ !----------------------------------------------------------------
+ !> subroutine TensorStructure
+ !! constructs a vertically-stratified tensor field.
+ !! The structure is defined by its interfaces: changes can be
+ !! gradual or discontinuous.
+ !
+ ! sylvain barbot (10/25/08) - original form
+ !----------------------------------------------------------------
+ SUBROUTINE tensorstructure(vstruct,layers,dx3)
+ TYPE(TENSOR_LAYER_STRUCT), INTENT(IN), DIMENSION(:) :: layers
+ TYPE(TENSOR_LAYER_STRUCT), INTENT(OUT), DIMENSION(:) :: vstruct
+ REAL*8, INTENT(IN) :: dx3
+
+ INTEGER :: nv,k,i3s,i3e=1,i3,sx3
+ REAL*8 :: z,z0,z1
+ TYPE(TENSOR) :: t0,t1,t
+
+ nv =SIZE(layers,1)
+ sx3=SIZE(vstruct,1)
+
+ IF (0 .ge. nv) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid tensor structure. exiting.")')
+ STOP 1
+ END IF
+
+ ! initialization
+ vstruct(:)%z=0 ! depth is not used
+ vstruct(:)%t=tensor(0._4,0._4,0._4,0._4,0._4,0._4) ! default
+
+ z0=fix(layers(1)%z/dx3)*dx3
+ DO k=1,nv
+ ! project model on multiples of sampling size 'dx3'
+ ! to avoid aliasing problems
+ z1=fix(layers(k)%z/dx3)*dx3
+
+ IF (z1 .lt. z0) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid mechanical structure.")')
+ WRITE (0,'("depths must be increasing. exiting.")')
+ STOP 1
+ END IF
+
+ IF (z1 .eq. z0) THEN
+ ! discontinuous interface in the elastic structure
+ z0=z1
+
+ t1=layers(k)%t
+
+ i3e=fix(z1/dx3+1)
+ ELSE
+ ! interpolate linearly between current and previous value
+
+ t1=layers(k)%t
+
+ i3s=fix(z0/dx3)+1
+ i3e=MIN(fix(z1/dx3+1),sx3)
+ DO i3=i3s,i3e
+ z=(i3-1._8)*dx3
+
+ t=REAL(1._8/(z1-z0)) .times. &
+ ((REAL(z-z0) .times. t1) .plus. (REAL(z1-z) .times. t0))
+
+ vstruct(i3)%t=t
+
+ END DO
+ END IF
+
+ z0=z1
+ t0=t1
+
+ END DO
+
+ ! downward-continue the last layer
+ IF (fix(z1/dx3) .lt. sx3-1) THEN
+ vstruct(i3e:sx3)%t=t1
+ END IF
+
+ END SUBROUTINE tensorstructure
+
+
+ !----------------------------------------------------------------
+ !> subroutine ViscoElasticStructure
+ !! constructs a vertically-stratified viscoelastic structure.
+ !! The structure is defined by its interfaces: changes can be
+ !! gradual or discontinuous.
+ !!
+ !! EXAMPLE INPUTS:
+ !!
+ !! 1- elastic plate over linear viscous half-space
+ !! 1
+ !! 1 1.0 1.0 1.0
+ !!
+ !! 2- elastic plate over powerlaw viscous half-space (n=3)
+ !! 1
+ !! 1 1.0 1.0 3.0
+ !!
+ !! 3- elastic plate over viscous half-space with depth-dependent
+ !! viscosity
+ !! 2
+ !! 1 01.0 1.0 1.0
+ !! 2 10.0 6.0 1.0
+ !!
+ !! in this last example, the grid does not have to reach down
+ !! to x3=10.
+ !!
+ !! \author sylvain barbot (08/07/07) - original form
+ !----------------------------------------------------------------
+ SUBROUTINE viscoelasticstructure(vstruct,layers,dx3)
+ TYPE(LAYER_STRUCT), INTENT(IN), DIMENSION(:) :: layers
+ TYPE(LAYER_STRUCT), INTENT(OUT), DIMENSION(:) :: vstruct
+ REAL*8, INTENT(IN) :: dx3
+
+ INTEGER :: nv,k,i3s,i3e=1,i3,sx3
+ REAL*8 :: z,z0,z1, &
+ power,power0,power1, &
+ gamma,gamma0,gamma1, &
+ friction,friction0,friction1, &
+ cohesion,cohesion0,cohesion1
+
+
+ nv =SIZE(layers,1)
+ sx3=SIZE(vstruct,1)
+
+ IF (0 .ge. nv) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid elastic structure. exiting.")')
+ STOP 1
+ END IF
+
+ ! initialization
+ vstruct(:)%z=0 ! depth is not used
+ vstruct(:)%gammadot0=0 ! default is inviscid
+ vstruct(:)%friction=0.6 ! default is friction=0.6
+ vstruct(:)%cohesion=0 ! default is no cohesion
+ vstruct(:)%stressexponent=layers(1)%stressexponent ! default
+
+ z0=fix(layers(1)%z/dx3)*dx3
+ DO k=1,nv
+ ! project model on multiples of sampling size 'dx3'
+ ! to avoid aliasing problems
+ z1=fix(layers(k)%z/dx3)*dx3
+
+ IF (z1 .lt. z0) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid mechanical structure. exiting.")')
+ STOP 1
+ END IF
+
+ IF (z1 .eq. z0) THEN
+ ! discontinuous interface in the elastic structure
+ z0=z1
+ gamma1=layers(k)%gammadot0
+ power1 =layers(k)%stressexponent
+ friction1=layers(k)%friction
+ cohesion1=layers(k)%cohesion
+
+ i3e=fix(z1/dx3+1)
+ ELSE
+ ! interpolate between current and previous value
+ gamma1=layers(k)%gammadot0
+ power1 =layers(k)%stressexponent
+ friction1=layers(k)%friction
+ cohesion1=layers(k)%cohesion
+
+ i3s=fix(z0/dx3)+1
+ i3e=MIN(fix(z1/dx3+1),sx3)
+ DO i3=i3s,i3e
+ z=(i3-1._8)*dx3
+ gamma=((z-z0)*gamma1+(z1-z)*gamma0)/(z1-z0)
+ power=((z-z0)*power1+(z1-z)*power0)/(z1-z0)
+ friction=((z-z0)*friction1+(z1-z)*friction0)/(z1-z0)
+ cohesion=((z-z0)*cohesion1+(z1-z)*cohesion0)/(z1-z0)
+
+ vstruct(i3)%gammadot0=gamma
+ vstruct(i3)%stressexponent =power
+ vstruct(i3)%friction=friction
+ vstruct(i3)%cohesion=cohesion
+ END DO
+ END IF
+
+ z0=z1
+ gamma0=gamma1
+ power0=power1
+ friction0=friction1
+ cohesion0=cohesion1
+
+ END DO
+
+ ! downward-continue the last layer
+ IF (fix(z1/dx3) .lt. sx3-1) THEN
+ vstruct(i3e:sx3)%gammadot0=REAL(gamma1)
+ vstruct(i3e:sx3)%stressexponent =REAL(power1)
+ vstruct(i3e:sx3)%friction=REAL(friction1)
+ vstruct(i3e:sx3)%cohesion=REAL(cohesion1)
+ END IF
+
+ END SUBROUTINE viscoelasticstructure
+
+
+ !------------------------------------------------------------------
+ !> function OptimalFilter
+ !! load predefined Finite Impulse Response (FIR) filters of various
+ !! lengths and select the most appropriate ones based on the
+ !! computational grid size. result is filter kernels always smaller
+ !! than available computational length.
+ !! this is useful in the special cases of infinite faults where
+ !! deformation is essentially two-dimensional, despite the actual
+ !! three-dimensional computation. in the direction of symmetry,
+ !! no strain occurs and high accuracy derivative estimates are not
+ !! needed.
+ !
+ ! Sylvain Barbot (03/05/08) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE optimalfilter(ker1,ker2,ker3,len1,len2,len3,sx1,sx2,sx3)
+ REAL*8, DIMENSION(16), INTENT(OUT) :: ker1,ker2,ker3
+ INTEGER, INTENT(OUT) :: len1,len2,len3
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+
+ ! load FIR differentiator filter
+ ! variables 'fir1', 'fir7', 'fir14'
+ INCLUDE 'kernel1.inc'
+ INCLUDE 'kernel7.inc'
+ INCLUDE 'kernel14bis.inc'
+
+ ! choose best differentiator kernels
+ SELECT CASE(sx1)
+ CASE (2:4)
+ ! use centered finite difference
+ len1=1
+ ker1(1)=fir1(1)
+ CASE (5:14)
+ len1=7
+ ker1(1:len1)=fir7(1:len1)
+ CASE (15:)
+ len1=1
+ ker1(1:len1)=fir1(1:len1)
+ CASE DEFAULT
+ WRITE_DEBUG_INFO
+ WRITE (0,'("optimalfilter: invalid dimension. exiting.")')
+ STOP 2
+ END SELECT
+
+ ! choose best differentiator kernels
+ SELECT CASE(sx2)
+ CASE (2:4)
+ ! use centered finite difference
+ len2=1
+ ker2(1)=fir1(1)
+ CASE (5:14)
+ len2=7
+ ker2(1:len2)=fir7(1:len2)
+ CASE (15:)
+ len2=1
+ ker2(1:len2)=fir1(1:len2)
+ CASE DEFAULT
+ WRITE_DEBUG_INFO
+ WRITE (0,'("optimalfilter: invalid dimension. exiting.")')
+ STOP 2
+ END SELECT
+
+ ! choose best differentiator kernels
+ SELECT CASE(sx3)
+ CASE (5:14)
+ len3=7
+ ker3(1:len3)=fir7(1:len3)
+ CASE (15:)
+ len3=1
+ ker3(1:len3)=fir1(1:len3)
+ CASE DEFAULT
+ WRITE_DEBUG_INFO
+ WRITE (0,'("optimalfilter: invalid dimension. exiting.")')
+ STOP 2
+ END SELECT
+
+ END SUBROUTINE optimalfilter
+
+ !-----------------------------------------------------------------
+ !> subroutine StressUpdate
+ !! computes the 3-d stress tensor sigma_ij' from the current
+ !! deformation field. Strain is the second order tensor
+ !!
+ !! \f[ \epsilon_{ij} = \frac{1}{2} ( u_{i,j} + u_{j,i} ) \f]
+ !!
+ !! The displacement derivatives are approximated numerically by the
+ !! application of a differentiator space-domain finite impulse
+ !! response filter. Coefficients of the filter can be obtained with
+ !! the MATLAB command line
+ !!
+ !!\verbatim
+ !! firpm(14, ...
+ !! [0 7.0e-1 8.000000e-1 8.500000e-1 9.000000e-1 1.0e+0],...
+ !! [0 7.0e-1 5.459372e-1 3.825260e-1 2.433534e-1 0.0e+0]*pi,...
+ !! 'differentiator');
+ !!\endverbatim
+ !!
+ !! The kernel is odd and antisymmetric and only half the numbers
+ !! are stored in this code. Kernels of different sizes are readilly
+ !! available in the 'kernelX.inc' files. Stress tensor field is
+ !! obtained by application of Hooke's law
+ !!
+ !! \f[ \sigma' = - C' : E \f]
+ !!
+ !! or in indicial notation
+ !!
+ !!
+ !! \f[ \sigma_{ij}' = -\lambda'*\delta_{ij}*\epsilon_{kk} - 2*\mu'*\epsilon_{ij}\f]
+ !!
+ !! where C' is the heterogeneous elastic moduli tensor and lambda'
+ !! and mu' are the inhomogeneous lame parameters
+ !!
+ !! \f[ C' = C(x) - C_0 \f]
+ !!
+ !! For isotropic materials
+ !!
+ !! \f[ \mu'(x) = \mu(x) - \mu_0 \f]
+ !! \f[ \lambda'(x) = \lambda(x) - \lambda_0 \f]
+ !!
+ !! Optionally, the surface traction sigma_i3 can be sampled.
+ !!
+ !! \author sylvain barbot (10/10/07) - original form
+ !! - optional sample of normal stress
+ !! (02/12/09) - OpemMP parallel implementation
+ !-----------------------------------------------------------------
+ SUBROUTINE stressupdate(v1,v2,v3,lambda,mu,dx1,dx2,dx3,sx1,sx2,sx3,sig)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3,lambda,mu
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: v1,v2,v3
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v1,v2,v3
+#endif
+ TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: sig
+
+ TYPE(TENSOR) :: t
+ INTEGER :: i1,i2,i3,i3p,i3m,len1,len2,len3
+ REAL*8 :: px3
+ REAL*8, DIMENSION(16) :: ker1,ker2,ker3
+
+ ! load FIR differentiator filter
+ CALL optimalfilter(ker1,ker2,ker3,len1,len2,len3,sx1,sx2,sx3)
+ ker1=ker1/dx1; ker2=ker2/dx2; ker3=ker3/dx3;
+
+ ! no periodicity in the 3rd direction
+ ! use a simple finite difference scheme
+ DO i3=1,sx3
+
+ IF ((i3 .gt. len3) .and. (i3 .lt. (sx3-len3+1))) &
+ CYCLE
+
+ IF (i3 .eq. 1) THEN
+ ! right-centered finite difference
+ px3=dx3; i3p=2; i3m=1
+ ELSE
+ IF (i3 .eq. sx3) THEN
+ ! left-centered finite difference
+ px3=dx3; i3p=sx3; i3m=sx3-1
+ ELSE
+ ! centered finite difference
+ px3=dx3*2._8; i3m=i3-1; i3p=i3+1
+ END IF
+ END IF
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL localstrain_ani(t,i3m,i3p,px3)
+ CALL isotropicstressstrain(t,lambda,mu)
+ sig(i1,i2,i3)=sig(i1,i2,i3) .plus. t
+ END DO
+ END DO
+ END DO
+
+ ! intermediate depth treated isotropically
+!$omp parallel do private(i1,i2,t)
+ DO i3=len3+1,sx3-len3
+ DO i2=1,sx2
+ DO i1=1,sx1
+ ! Finite Impulse Response filter
+ !CALL localstrain_fir(t)
+ CALL localstrain_fir2(t,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,v1,v2,v3,sx1,sx2,sx3)
+ CALL isotropicstressstrain(t,lambda,mu)
+ sig(i1,i2,i3)=sig(i1,i2,i3) .plus. t
+ END DO
+ END DO
+ END DO
+!$omp end parallel do
+
+ CONTAINS
+
+ !---------------------------------------------------------------
+ !> LocalStrain_FIR2
+ !! implements a finite impulse response filter (FIR) to estimate
+ !! derivatives and strain components. the compatibility with the
+ !! OpenMP parallel execution requires that all variable be
+ !! tractable from the calling routine.
+ !!
+ !! \author sylvain barbot (10/10/07) - original form
+ ! (03/05/08) - implements 3 filters
+ ! (02/12/09) - compatibility with OpenMP (scope)
+ !---------------------------------------------------------------
+ SUBROUTINE localstrain_fir2(e,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,v1,v2,v3,sx1,sx2,sx3)
+ TYPE(TENSOR), INTENT(OUT) :: e
+ INTEGER, INTENT(IN) :: len1,len2,len3,i1,i2,i3,sx1,sx2,sx3
+ REAL*8, INTENT(IN), DIMENSION(len1) :: ker1
+ REAL*8, INTENT(IN), DIMENSION(len2) :: ker2
+ REAL*8, INTENT(IN), DIMENSION(len3) :: ker3
+ REAL*4, INTENT(IN), DIMENSION(:,:,:) :: v1,v2,v3
+
+ INTEGER :: l,i1m,i2m,i3m,i1p,i2p,i3p
+
+ e=TENSOR(0._4,0._4,0._4,0._4,0._4,0._4)
+
+ DO l=1,len1
+ ! neighbor samples with periodic boundary conditions
+ i1m=mod(sx1+i1-1-l,sx1)+1
+ i1p=mod(i1-1+l,sx1)+1
+
+ e%s11=e%s11+(v1(i1p,i2,i3)-v1(i1m,i2,i3))*ker1(l)
+ e%s12=e%s12+(v2(i1p,i2,i3)-v2(i1m,i2,i3))*ker1(l)
+ e%s13=e%s13+(v3(i1p,i2,i3)-v3(i1m,i2,i3))*ker1(l)
+ END DO
+
+ DO l=1,len2
+ ! neighbor samples with periodic boundary conditions
+ i2m=mod(sx2+i2-1-l,sx2)+1
+ i2p=mod(i2-1+l,sx2)+1
+
+ e%s12=e%s12+(v1(i1,i2p,i3)-v1(i1,i2m,i3))*ker2(l)
+ e%s22=e%s22+(v2(i1,i2p,i3)-v2(i1,i2m,i3))*ker2(l)
+ e%s23=e%s23+(v3(i1,i2p,i3)-v3(i1,i2m,i3))*ker2(l)
+ END DO
+
+ DO l=1,len3
+ ! neighbor samples in semi-infinite solid
+ i3m=i3-l
+ i3p=i3+l
+
+ e%s13=e%s13+(v1(i1,i2,i3p)-v1(i1,i2,i3m))*ker3(l)
+ e%s23=e%s23+(v2(i1,i2,i3p)-v2(i1,i2,i3m))*ker3(l)
+ e%s33=e%s33+(v3(i1,i2,i3p)-v3(i1,i2,i3m))*ker3(l)
+ END DO
+
+ e%s12=e%s12/2._8
+ e%s13=e%s13/2._8
+ e%s23=e%s23/2._8
+
+ END SUBROUTINE localstrain_fir2
+
+ !---------------------------------------------------------------
+ !> LocalStrain_FIR
+ !! implements a finite impulse response filter (FIR) to estimate
+ !! derivatives and strain components.
+ !!
+ !! \author sylvain barbot (10/10/07) - original form
+ !! (03/05/08) - implements 3 filters
+ !---------------------------------------------------------------
+ SUBROUTINE localstrain_fir(e)
+ TYPE(TENSOR), INTENT(OUT) :: e
+
+ INTEGER :: l,i1m,i2m,i3m,i1p,i2p,i3p
+
+ e=TENSOR(0._4,0._4,0._4,0._4,0._4,0._4)
+
+ DO l=1,len1
+ ! neighbor samples with periodic boundary conditions
+ i1m=mod(sx1+i1-1-l,sx1)+1
+ i1p=mod(i1-1+l,sx1)+1
+
+ e%s11=e%s11+(v1(i1p,i2,i3)-v1(i1m,i2,i3))*ker1(l)
+ e%s12=e%s12+(v2(i1p,i2,i3)-v2(i1m,i2,i3))*ker1(l)
+ e%s13=e%s13+(v3(i1p,i2,i3)-v3(i1m,i2,i3))*ker1(l)
+ END DO
+
+ DO l=1,len2
+ ! neighbor samples with periodic boundary conditions
+ i2m=mod(sx2+i2-1-l,sx2)+1
+ i2p=mod(i2-1+l,sx2)+1
+
+ e%s12=e%s12+(v1(i1,i2p,i3)-v1(i1,i2m,i3))*ker2(l)
+ e%s22=e%s22+(v2(i1,i2p,i3)-v2(i1,i2m,i3))*ker2(l)
+ e%s23=e%s23+(v3(i1,i2p,i3)-v3(i1,i2m,i3))*ker2(l)
+ END DO
+
+ DO l=1,len3
+ ! neighbor samples in semi-infinite solid
+ i3m=i3-l
+ i3p=i3+l
+
+ e%s13=e%s13+(v1(i1,i2,i3p)-v1(i1,i2,i3m))*ker3(l)
+ e%s23=e%s23+(v2(i1,i2,i3p)-v2(i1,i2,i3m))*ker3(l)
+ e%s33=e%s33+(v3(i1,i2,i3p)-v3(i1,i2,i3m))*ker3(l)
+ END DO
+
+ e%s12=e%s12/2._8
+ e%s13=e%s13/2._8
+ e%s23=e%s23/2._8
+
+ END SUBROUTINE localstrain_fir
+
+ !---------------------------------------------------------------
+ !> LocalStrain_ANI
+ !! implements a different finite impulse response filter (FIR)
+ !! in each direction (ANIsotropy) to estimate derivatives and
+ !! strain components.
+ !
+ ! sylvain barbot (10/10/07) - original form
+ ! (03/05/09) - implements 3 filters
+ !---------------------------------------------------------------
+ SUBROUTINE localstrain_ani(e,i3m,i3p,px3)
+ TYPE(TENSOR), INTENT(OUT) :: e
+ INTEGER, INTENT(IN) :: i3m, i3p
+ REAL*8, INTENT(IN) :: px3
+
+ INTEGER :: l,i1m,i2m,i1p,i2p,foo,dum
+
+ e=TENSOR(0._4,0._4,0._4,0._4,0._4,0._4)
+
+ DO l=1,len1
+ ! neighbor samples with periodic boundary conditions
+ i1m=mod(sx1+i1-1-l,sx1)+1
+ i1p=mod(i1-1+l,sx1)+1
+
+ e%s11=e%s11+(v1(i1p,i2,i3)-v1(i1m,i2,i3))*ker1(l)
+ e%s12=e%s12+(v2(i1p,i2,i3)-v2(i1m,i2,i3))*ker1(l)
+ e%s13=e%s13+(v3(i1p,i2,i3)-v3(i1m,i2,i3))*ker1(l)
+ END DO
+
+ DO l=1,len2
+ ! neighbor samples with periodic boundary conditions
+ i2m=mod(sx2+i2-1-l,sx2)+1
+ i2p=mod(i2-1+l,sx2)+1
+
+ e%s12=e%s12+(v1(i1,i2p,i3)-v1(i1,i2m,i3))*ker2(l)
+ e%s22=e%s22+(v2(i1,i2p,i3)-v2(i1,i2m,i3))*ker2(l)
+ e%s23=e%s23+(v3(i1,i2p,i3)-v3(i1,i2m,i3))*ker2(l)
+ END DO
+
+ ! finite difference in the 3rd direction
+ e%s13=e%s13 + (v1(i1,i2,i3p)-v1(i1,i2,i3m))/px3
+ e%s23=e%s23 + (v2(i1,i2,i3p)-v2(i1,i2,i3m))/px3
+ e%s33=(v3(i1,i2,i3p)-v3(i1,i2,i3m))/px3
+
+ e%s12=e%s12/2._8
+ e%s13=e%s13/2._8
+ e%s23=e%s23/2._8
+
+ END SUBROUTINE localstrain_ani
+
+ END SUBROUTINE stressupdate
+
+ !-----------------------------------------------------------------
+ !> subroutine EquivalentBodyForce
+ !! computes and updates the equivalent body-force
+ !!
+ !! f = - div.( C : E^i )
+ !!
+ !! and the equivalent surface traction
+ !!
+ !! t = n . C : E^i
+ !!
+ !! with n = (0,0,-1). In indicial notations
+ !!
+ !! f_i = - (C_ijkl E^i_kl),j
+ !!
+ !! and
+ !!
+ !! t_1 = n_j C_ijkl E^i_kl
+ !!
+ !! where f is the equivalent body-force, t is the equivalent surface
+ !! traction, C is the elastic moduli tensor and E^i is the moment
+ !! density tensor tensor.
+ !!
+ !! Divergence is computed with a mixed numerical scheme including
+ !! centered finite-difference (in the vertical direction) and
+ !! finite impulse response differentiator filter for derivatives
+ !! estimates. see function 'stress' for further explanations.
+ !!
+ !! \author sylvain barbot (07/09/07) - original form
+ !! (10/09/07) - upgrade the finite difference scheme
+ !! to a finite impulse response filter
+ !! (02/12/09) - OpenMP parallel implementation
+ !-----------------------------------------------------------------
+ SUBROUTINE equivalentbodyforce(sig,dx1,dx2,dx3,sx1,sx2,sx3, &
+ c1,c2,c3,t1,t2,t3,mask)
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(INOUT), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
+ REAL*4, INTENT(INOUT), DIMENSION(sx1+2,sx2) :: t1,t2,t3
+#else
+ REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
+ REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2) :: t1,t2,t3
+#endif
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ REAL*4, INTENT(IN), DIMENSION(sx3), OPTIONAL :: mask
+
+ INTEGER :: i1,i2,i3,i3m,i3p,len1,len2,len3
+ REAL*8 :: f1,f2,f3,px3
+ REAL*8, DIMENSION(16) :: ker1,ker2,ker3
+
+ CALL optimalfilter(ker1,ker2,ker3,len1,len2,len3,sx1,sx2,sx3)
+ ker1=ker1/dx1; ker2=ker2/dx2; ker3=ker3/dx3
+
+ ! equivalent surface traction
+ DO i2=1,sx2
+ DO i1=1,sx1
+ t1(i1,i2)=t1(i1,i2)+sig(i1,i2,1)%s13
+ t2(i1,i2)=t2(i1,i2)+sig(i1,i2,1)%s23
+ t3(i1,i2)=t3(i1,i2)+sig(i1,i2,1)%s33
+ END DO
+ END DO
+
+ ! no periodicity in the 3rd direction
+ ! use a simple finite difference scheme in the 3rd direction
+!$omp parallel
+!$omp do private(i1,i2,f1,f2,f3,px3,i3m,i3p)
+ DO i3=1,sx3
+
+ IF ((i3 .gt. len3) .and. (i3 .lt. (sx3-len3+1))) &
+ CYCLE
+
+ IF (PRESENT(mask)) THEN
+ IF (mask(i3) .EQ. 0) THEN
+ CYCLE
+ END IF
+ END IF
+
+ IF (i3 .eq. 1) THEN
+ ! right-centered finite difference
+ px3=dx3; i3p=2; i3m=1
+ ELSE
+ IF (i3 .eq. sx3) THEN
+ ! left-centered finite difference
+ px3=dx3; i3p=sx3; i3m=sx3-1
+ ELSE
+ ! centered finite difference
+ px3=dx3*2._8; i3m=i3-1; i3p=i3+1
+ END IF
+ END IF
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL localdivergence_ani(f1,f2,f3,i3m,i3p,px3, &
+ i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,sig,sx1,sx2,sx3)
+
+ c1(i1,i2,i3)=c1(i1,i2,i3)-REAL(f1)
+ c2(i1,i2,i3)=c2(i1,i2,i3)-REAL(f2)
+ c3(i1,i2,i3)=c3(i1,i2,i3)-REAL(f3)
+
+ END DO
+ END DO
+ END DO
+!$omp end do nowait
+
+ ! intermediate depth treated isotropically
+!$omp do private(i1,i2,f1,f2,f3)
+ DO i3=len3+1,sx3-len3
+
+ IF (PRESENT(mask)) THEN
+ IF (mask(i3) .EQ. 0) THEN
+ CYCLE
+ END IF
+ END IF
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ ! Finite Impulse Response filter
+ !CALL localdivergence_fir(f1,f2,f3)
+ CALL localdivergence_fir2(f1,f2,f3,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,sig,sx1,sx2,sx3)
+
+ c1(i1,i2,i3)=c1(i1,i2,i3)-REAL(f1)
+ c2(i1,i2,i3)=c2(i1,i2,i3)-REAL(f2)
+ c3(i1,i2,i3)=c3(i1,i2,i3)-REAL(f3)
+ END DO
+ END DO
+ END DO
+!$omp end do
+!$omp end parallel
+
+ CONTAINS
+
+ !---------------------------------------------------------------
+ ! LocalDivergence_FIR
+ ! implements a finite impulse response filter (FIR) to estimate
+ ! the divergence of second-order tensor.
+ !
+ ! ATTENTION - calls to this routine can cause memory leak.
+ !
+ ! sylvain barbot (10/10/07) - original form
+ ! (03/05/08) - implements 3 filters
+ ! (02/11/09) - compatibility with OpenMP
+ !---------------------------------------------------------------
+ SUBROUTINE localdivergence_fir2(f1,f2,f3,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,sig,sx1,sx2,sx3)
+ REAL*8, INTENT(OUT) :: f1,f2,f3
+ INTEGER, INTENT(IN) :: len1,len2,len3,i1,i2,i3,sx1,sx2,sx3
+ REAL*8, INTENT(IN), DIMENSION(len1) :: ker1
+ REAL*8, INTENT(IN), DIMENSION(len2) :: ker2
+ REAL*8, INTENT(IN), DIMENSION(len3) :: ker3
+ TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: sig
+
+ INTEGER :: l,i1m,i1p,i2m,i2p,i3m,i3p
+
+ f1=0._8; f2=0._8; f3=0._8
+
+ DO l=1,len1
+ ! neighbor samples with periodic boundary conditions
+ i1m=mod(sx1+i1-1-l,sx1)+1
+ i1p=mod(i1-1+l,sx1)+1
+
+ f1=f1+(sig(i1p,i2,i3)%s11-sig(i1m,i2,i3)%s11)*ker1(l)
+ f2=f2+(sig(i1p,i2,i3)%s12-sig(i1m,i2,i3)%s12)*ker1(l)
+ f3=f3+(sig(i1p,i2,i3)%s13-sig(i1m,i2,i3)%s13)*ker1(l)
+ END DO
+
+ DO l=1,len2
+ ! neighbor samples with periodic boundary conditions
+ i2m=mod(sx2+i2-1-l,sx2)+1
+ i2p=mod(i2-1+l,sx2)+1
+
+ f1=f1+(sig(i1,i2p,i3)%s12-sig(i1,i2m,i3)%s12)*ker2(l)
+ f2=f2+(sig(i1,i2p,i3)%s22-sig(i1,i2m,i3)%s22)*ker2(l)
+ f3=f3+(sig(i1,i2p,i3)%s23-sig(i1,i2m,i3)%s23)*ker2(l)
+ END DO
+
+ DO l=1,len3
+ ! neighbor samples in semi-infinite solid
+ i3m=i3-l
+ i3p=i3+l
+
+ f1=f1+(sig(i1,i2,i3p)%s13-sig(i1,i2,i3m)%s13)*ker3(l)
+ f2=f2+(sig(i1,i2,i3p)%s23-sig(i1,i2,i3m)%s23)*ker3(l)
+ f3=f3+(sig(i1,i2,i3p)%s33-sig(i1,i2,i3m)%s33)*ker3(l)
+ END DO
+
+ END SUBROUTINE localdivergence_fir2
+
+ !---------------------------------------------------------------
+ ! LocalDivergence_FIR
+ ! implements a finite impulse response filter (FIR) to estimate
+ ! the divergence of second-order tensor.
+ !
+ ! ATTENTION - calls to this routine can cause memory leak.
+ !
+ ! sylvain barbot (10/10/07) - original form
+ ! (03/05/08) - implements 3 filters
+ !---------------------------------------------------------------
+ SUBROUTINE localdivergence_fir(f1,f2,f3)
+ REAL*8, INTENT(OUT) :: f1,f2,f3
+
+ INTEGER :: l,i1m,i1p,i2m,i2p,i3m,i3p
+
+ f1=0._8; f2=0._8; f3=0._8
+
+ DO l=1,len1
+ ! neighbor samples with periodic boundary conditions
+ i1m=mod(sx1+i1-1-l,sx1)+1
+ i1p=mod(i1-1+l,sx1)+1
+
+ f1=f1+(sig(i1p,i2,i3)%s11-sig(i1m,i2,i3)%s11)*ker1(l)
+ f2=f2+(sig(i1p,i2,i3)%s12-sig(i1m,i2,i3)%s12)*ker1(l)
+ f3=f3+(sig(i1p,i2,i3)%s13-sig(i1m,i2,i3)%s13)*ker1(l)
+ END DO
+
+ DO l=1,len2
+ ! neighbor samples with periodic boundary conditions
+ i2m=mod(sx2+i2-1-l,sx2)+1
+ i2p=mod(i2-1+l,sx2)+1
+
+ f1=f1+(sig(i1,i2p,i3)%s12-sig(i1,i2m,i3)%s12)*ker2(l)
+ f2=f2+(sig(i1,i2p,i3)%s22-sig(i1,i2m,i3)%s22)*ker2(l)
+ f3=f3+(sig(i1,i2p,i3)%s23-sig(i1,i2m,i3)%s23)*ker2(l)
+ END DO
+
+ DO l=1,len3
+ ! neighbor samples in semi-infinite solid
+ i3m=i3-l
+ i3p=i3+l
+
+ f1=f1+(sig(i1,i2,i3p)%s13-sig(i1,i2,i3m)%s13)*ker3(l)
+ f2=f2+(sig(i1,i2,i3p)%s23-sig(i1,i2,i3m)%s23)*ker3(l)
+ f3=f3+(sig(i1,i2,i3p)%s33-sig(i1,i2,i3m)%s33)*ker3(l)
+ END DO
+
+ END SUBROUTINE localdivergence_fir
+
+ !---------------------------------------------------------------
+ ! LocalDivergence_ANI
+ ! implements a finite impulse response filter (FIR) in the
+ ! horizontal direction and a finite-difference scheme in the
+ ! vertical direction to estimate the divergence of second-order
+ ! tensor.
+ ! Finite difference scheme is left-centered, right-centered or
+ ! symmetric, depending on input positions (i3m,i3p) and spacing
+ ! (px3).
+ !
+ ! sylvain barbot (10/10/07) - original form
+ ! (03/05/08) - implements 3 filters
+ ! (02/12/09) - compatibility with OpenMP
+ !---------------------------------------------------------------
+ SUBROUTINE localdivergence_ani(f1,f2,f3,i3m,i3p,px3,i1,i2,i3,ker1,ker2,ker3,len1,len2,len3,sig,sx1,sx2,sx3)
+ REAL*8, INTENT(OUT) :: f1,f2,f3
+ INTEGER, INTENT(IN) :: i3m,i3p,i1,i2,i3,len1,len2,len3,sx1,sx2,sx3
+ REAL*8, INTENT(IN), DIMENSION(len1) :: ker1
+ REAL*8, INTENT(IN), DIMENSION(len2) :: ker2
+ REAL*8, INTENT(IN), DIMENSION(len3) :: ker3
+ REAL*8, INTENT(IN) :: px3
+ TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: sig
+
+ INTEGER :: l,i1m,i1p,i2m,i2p,foo,dum
+
+ f1=0._8; f2=0._8; f3=0._8
+
+ ! differentiator filter in the horizontal direction
+ DO l=1,len1
+ ! neighbor samples with periodic boundary conditions
+ i1m=mod(sx1+i1-1-l,sx1)+1
+ i1p=mod(i1-1+l,sx1)+1
+
+ f1=f1+(sig(i1p,i2,i3)%s11-sig(i1m,i2,i3)%s11)*ker1(l)
+ f2=f2+(sig(i1p,i2,i3)%s12-sig(i1m,i2,i3)%s12)*ker1(l)
+ f3=f3+(sig(i1p,i2,i3)%s13-sig(i1m,i2,i3)%s13)*ker1(l)
+ END DO
+
+ DO l=1,len2
+ ! neighbor samples with periodic boundary conditions
+ i2m=mod(sx2+i2-1-l,sx2)+1
+ i2p=mod(i2-1+l,sx2)+1
+
+ f1=f1+(sig(i1,i2p,i3)%s12-sig(i1,i2m,i3)%s12)*ker2(l)
+ f2=f2+(sig(i1,i2p,i3)%s22-sig(i1,i2m,i3)%s22)*ker2(l)
+ f3=f3+(sig(i1,i2p,i3)%s23-sig(i1,i2m,i3)%s23)*ker2(l)
+ END DO
+
+ ! finite difference in the 3-direction
+ f1=f1+( sig(i1,i2,i3p)%s13-sig(i1,i2,i3m)%s13 )/px3
+ f2=f2+( sig(i1,i2,i3p)%s23-sig(i1,i2,i3m)%s23 )/px3
+ f3=f3+( sig(i1,i2,i3p)%s33-sig(i1,i2,i3m)%s33 )/px3
+
+ END SUBROUTINE localdivergence_ani
+
+ !-------------------------------------------------------------------
+ ! subroutine LocalDivergence_CFD
+ ! estimate the divergence of the stress tensor by means of simple
+ ! finite difference schemes. In the horizontal direction, numerical
+ ! scheme is always centered finite difference. because of the
+ ! surface and bottom boundary condition, scheme in the vertical
+ ! direction changes from right-centered at the top, to center in the
+ ! middle, to left-centered finite difference at the bottom.
+ !-------------------------------------------------------------------
+ SUBROUTINE localdivergence_cfd(f1,f2,f3,i3m,i3p,px3)
+ REAL*8, INTENT(OUT) :: f1,f2,f3
+ REAL*8, INTENT(IN) :: px3
+ INTEGER, INTENT(IN) :: i3m, i3p
+
+ INTEGER :: i1m,i1p,i2m,i2p
+
+ ! neighbor samples
+ i1m=mod(sx1+i1-2,sx1)+1
+ i1p=mod(i1,sx1)+1
+ i2m=mod(sx2+i2-2,sx2)+1
+ i2p=mod(i2,sx2)+1
+
+ f1= ( sig(i1p,i2,i3)%s11-sig(i1m,i2,i3)%s11 )/dx1/2._8 &
+ +( sig(i1,i2p,i3)%s12-sig(i1,i2m,i3)%s12 )/dx2/2._8 &
+ +( sig(i1,i2,i3p)%s13-sig(i1,i2,i3m)%s13 )/px3
+ f2= ( sig(i1p,i2,i3)%s12-sig(i1m,i2,i3)%s12 )/dx1/2._8 &
+ +( sig(i1,i2p,i3)%s22-sig(i1,i2m,i3)%s22 )/dx2/2._8 &
+ +( sig(i1,i2,i3p)%s23-sig(i1,i2,i3m)%s23 )/px3
+ f3= ( sig(i1p,i2,i3)%s13-sig(i1m,i2,i3)%s13 )/dx1/2._8 &
+ +( sig(i1,i2p,i3)%s23-sig(i1,i2m,i3)%s23 )/dx2/2._8 &
+ +( sig(i1,i2,i3p)%s33-sig(i1,i2,i3m)%s33 )/px3
+
+ END SUBROUTINE localdivergence_cfd
+
+ END SUBROUTINE equivalentbodyforce
+
+
+ !---------------------------------------------------------------------
+ !> function SourceSpectrum
+ !! computes the equivalent body-forces for a buried dislocation,
+ !! with strike-slip and dip-slip components,
+ !! slip s, width W, length L in a rigidity mu
+ !!
+ !! \author sylvain barbot (06-25-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE sourcespectrum(mu,s,x,y,d, &
+ L,W,strike,dip,rake,beta,dx1,dx2,dx3,f1,f2,f3)
+ REAL*8, INTENT(IN) :: mu,s,x,y,d,L,W,strike,dip,rake,&
+ beta,dx1,dx2,dx3
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: f1,f2,f3
+
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3
+ REAL*8 :: k1,k2,k3,k1s,k2s,k3s,k1i,k3i, &
+ cstrike,sstrike,cdip,sdip,cr,sr,k2r
+ COMPLEX*8 :: cbuf1,cbuf2,cbuf3,source,image,&
+ shift,scale,aperture,up,down
+ COMPLEX*8, PARAMETER :: i=CMPLX(0._8,pi2)
+
+ sx1=SIZE(f2,1)-2
+ sx2=SIZE(f2,2)
+ sx3=SIZE(f2,3)
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+ cr=cos(rake)
+ sr=sin(rake)
+ scale=i*mu*s*L*W
+
+ DO i3=1,sx3
+ CALL wavenumber3(i3,sx3,dx3,k3)
+ down=exp(-i*k3*(L/2._8+d))
+ up=conjg(down)
+ DO i2=1,sx2
+ CALL wavenumber2(i2,sx2,dx2,k2)
+ DO i1=1,sx1/2+1
+ CALL wavenumber1(i1,sx1,dx1,k1)
+
+ !rotate the wavenumbers
+ k2r= cstrike*k1-sstrike*k2
+ k1s= cdip*k2r-sdip*k3
+ k2s= sstrike*k1+cstrike*k2
+ k3s= sdip*k2r+cdip*k3
+ k1i= cdip*k2r+sdip*k3
+ k3i=-sdip*k2r+cdip*k3
+
+ !integrate at depth and along strike with raised cosine taper
+ !and shift sources to x,y,z coordinate
+ shift=exp(-i*(x*k1+y*k2))
+ aperture=scale*omegak(W*k2s,beta)
+ source=omegak(L*k3s,beta)*aperture*shift*down
+ image =omegak(L*k3i,beta)*aperture*shift*up
+
+ !convolve source and image with a 1-D gaussian
+ source=source*exp(-(pi*dx1*k1s)**2)
+ image = image*exp(-(pi*dx1*k1i)**2)
+
+ cbuf1= cdip*cstrike*( &
+ -(cr*k2s+sr*k3s)*source-(cr*k2s-sr*k3i)*image) &
+ +cr*sstrike*(-k1s*source-k1i*image) &
+ -sr*sdip*cstrike*(-k1s*source-k1i*image)
+ !change -sr*sdip back to +sr*sdip above and below
+ cbuf2=-cdip*sstrike*( &
+ -(cr*k2s+sr*k3s)*source-(cr*k2s-sr*k3i)*image) &
+ +cr*cstrike*(-k1s*source-k1i*image) &
+ -sr*sdip*sstrike*(-k1s*source-k1i*image)
+ !change -sdip back to +sdip here
+ cbuf3=-sdip*((-sr*k3s-cr*k2s)*source &
+ +(-sr*k3i+cr*k2s)*image) &
+ +sr*cdip*(-k1s*source+k1i*image)
+
+ f1(2*i1-1:2*i1,i2,i3)=&
+ f1(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf1),AIMAG(cbuf1)/)
+ f2(2*i1-1:2*i1,i2,i3)=&
+ f2(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf2),AIMAG(cbuf2)/)
+ f3(2*i1-1:2*i1,i2,i3)=&
+ f3(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf3),AIMAG(cbuf3)/)
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE sourcespectrum
+
+
+ !---------------------------------------------------------------------
+ !> function SourceSpectrumHalfSpace
+ !! computes the equivalent body-forces for a buried dislocation,
+ !! with strike-slip and dip-slip components,
+ !! slip s, width W, length L in a rigidity mu; sources are not imaged
+ !!
+ !! \author sylvain barbot (06-25-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE sourcespectrumhalfspace(mu,s,x,y,d, &
+ L,W,strike,dip,rake,beta,dx1,dx2,dx3,f1,f2,f3)
+ REAL*8, INTENT(IN) :: mu,s,x,y,d,L,W,strike,dip,rake,&
+ beta,dx1,dx2,dx3
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: f1,f2,f3
+
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3
+ REAL*8 :: k1,k2,k3,k1s,k2s,k3s, &
+ cstrike,sstrike,cdip,sdip,cr,sr,k2r
+ COMPLEX*8 :: cbuf1,cbuf2,cbuf3,source,&
+ shift,scale,aperture,down
+ COMPLEX*8, PARAMETER :: i=CMPLX(0._8,pi2)
+
+ sx1=SIZE(f2,1)-2
+ sx2=SIZE(f2,2)
+ sx3=SIZE(f2,3)
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+ cr=cos(rake)
+ sr=sin(rake)
+ scale=i*mu*s*L*W
+
+ DO i3=1,sx3
+ CALL wavenumber3(i3,sx3,dx3,k3)
+ down=exp(-i*k3*(L/2._8+d))
+ DO i2=1,sx2
+ CALL wavenumber2(i2,sx2,dx2,k2)
+ DO i1=1,sx1/2+1
+ CALL wavenumber1(i1,sx1,dx1,k1)
+ !rotate the wavenumbers
+ k2r= cstrike*k1-sstrike*k2
+ k1s= cdip*k2r-sdip*k3
+ k2s= sstrike*k1+cstrike*k2
+ k3s= sdip*k2r+cdip*k3
+
+ !convolve source and image with a 1-D gaussian
+ !integrate at depth and along strike with raised cosine taper
+ !and shift sources to x,y,z coordinate
+ shift=exp(-i*(x*k1+y*k2))
+ aperture=scale*omegak(W*k2s,beta)*exp(-(pi*dx1*k1s)**2)
+ source=(omegak(L*k3s,beta)*aperture)*shift*down
+
+ cbuf1= cdip*cstrike*( &
+ -(cr*k2s+sr*k3s)*source) &
+ +cr*sstrike*(-k1s*source) &
+ -sr*sdip*cstrike*(-k1s*source)
+ cbuf2=-cdip*sstrike*( &
+ -(cr*k2s+sr*k3s)*source) &
+ +cr*cstrike*(-k1s*source) &
+ -sr*sdip*sstrike*(-k1s*source)
+ cbuf3=-sdip*((-sr*k3s-cr*k2s)*source) &
+ +sr*cdip*(-k1s*source)
+
+ f1(2*i1-1:2*i1,i2,i3)=&
+ f1(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf1),AIMAG(cbuf1)/)
+ f2(2*i1-1:2*i1,i2,i3)=&
+ f2(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf2),AIMAG(cbuf2)/)
+ f3(2*i1-1:2*i1,i2,i3)=&
+ f3(2*i1-1:2*i1,i2,i3)+(/REAL(cbuf3),AIMAG(cbuf3)/)
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE sourcespectrumhalfspace
+
+ !---------------------------------------------------------------------
+ !> function Source computes the equivalent body-forces
+ !! in the space domain for a buried dislocation with strike-slip
+ !! and dip-slip components, slip s, width W, length L in a rigidity mu
+ !!
+ !! Default (strike=0, dip=0, rake=0) is a vertical left-lateral
+ !! strike-slip fault along the x2 axis. Default fault slip is
+ !! represented with the double-couple equivalent body forces:
+ !!
+ !!\verbatim
+ !!
+ !! x1
+ !! |
+ !! | ^ f2
+ !! | |<-----
+ !! +---+------+---- x2
+ !! ----->|
+ !! v f1
+ !!
+ !!\endverbatim
+ !!
+ !! \author sylvain barbot (06-29-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE source(mu,s,x,y,z,L,W,strike,dip,rake, &
+ beta,sx1,sx2,sx3,dx1,dx2,dx3,f1,f2,f3,t1,t2,t3)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: mu,s,x,y,z,L,W,strike,dip,rake, &
+ beta,dx1,dx2,dx3
+#ifdef ALIGN_DATA
+ REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
+ REAL*4, DIMENSION(sx1+2,sx2), INTENT(INOUT) :: t1,t2,t3
+#else
+ REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
+ REAL*4, DIMENSION(sx1,sx2), INTENT(INOUT) :: t1,t2,t3
+#endif
+
+ INTEGER :: i1,i2,i3
+ REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
+ cstrike,sstrike,cdip,sdip,cr,sr,x2r, &
+ sourc,image,scale,temp1,temp2,temp3, &
+ dblcp,cplei,dipcs,dipci,xr,yr,zr,Wp,Lp
+ REAL(8), DIMENSION(3) :: n,b
+ TYPE(TENSOR) :: m
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+ cr=cos(rake)
+ sr=sin(rake)
+ scale=-mu*s
+
+ ! effective tapered dimensions
+ Wp=W*(1._8+2._8*beta)/2._8
+ Lp=L*(1._8+2._8*beta)/2._8
+
+ ! rotate centre coordinates of source and images
+ x2r= cstrike*x -sstrike*y
+ xr = cdip *x2r-sdip *z
+ yr = sstrike*x +cstrike*y
+ zr = sdip *x2r+cdip *z
+
+ ! equivalent surface traction
+ i3=1
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
+ dx1,dx2,dx3,x1,x2,x3)
+
+ IF ((ABS(x1-x).GT.MAX(Lp,Wp)).OR.(ABS(x2-y).GT.MAX(Lp,Wp))) CYCLE
+
+ x2r= cstrike*x1-sstrike*x2
+ x1s= cdip*x2r-sdip*x3
+ x1i= cdip*x2r+sdip*x3
+ IF ((ABS(x1s-xr).GT.7.01*dx1).AND.(ABS(x1i-xr).GT.7.01*dx1)) CYCLE
+ x2s= sstrike*x1+cstrike*x2
+ x3s= sdip*x2r+cdip*x3
+ x3i=-sdip*x2r+cdip*x3
+
+ ! integrate at depth and along strike with raised cosine taper
+ ! and shift sources to x,y,z coordinate
+ temp1=gauss(x1s-xr,dx1)
+ temp2=omega((x2s-yr)/W,beta)
+ temp3=omega((x3s-zr)/L,beta)
+ sourc=temp1*temp2*temp3
+
+ ! add image
+ temp1=gauss(x1i-xr,dx1)
+ temp3=omega((x3i+zr)/L,beta)
+ sourc=sourc+temp1*temp2*temp3
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike*sourc
+ n(2)=-cdip*sstrike*sourc
+ n(3)=-sdip*sourc
+
+ ! burger vector (strike-slip)
+ b(1)=sstrike*cr
+ b(2)=cstrike*cr
+
+ ! burger vector (dip-slip)
+ b(1)=b(1)+cstrike*sdip*sr
+ b(2)=b(2)-sstrike*sdip*sr
+ b(3)= +cdip*sr
+
+ ! principal stress (symmetric deviatoric second-order tensor)
+ m=n .sdyad. (mu*s*b)
+
+ ! surface tractions
+ t1(i1,i2)=t1(i1,i2)+m%s13
+ t2(i1,i2)=t2(i1,i2)+m%s23
+ t3(i1,i2)=t3(i1,i2)+m%s33
+
+ END DO
+ END DO
+
+ ! equivalent body-force density
+!$omp parallel do private(i1,i2,x1,x2,x3,x2r,x1s,x1i,x2s,x3s,x3i,temp1,temp2,temp3), &
+!$omp private(sourc,dblcp,dipcs,image,cplei,dipci)
+ DO i3=1,sx3/2
+ CALL shiftedcoordinates(1,1,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
+ IF ((abs(x3-z).gt.Lp) .and. (abs(x3+z).gt.Lp)) CYCLE
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
+ IF ((ABS(x1-x) .GT. MAX(Wp,Lp)) .OR. (abs(x2-y) .GT. MAX(Wp,Lp))) CYCLE
+
+ x2r= cstrike*x1-sstrike*x2
+ x1s= cdip*x2r-sdip*x3
+ x1i= cdip*x2r+sdip*x3
+ IF ((ABS(x1s-xr) .GT. 7.01_8*dx1) .AND. (ABS(x1i-xr) .GT. 7.01_8*dx1)) CYCLE
+ x2s= sstrike*x1+cstrike*x2
+ x3s= sdip*x2r+cdip*x3
+ x3i=-sdip*x2r+cdip*x3
+
+ !integrate at depth and along strike with raised cosine taper
+ !and shift sources to x,y,z coordinate
+ temp1=gauss(x1s-xr,dx1)
+ temp2=omega((x2s-yr)/W,beta)
+ temp3=omega((x3s-zr)/L,beta)
+ sourc=scale *gaussp(x1s-xr,dx1) &
+ *temp2 &
+ *temp3
+ dblcp=scale/W*temp1 &
+ *omegap((x2s-yr)/W,beta) &
+ *temp3
+ dipcs=scale/L*temp1 &
+ *temp2 &
+ *omegap((x3s-zr)/L,beta)
+
+ temp1=gauss(x1i-xr,dx1)
+ temp3=omega((x3i+zr)/L,beta)
+ image=scale *gaussp(x1i-xr,dx1) &
+ *temp2 &
+ *temp3
+ cplei=scale/W*temp1 &
+ *omegap((x2s-yr)/W,beta) &
+ *temp3
+ dipci=scale/L*temp1 &
+ *temp2 &
+ *omegap((x3i+zr)/L,beta)
+
+ ! strike-slip component
+
+ IF (2.01_8*DEG2RAD .GT. dip) THEN
+ ! use method of images for subvertical faults
+ f1(i1,i2,i3)=f1(i1,i2,i3) &
+ +cr*sstrike*(sourc+image) &
+ +cr*cdip*cstrike*(dblcp+cplei)
+ f2(i1,i2,i3)=f2(i1,i2,i3) &
+ +cr*cstrike*(sourc+image) &
+ -cr*cdip*sstrike*(dblcp+cplei)
+ f3(i1,i2,i3)=f3(i1,i2,i3) &
+ -cr*sdip*(dblcp-cplei)
+ ELSE
+ ! dipping faults do not use method of image
+ f1(i1,i2,i3)=f1(i1,i2,i3) &
+ +cr*sstrike*(sourc) &
+ +cr*cdip*cstrike*(dblcp)
+ f2(i1,i2,i3)=f2(i1,i2,i3) &
+ +cr*cstrike*(sourc) &
+ -cr*cdip*sstrike*(dblcp)
+ f3(i1,i2,i3)=f3(i1,i2,i3) &
+ -cr*sdip*(dblcp)
+ END IF
+
+ ! dip-slip component
+
+ f1(i1,i2,i3)=f1(i1,i2,i3) &
+ +cdip*sr*cstrike*dipcs &
+ +sdip*sr*cstrike*sourc
+ f2(i1,i2,i3)=f2(i1,i2,i3) &
+ -cdip*sr*sstrike*dipcs &
+ -sdip*sr*sstrike*sourc
+ f3(i1,i2,i3)=f3(i1,i2,i3) &
+ +cdip*sr*sourc &
+ -sdip*sr*dipcs
+
+ END DO
+ END DO
+ END DO
+!$omp end parallel do
+
+ END SUBROUTINE source
+
+ !---------------------------------------------------------------------
+ !> function TensileSource
+ !! computes the equivalent body-forces in the space domain for a buried
+ !! tensile crack with opening s, width W, length L and Lame parameters
+ !! lambda, mu.
+ !!
+ !! Default (strike=0, dip=0) is a vertical opening along the x2 axis.
+ !! Default fault opening is represented with the double-couple
+ !! equivalent body forces:
+ !!
+ !!\verbatim
+ !!
+ !! x1 f1
+ !! | ^^^^^^^
+ !! | |||||||
+ !! | -f2 <--+-------+--> f2
+ !! | |||||||
+ !! | vvvvvvv
+ !! | -f1
+ !! |
+ !! +----------------------------- x2
+ !!
+ !!\endverbatim
+ !!
+ !! The eigenstrain/potency tensor for a point source is
+ !!
+ !!\verbatim
+ !!
+ !! | 1 0 0 |
+ !! E^i = | 0 0 0 |
+ !! | 0 0 0 |
+ !!
+ !!\endverbatim
+ !!
+ !! and the corresponding moment density for a point source is
+ !!
+ !!\verbatim
+ !!
+ !! | lambda+2*mu 0 0 |
+ !! m = C : E^i = | 0 lambda 0 |
+ !! | 0 0 lambda |
+ !!
+ !!\endverbatim
+ !!
+ !! Moment density is integrated along the planar surface
+ !!
+ !! \f[ box(x2) \delta(x1) box(x3) \f]
+ !!
+ !! where box(x) and delta(x) are the boxcar and the dirac delta
+ !! functions, respectively. We use a tapered boxcar, omega_beta(x) and
+ !! approximate the delta function by a small gaussian function.
+ !! Finally, the equivalent body force is the divergence of the moment
+ !! density tensor
+ !!
+ !! \f[ f_i = - ( m_{ij} )_{,j} \f]
+ !!
+ !! derivatives are performed analytically on the gaussian and
+ !! omega_beta functions.
+ !!
+ !! \author sylvain barbot (05-09-08) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE tensilesource(lambda,mu,s,x,y,z,L,W,strike,dip, &
+ beta,sx1,sx2,sx3,dx1,dx2,dx3,f1,f2,f3)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: lambda,mu,s,x,y,z,L,W,strike,dip,&
+ beta,dx1,dx2,dx3
+#ifdef ALIGN_DATA
+ REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
+#else
+ REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
+#endif
+
+ INTEGER :: i1,i2,i3
+ REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
+ cstrike,sstrike,cdip,sdip,x2r,&
+ sourc,image,scale1,scale2,temp1,temp2,temp3, &
+ dblcp,cplei,dipcs,dipci,xr,yr,zr,Wp,Lp
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! effective tapered dimensions
+ Wp=W*(1._8+2._8*beta)/2._8
+ Lp=L*(1._8+2._8*beta)/2._8
+
+ ! rotate centre coordinates of source and images
+ x2r= cstrike*x -sstrike*y
+ xr = cdip *x2r-sdip *z
+ yr = sstrike*x +cstrike*y
+ zr = sdip *x2r+cdip *z
+ scale1=-s*(lambda+2._8*mu)
+ scale2=-s*lambda
+
+ DO i3=1,sx3
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
+ IF ((abs(x3-z).gt.Lp) .and. (abs(x3+z).gt.Lp)) CYCLE
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
+ IF ((abs(x1-x).gt.Wp) .or. (abs(x2-y).gt.Wp)) CYCLE
+
+ x2r= cstrike*x1-sstrike*x2
+ x1s= cdip*x2r-sdip*x3
+ x1i= cdip*x2r+sdip*x3
+ IF ((abs(x1s-xr).gt.7.01*dx1).and.(abs(x1i-xr).gt.7.01*dx1)) CYCLE
+ x2s= sstrike*x1+cstrike*x2
+ x3s= sdip*x2r+cdip*x3
+ x3i=-sdip*x2r+cdip*x3
+
+ !integrate at depth and along strike with raised cosine taper
+ !and shift sources to x,y,z coordinate
+ temp1=gauss(x1s-xr,dx1)
+ temp2=omega((x2s-yr)/W,beta)
+ temp3=omega((x3s-zr)/L,beta)
+ sourc=scale1 *gaussp(x1s-xr,dx1) &
+ *temp2 &
+ *temp3
+ dblcp=scale2/W*temp1 &
+ *omegap((x2s-yr)/W,beta) &
+ *temp3
+ dipcs=scale2/L*temp1 &
+ *temp2 &
+ *omegap((x3s-zr)/L,beta)
+
+ temp1=gauss(x1i-xr,dx1)
+ temp3=omega((x3i+zr)/L,beta)
+ image=scale1 *gaussp(x1i-xr,dx1) &
+ *temp2 &
+ *temp3
+ cplei=scale2/W*temp1 &
+ *omegap((x2s-yr)/W,beta) &
+ *temp3
+ dipci=scale2/L*temp1 &
+ *temp2 &
+ *omegap((x3i+zr)/L,beta)
+
+ ! force moments in original coordinate system
+
+ f1(i1,i2,i3)=f1(i1,i2,i3) &
+ +cstrike*cdip*(sourc+image) &
+ +sstrike*(dblcp+cplei) &
+ +cstrike*sdip*(dipcs+dipci)
+ f2(i1,i2,i3)=f2(i1,i2,i3) &
+ -sstrike*cdip*(sourc+image) &
+ +cstrike*(dblcp+cplei) &
+ -sstrike*sdip*(dipcs+dipci)
+ f3(i1,i2,i3)=f3(i1,i2,i3) &
+ -sdip*(sourc-image) &
+ +cdip*(dipcs-dipci)
+
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE tensilesource
+
+ !---------------------------------------------------------------------
+ !! function MogiSource
+ !! computes the equivalent body-forces in the space domain for a buried
+ !! dilatation point source.
+ !!
+ !! The point-source opening o with at position xs in the half space is
+ !! associated with eigenstrain
+ !!
+ !! \f[ E^i = o \frac{1}{3} I \delta(x-x_s) \f]
+ !!
+ !! where I is the diagonal tensor and delta is the Dirac delta function
+ !! (or in index notation E^i_{ij} = o delta_{ij} / 3 delta(xs) ) and
+ !! with the moment density
+ !!
+ !! \f[ m = C : E^i = K o I \delta(x-x_s) \f]
+ !!
+ !! The equivalent body-force density is
+ !!
+ !! \f[ f = - \nabla \cdot m = K o \nabla \delta(x-x_s) \f]
+ !!
+ !! where nabla is the gradient operator. Default source opening is
+ !! represented with the isotropic equivalent body-force density:
+ !!
+ !!\verbatim
+ !!
+ !! x1
+ !! | f1
+ !! | ^
+ !! | f2 | f2
+ !! +---<--+-->---- x2
+ !! |
+ !! v f1
+ !!
+ !! x3
+ !! | f3
+ !! | ^
+ !! | f2 | f2
+ !! +---<--+-->---- x2
+ !! |
+ !! v f3
+ !!
+ !!\endverbatim
+ !!
+ !! \author sylvain barbot (03-24-09) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE mogisource(lambda,mu,o,xs,ys,zs,sx1,sx2,sx3,dx1,dx2,dx3,f1,f2,f3)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: lambda,mu,o,xs,ys,zs,dx1,dx2,dx3
+#ifdef ALIGN_DATA
+ REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
+#else
+ REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(INOUT) :: f1,f2,f3
+#endif
+
+ INTEGER :: i1,i2,i3
+ REAL*8 :: x1,x2,x3,source1,source2,source3, &
+ image1,image2,image3,scale,temp1,temp2,temp3,Wp,Lp
+
+ scale=-(lambda+2._8*mu/3._8)*o ! -kappa*o
+
+ ! effective dimensions
+ Wp=6._8*MAX(dx1,dx2,dx3)
+ Lp=6._8*MAX(dx1,dx2,dx3)
+
+ DO i3=1,sx3
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
+ IF ((abs(x3-zs).gt.Lp) .and. (abs(x3+zs).gt.Lp)) CYCLE
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
+ IF ((abs(x1-xs).gt.Wp) .or. (abs(x2-ys).gt.Wp)) CYCLE
+
+ temp1=gauss(x1-xs,dx1)
+ temp2=gauss(x2-ys,dx2)
+ temp3=gauss(x3-zs,dx3)
+
+ source1=scale*gaussp(x1-xs,dx1)*temp2*temp3
+ source2=scale*temp1*gaussp(x2-ys,dx2)*temp3
+ source3=scale*temp1*temp2*gaussp(x3-zs,dx3)
+
+ temp3=gauss(x3+zs,dx3)
+
+ image1=scale*gaussp(x1-xs,dx1)*temp2*temp3
+ image2=scale*temp1*gaussp(x2-ys,dx2)*temp3
+ image3=scale*temp1*temp2*gaussp(x3+zs,dx3)
+
+ ! equivalent body-force density
+ f1(i1,i2,i3)=f1(i1,i2,i3)+(source1+image1)
+ f2(i1,i2,i3)=f2(i1,i2,i3)+(source2+image2)
+ f3(i1,i2,i3)=f3(i1,i2,i3)+(source3-image3)
+
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE mogisource
+
+ !---------------------------------------------------------------------
+ !> subroutine Traction
+ !! assigns the traction vector at the surface.
+ !!
+ !! \author sylvain barbot (07-19-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE traction(mu,e,sx1,sx2,dx1,dx2,t,Dt,t3,rate)
+ TYPE(EVENT_STRUC), INTENT(IN) :: e
+ INTEGER, INTENT(IN) :: sx1,sx2
+ REAL*8, INTENT(IN) :: mu,dx1,dx2,t,Dt
+#ifdef ALIGN_DATA
+ REAL*4, DIMENSION(sx1+2,sx2), INTENT(INOUT) :: t3
+#else
+ REAL*4, DIMENSION(sx1,sx2), INTENT(INOUT) :: t3
+#endif
+ LOGICAL, INTENT(IN), OPTIONAL :: rate
+
+ INTEGER :: i,i1,i2,i3
+ LOGICAL :: israte
+ REAL*8 :: period,phi,amp,L,W,Lp,Wp,x1,x2,x3,x,y,beta
+
+ REAL*8, PARAMETER :: pi=3.141592653589793115997963468544185161_8
+
+ IF (PRESENT(rate)) THEN
+ israte=rate
+ ELSE
+ israte=.FALSE.
+ END IF
+
+ ! loop over traction sources
+ DO i=1,e%nl
+
+ x=e%l(i)%x
+ y=e%l(i)%y
+
+ L=e%l(i)%length
+ W=e%l(i)%width
+
+ beta=e%l(i)%beta
+
+ ! effective tapered dimensions
+ Lp=L*(1._8+2._8*beta)/2._8
+ Wp=W*(1._8+2._8*beta)/2._8
+
+ i3=1
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,1, &
+ dx1,dx2,1.d8,x1,x2,x3)
+
+ IF ((ABS(x1-x).GT.MAX(Lp,Wp)).OR.(ABS(x2-y).GT.MAX(Lp,Wp))) CYCLE
+
+ amp=omega((x1-x)/L,beta)* &
+ omega((x2-y)/W,beta)* &
+ mu*e%l(i)%slip
+
+ IF (israte) THEN
+ ! surface tractions rate
+ period=e%l(i)%period
+ phi=e%l(i)%phase
+
+ t3(i1,i2)=t3(i1,i2)-amp*(sin(2*pi*(t+Dt)/period+phi)-sin(2*pi*t/period+phi))
+ ELSE
+ IF (e%l(i)%period .LE. 0) THEN
+ ! surface tractions
+ t3(i1,i2)=t3(i1,i2)-amp
+ END IF
+ END IF
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE traction
+
+ !---------------------------------------------------------------------
+ !! function MomentDensityShear
+ !! computes the inelastic irreversible moment density in the space
+ !! domain corresponding to a buried dislocation with strike-slip and
+ !! dip-slip components (pure shear). A fault along a surface of normal
+ !! n_i with a burger vector s_i, is associated with the eigenstrain
+ !!
+ !! E^i_ij = 1/2 ( n_i s_j + s_i n_j )
+ !!
+ !! In a heterogeneous medium of elastic moduli tensor C_ijkl, the
+ !! corresponding moment density tensor is
+ !!
+ !! m_ij = C_ijkl E^i_kl
+ !!
+ !! where C = C(x) is a function of space. Equivalent body forces
+ !! representing the set of dislocations can be obtained by evaluating
+ !! the divergence of the moment density tensor
+ !!
+ !! f_i = - ( m_ji ),j
+ !!
+ !! using the function "EquivalentBodyForce" in this module.
+ !!
+ !! The default dislocation extends in the x2 direction, with a normal
+ !! in the x1 direction. Using the following angular convention,
+ !!
+ !!\verbatim
+ !!
+ !! x1 ! x1
+ !! n theta | ! n phi |
+ !! \ ____| ! \ ____|
+ !! \ | ! \ |
+ !! \ | ! \ |
+ !! -----\+------ x2 ! -----\+------ x3
+ !! (x3 down) ! (x2 up)
+ !!
+ !!\endverbatim
+ !!
+ !! where theta is the strike and phi is the dip (internal convention),
+ !! and introducting the rotation matrices
+ !!
+ !!\verbatim
+ !!
+ !! | cos(theta) sin(theta) 0 |
+ !! R1 = | -sin(theta) cos(theta) 0 |
+ !! | 0 0 1 |
+ !!
+ !! | cos(phi) 0 sin(phi) |
+ !! R2 = | 0 1 0 |
+ !! | -sin(phi) 0 cos(phi) |
+ !!
+ !!\endverbatim
+ !!
+ !! a normal vector n of arbitrary orientation and the corresponding
+ !! strike-slip and dip-slip vector, s and d respectively, are
+ !!
+ !!\verbatim
+ !!
+ !! | 1 | | 0 | | 0 |
+ !! n = R1 R2 | 0 |, s = R1 R2 | 1 |, d = R1 R2 | 0 |
+ !! | 0 | | 0 | | 1 |
+ !!
+ !!\endverbatim
+ !!
+ !! vector n, s and d are orthogonal and the corresponding moment
+ !! density second order tensor is deviatoric. The method of images is
+ !! used to avoid tapering of the fault at the surface.
+ !!
+ !! \author sylvain barbot (03-02-08) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE momentdensityshear(mu,slip,x,y,z,L,W,strike,dip,rake, &
+ beta,sx1,sx2,sx3,dx1,dx2,dx3,sig)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: mu,slip,x,y,z,L,W,strike,dip,rake,&
+ beta,dx1,dx2,dx3
+ TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: sig
+
+ INTEGER :: i1,i2,i3
+ REAL*4 :: rmu
+ REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
+ cstrike,sstrike,cdip,sdip,cr,sr,x2r,&
+ aperture,temp1,temp2,temp3,xr,yr,zr,Wp,Lp,dum
+ REAL*8, DIMENSION(3) :: n,s
+ TYPE(TENSOR) :: Ei
+
+ rmu=2._4*REAL(mu,4)
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+ cr=cos(rake)
+ sr=sin(rake)
+
+ ! effective tapered dimensions
+ Wp=W*(1._8+2._8*beta)/2._8
+ Lp=L*(1._8+2._8*beta)/2._8
+
+ ! rotate centre coordinates of source and images
+ x2r= cstrike*x -sstrike*y
+ xr = cdip *x2r-sdip *z
+ yr = sstrike*x +cstrike*y
+ zr = sdip *x2r+cdip *z
+
+ DO i3=1,sx3
+ x3=DBLE(i3-1)*dx3
+ IF (abs(x3-z) .gt. Lp) CYCLE
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
+ dx1,dx2,dx3,x1,x2,dum)
+
+ IF ((abs(x1-x).gt.Wp) .or. (abs(x2-y).gt.Wp)) CYCLE
+
+ x2r= cstrike*x1-sstrike*x2
+ x1s= cdip*x2r-sdip*x3
+ x1i= cdip*x2r+sdip*x3
+ IF ((abs(x1s-xr).gt.7.01*dx1).and.(abs(x1i-xr).gt.7.01*dx1)) CYCLE
+ x2s= sstrike*x1+cstrike*x2
+ x3s= sdip*x2r+cdip*x3
+ x3i=-sdip*x2r+cdip*x3
+
+ ! integrate at depth and along strike with raised cosine taper
+ ! and shift sources to x,y,z coordinate
+ temp1=gauss(x1s-xr,dx1)
+ temp2=omega((x2s-yr)/W,beta)
+ temp3=omega((x3s-zr)/L,beta)
+ aperture=temp1*temp2*temp3
+
+ ! add image
+ temp1=gauss(x1i-xr,dx1)
+ temp3=omega((x3i+zr)/L,beta)
+ aperture=aperture+temp1*temp2*temp3
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike*aperture
+ n(2)=-cdip*sstrike*aperture
+ n(3)=-sdip*aperture
+
+ ! strike-slip component
+ s(1)=sstrike*cr
+ s(2)=cstrike*cr
+
+ ! dip-slip component
+ s(1)=s(1)+cstrike*sdip*sr
+ s(2)=s(2)-sstrike*sdip*sr
+ s(3)= +cdip*sr
+
+ ! eigenstrain (symmetric deviatoric second-order tensor)
+ Ei=n .sdyad. (slip*s)
+
+ ! moment density (pure shear)
+ sig(i1,i2,i3)=sig(i1,i2,i3) .plus. (rmu .times. Ei)
+
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE momentdensityshear
+
+ !---------------------------------------------------------------------
+ !> function MomentDensityTensile
+ !! computes the inelastic irreversible moment density in the space
+ !! domain corresponding to a buried dislocation with opening (open
+ !! crack). A fault along a surface of normal n_i with a burger vector
+ !! s_i, is associated with the eigenstrain
+ !!
+ !! \f[ E^i_{ij} = \frac{1}{2} ( n_i s_j + s_i n_j ) \f]
+ !!
+ !! The eigenstrain/potency tensor for a point source opening crack is
+ !!
+ !!\verbatim
+ !!
+ !! | 1 0 0 |
+ !! E^i = | 0 0 0 |
+ !! | 0 0 0 |
+ !!
+ !!\endverbatim
+ !!
+ !! In a heterogeneous medium of elastic moduli tensor C_ijkl, the
+ !! corresponding moment density tensor is
+ !!
+ !! \f[ m_{ij} = C_{ijkl} E^i_{kl} = \lambda E^i_{kk} \delta_{ij} + 2 \mu E^i_{ij} \f]
+ !!
+ !! where C = C(x) is a function of space. (We use isotropic elastic
+ !! solid, and heterogeneous elastic moduli tensor simplifies to
+ !! mu=mu(x) and lambda = lambda(x).) The moment density for a point
+ !! source opening crack is
+ !!
+ !!\verbatim
+ !!
+ !! | lambda+2*mu 0 0 |
+ !! m(x) = | 0 lambda 0 |
+ !! | 0 0 lambda |
+ !!
+ !!\endverbatim
+ !!
+ !! Moment density m(x) is integrated along the planar surface
+ !!
+ !! box(x2) delta (x1) box(x3)
+ !!
+ !! where box(x) and delta(x) are the boxcar and the dirac delta
+ !! functions, respectively. Equivalent body forces representing the
+ !! set of dislocations can be obtained by evaluating the divergence
+ !! of the moment density tensor
+ !!
+ !! \f[ f_i = - ( m_{ji} ),j \f]
+ !!
+ !! The corresponding equivalent surface traction is simply
+ !!
+ !! \f[ t_i = m_{ij} n_j \f]
+ !!
+ !! Both equivalent body forces and equivalent surface traction are
+ !! computed using the function "EquivalentBodyForce" in this module.
+ !!
+ !! The default dislocation extends in the x2 direction, with a normal
+ !! in the x1 direction. Using the following angular convention,
+ !!
+ !!\verbatim
+ !!
+ !! x1 ! x1
+ !! n theta | ! n phi |
+ !! \ ____| ! \ ____|
+ !! \ | ! \ |
+ !! \ | ! \ |
+ !! -----\+------ x2 ! -----\+------ x3
+ !! (x3 down) ! (x2 up)
+ !!
+ !!\endverbatim
+ !!
+ !! where theta is the strike and phi is the dip, in internal
+ !! convention. (Internal angular convention does not correspond to
+ !! usual angular convention of geology and conversion between the two
+ !! standard is necessary.) Introducting the rotation matrices,
+ !!
+ !!\verbatim
+ !!
+ !! | cos(theta) sin(theta) 0 |
+ !! R1 = | -sin(theta) cos(theta) 0 |
+ !! | 0 0 1 |
+ !!
+ !! | cos(phi) 0 sin(phi) |
+ !! R2 = | 0 1 0 |
+ !! | -sin(phi) 0 cos(phi) |
+ !!
+ !!\endverbatim
+ !!
+ !! a normal vector n of arbitrary orientation and the corresponding
+ !! slip vector s are
+ !!
+ !!\verbatim
+ !!
+ !! | 1 | | 1 |
+ !! n = R1 R2 | 0 |, s = n = R1 R2 | 0 |
+ !! | 0 | | 0 |
+ !!
+ !!\endverbatim
+ !!
+ !! The method of images is used to avoid tapering of the fault at
+ !! the surface.
+ !!
+ !! \author sylvain barbot (03-02-08) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE momentdensitytensile(lambda,mu,slip,x,y,z,L,W,strike,dip,rake, &
+ beta,sx1,sx2,sx3,dx1,dx2,dx3,sig)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: lambda,mu,slip,x,y,z,L,W,strike,dip,rake,&
+ beta,dx1,dx2,dx3
+ TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: sig
+
+ INTEGER :: i1,i2,i3
+ REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
+ cstrike,sstrike,cdip,sdip,cr,sr,x2r,&
+ aperture,temp1,temp2,temp3,xr,yr,zr,Wp,Lp,dum
+ REAL*8, DIMENSION(3) :: n
+ TYPE(TENSOR) :: Ei
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+ cr=cos(rake)
+ sr=sin(rake)
+
+ ! effective tapered dimensions
+ Wp=W*(1._8+2._8*beta)/2._8
+ Lp=L*(1._8+2._8*beta)/2._8
+
+ ! rotate centre coordinates of source and images
+ x2r= cstrike*x -sstrike*y
+ xr = cdip *x2r-sdip *z
+ yr = sstrike*x +cstrike*y
+ zr = sdip *x2r+cdip *z
+
+ DO i3=1,sx3
+ x3=DBLE(i3-1)*dx3
+ IF (abs(x3-z) .gt. Lp) CYCLE
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
+ dx1,dx2,dx3,x1,x2,dum)
+
+ IF ((abs(x1-x).gt.Wp) .or. (abs(x2-y).gt.Wp)) CYCLE
+
+ x2r= cstrike*x1-sstrike*x2
+ x1s= cdip*x2r-sdip*x3
+ x1i= cdip*x2r+sdip*x3
+ IF ((abs(x1s-xr).gt.7.01*dx1).and.(abs(x1i-xr).gt.7.01*dx1)) CYCLE
+ x2s= sstrike*x1+cstrike*x2
+ x3s= sdip*x2r+cdip*x3
+ x3i=-sdip*x2r+cdip*x3
+
+ ! integrate at depth and along strike with raised cosine taper
+ ! and shift sources to x,y,z coordinate
+ temp1=gauss(x1s-xr,dx1)
+ temp2=omega((x2s-yr)/W,beta)
+ temp3=omega((x3s-zr)/L,beta)
+ aperture=temp1*temp2*temp3
+
+ ! add image
+ temp1=gauss(x1i-xr,dx1)
+ temp3=omega((x3i+zr)/L,beta)
+ aperture=aperture+temp1*temp2*temp3
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike*aperture
+ n(2)=-cdip*sstrike*aperture
+ n(3)=-sdip*aperture
+
+ ! eigenstrain (symmetric second-order tensor)
+ Ei=n .sdyad. (slip*n)
+
+ ! moment density (isotropic Hooke's law)
+ CALL isotropicstressstrain(Ei,lambda,mu)
+ sig(i1,i2,i3)=sig(i1,i2,i3) .plus. Ei
+
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE momentdensitytensile
+
+ !---------------------------------------------------------------------
+ !! function MomentDensityMogi
+ !! computes the inelastic irreversible moment density in the space
+ !! domain corresponding to a buried Mogi source.
+ !! The Mogi source is associated with the eigenstrain
+ !!
+ !! \f[ E^i_{ij} = o \frac{1}{3} \delta_{ij} \f]
+ !!
+ !! In a heterogeneous medium of elastic moduli tensor C_ijkl, the
+ !! corresponding moment density tensor is
+ !!
+ !! \f[ m_{ij} = C_{ijkl} E^i_{kl} \f]
+ !!
+ !! where C = C(x) is a function of space. Equivalent body forces
+ !! representing the set of dislocations can be obtained by evaluating
+ !! the divergence of the moment density tensor
+ !!
+ !! \f[ f_i = - ( m_{ji} ),j \f]
+ !!
+ !! using the function "EquivalentBodyForce" in this module.
+ !!
+ !! \author sylvain barbot (03-24-09) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE momentdensitymogi(lambda,mu,o,xs,ys,zs,sx1,sx2,sx3,dx1,dx2,dx3,sig)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: lambda,mu,o,xs,ys,zs,dx1,dx2,dx3
+ TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: sig
+
+ INTEGER :: i1,i2,i3
+ REAL*8 :: x1,x2,x3,Wp,Lp,dum,kappa,gamma,gammai
+ TYPE(TENSOR) :: m
+
+ kappa=lambda+2._8/3._8*mu
+
+ ! effective tapered dimensions
+ Wp=6._8*MAX(dx1,dx2,dx3)
+ Lp=6._8*MAX(dx1,dx2,dx3)
+
+ DO i3=1,sx3
+ x3=DBLE(i3-1)*dx3
+ IF (abs(x3-zs) .gt. Lp) CYCLE
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
+ dx1,dx2,dx3,x1,x2,dum)
+
+ IF ((abs(x1-xs).gt.Wp) .or. (abs(x2-ys).gt.Wp)) CYCLE
+
+ ! amplitude of eigenstrain
+ gamma =o*gauss(x1-xs,dx1)*gauss(x2-ys,dx2)*gauss(x3-zs,dx3)
+
+ ! add image
+ gammai=o*gauss(x1-xs,dx1)*gauss(x2-ys,dx2)*gauss(x3+zs,dx3)
+
+ ! amplitude of moment density
+ gamma=kappa*gamma
+ gammai=kappa*gammai
+
+ ! eigenstrain (diagonal second-order tensor)
+ m=TENSOR(gamma,0,0,gamma,0,gamma)
+
+ ! moment density (pure shear)
+ sig(i1,i2,i3)=sig(i1,i2,i3) .plus. m
+
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE momentdensitymogi
+
+ !---------------------------------------------------------------------
+ !> function Plane
+ !! computes the three components, n1, n2 and n3, of the normal vector
+ !! corresponding to a rectangular surface of finite size. The plane
+ !! is defined by its orientation (strike and dip) and dimension.
+ !!
+ !!\verbatim
+ !!
+ !! W
+ !! +-------------+
+ !! | |
+ !! L | + | - - - > along strike direction
+ !! | (x,y,z) |
+ !! +-------------|
+ !! |
+ !! v
+ !! down-dip direction
+ !!
+ !!\endverbatim
+ !!
+ !! in the default orientation, for which strike=0 and dip=0, the plane
+ !! is vertical along the x2 axis, such as n2(x) = n3(x) = 0 for all x.
+ !! internal angular conventions are as follows:
+ !!
+ !!\verbatim
+ !!
+ !! n x1 n x1
+ !! \ | \ |
+ !! \ | \ |
+ !! 90 - strike \ | 90 - dip \ |
+ !! ( \| ( \|
+ !! ----------+------ x2 ----------+------ x3
+ !! (x3 down) (x2 up)
+ !!
+ !!\endverbatim
+ !!
+ !! edges of the rectangle are tapered.
+ !!
+ !! \author sylvain barbot (09-15-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE plane(x,y,z,L,W,strike,dip, &
+ beta,sx1,sx2,sx3,dx1,dx2,dx3,n1,n2,n3)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: x,y,z,L,W,strike,dip,beta,dx1,dx2,dx3
+#ifdef ALIGN_DATA
+ REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: n1,n2,n3
+#else
+ REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(INOUT) :: n1,n2,n3
+#endif
+
+ INTEGER :: i1,i2,i3
+ REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
+ cstrike,sstrike,cdip,sdip,x2r,&
+ temp1,temp2,temp3,sourc,image,xr,yr,zr,Wp,Lp,dum
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! effective tapered dimensions
+ Wp=W*(1._8+2._8*beta)/2._8
+ Lp=L*(1._8+2._8*beta)/2._8
+
+ ! rotate centre coordinates of source and images
+ x2r= cstrike*x -sstrike*y
+ xr = cdip *x2r-sdip *z
+ yr = sstrike*x +cstrike*y
+ zr = sdip *x2r+cdip *z
+
+ DO i3=1,sx3
+ x3=DBLE(i3-1)*dx3
+ IF ((abs(x3-z).gt.Lp) .and. (abs(x3+z).gt.Lp)) CYCLE
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
+ dx1,dx2,dx3,x1,x2,dum)
+ IF ((abs(x1-x).gt.Wp) .or. (abs(x2-y).gt.Wp)) CYCLE
+
+ x2r= cstrike*x1-sstrike*x2
+ x1s= cdip*x2r-sdip*x3
+ x1i= cdip*x2r+sdip*x3
+ IF ((abs(x1s-xr).gt.7.01*dx1).and.(abs(x1i-xr).gt.7.01*dx1)) CYCLE
+ x2s= sstrike*x1+cstrike*x2
+ x3s= sdip*x2r+cdip*x3
+ x3i=-sdip*x2r+cdip*x3
+
+ !integrate at depth and along strike with raised cosine taper
+ !and shift sources to x,y,z coordinate
+ temp1=gauss(x1s-xr,dx1)
+ temp2=omega((x2s-yr)/W,beta)
+ temp3=omega((x3s-zr)/L,beta)
+ sourc=temp1*temp2*temp3
+
+ temp1=gauss(x1i-xr,dx1)
+ temp3=omega((x3i+zr)/L,beta)
+ image=temp1*temp2*temp3
+
+ ! surface normal vector components
+ n1(i1,i2,i3)=n1(i1,i2,i3)+cdip*cstrike*(sourc+image)
+ n2(i1,i2,i3)=n2(i1,i2,i3)-cdip*sstrike*(sourc+image)
+ n3(i1,i2,i3)=n3(i1,i2,i3)-sdip*(sourc+image)
+
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE plane
+
+ !---------------------------------------------------------------------
+ !> function MonitorStressField
+ !! samples a stress field along a specified planar surface.
+ !!
+ !! \author sylvain barbot (10-16-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE monitorstressfield(x,y,z,L,W,strike,dip,beta, &
+ sx1,sx2,sx3,dx1,dx2,dx3,sig,patch)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: x,y,z,L,W,strike,dip,beta,dx1,dx2,dx3
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ TYPE(SLIPPATCH_STRUCT), ALLOCATABLE, DIMENSION(:,:), INTENT(OUT) :: patch
+
+ INTEGER :: px2,px3,j2,j3,status
+ REAL*8 :: x1,x2,x3,xr,yr,zr,Wp,Lp, &
+ cstrike,sstrike,cdip,sdip
+ TYPE(TENSOR) :: lsig
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! effective tapered dimensions
+ Wp=W*(1._8+2._8*beta) ! horizontal dimension for vertical fault
+ Lp=L*(1._8+2._8*beta) ! depth for a vertical fault
+
+ px3=fix(Lp/dx3)
+ px2=fix(Wp/dx2)
+
+ ALLOCATE(patch(px2+1,px3+1),STAT=status)
+ IF (status>0) STOP "could not allocate the slip patches for export"
+
+ DO j3=1,px3+1
+ DO j2=1,px2+1
+
+ CALL ref2local(x,y,z,xr,yr,zr)
+
+ ! no translation in out of plane direction
+ yr=REAL(yr)+REAL((DBLE(j2)-DBLE(px2)/2._8-1._8)*dx2)
+ zr=REAL(zr)+REAL((DBLE(j3)-DBLE(px3)/2._8-1._8)*dx3)
+
+ CALL local2ref(xr,yr,zr,x1,x2,x3)
+
+ ! discard out-of-bound locations
+ IF ( (x1 .gt. DBLE(sx1/2-1)*dx1) .or. (x1 .lt. -DBLE(sx1/2)*dx1) &
+ .or. (x2 .gt. DBLE(sx2/2-1)*dx2) .or. (x2 .lt. -DBLE(sx2/2)*dx2) &
+ .or. (x3 .gt. DBLE(sx3-1)*dx3) .or. (x3 .lt. 0._8) ) THEN
+ lsig=TENSOR(0._8,0._8,0._8,0._8,0._8,0._8)
+ ELSE
+ CALL sampletensor(x1,x2,x3,dx1,dx2,dx3,sx1,sx2,sx3,sig,lsig)
+ END IF
+
+ patch(j2,j3)=SLIPPATCH_STRUCT(x1,x2,x3,yr,zr, &
+ 0._8,0._8,0._8,0._8,0._8,0._8,0._8,lsig)
+
+ END DO
+ END DO
+
+ CONTAINS
+
+ !--------------------------------------------------------------
+ !> subroutine sample
+ !! interpolates the value of a discretized 3-dimensional field
+ !! at a subpixel location. method consists in correlating the
+ !! 3D field with a delta function filter. the delta function is
+ !! approximated with a narrow normalized gaussian.
+ !!
+ !! \author sylvain barbot (10-17-07) - original form
+ !--------------------------------------------------------------
+ SUBROUTINE sampletensor(x1,x2,x3,dx1,dx2,dx3,sx1,sx2,sx3,sig,lsig)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: x1,x2,x3,dx1,dx2,dx3
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ TYPE(TENSOR), INTENT(OUT) :: lsig
+
+ INTEGER :: i1,i2,i3,i,j,k,l1,l2,l3,i1p,i2p,i3p
+ INTEGER, PARAMETER :: RANGE=2
+ REAL*8 :: sum,weight,x,y,z
+ REAL*8, PARAMETER :: EPS=1e-2
+
+ sum=0._8
+ lsig=TENSOR(0._8,0._8,0._8,0._8,0._8,0._8)
+
+ ! closest sample
+ CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i,j,k)
+ ! rounded coordinates of closest sample
+ CALL shiftedcoordinates(i,j,k,sx1,sx2,2*sx3,dx1,dx2,dx3,x,y,z)
+
+ ! no interpolation for node points
+ IF ( (abs(x-x1) .lt. EPS*dx1) .and. &
+ (abs(y-x2) .lt. EPS*dx2) .and. &
+ (abs(z-x3) .lt. EPS*dx3) ) THEN
+ lsig=sig(i,j,k)
+ RETURN
+ END IF
+
+ DO l3=-RANGE,+RANGE
+ ! no periodicity in the 3-direction
+ IF ((k+l3 .le. 0) .or. (k+l3 .gt. sx3)) CYCLE
+
+ IF (l3 .ge. 0) THEN
+ i3p=mod(k-1+l3,sx3)+1
+ ELSE
+ i3p=mod(sx3+k-1+l3,sx3)+1
+ END IF
+
+ DO l2=-RANGE,+RANGE
+ IF (l2 .ge. 0) THEN
+ i2p=mod(j-1+l2,sx2)+1
+ ELSE
+ i2p=mod(sx2+j-1+l2,sx2)+1
+ END IF
+
+ DO l1=-RANGE,+RANGE
+ IF (l1 .ge. 0) THEN
+ i1p=mod(i-1+l1,sx1)+1
+ ELSE
+ i1p=mod(sx1+i-1+l1,sx1)+1
+ END IF
+
+ weight=sinc(((x+l1*dx1)-x1)/dx1)*dx1 &
+ *sinc(((y+l2*dx2)-x2)/dx2)*dx2 &
+ *sinc(((z+l3*dx3)-x3)/dx3)*dx3
+
+ !weight=gauss((x+l1*dx1)-x1,dx1)*dx1 &
+ ! *gauss((y+l2*dx2)-x2,dx2)*dx2 &
+ ! *gauss((z+l3*dx3)-x3,dx3)*dx3
+
+ lsig=lsig.plus.(REAL(weight).times.sig(i1p,i2p,i3p))
+ sum =sum +weight
+
+ END DO
+ END DO
+ END DO
+ IF (sum .gt. 1e-6) lsig=REAL(1._8/sum).times.lsig
+
+ END SUBROUTINE sampletensor
+
+ !-----------------------------------------------
+ ! subroutine ref2local
+ ! convert reference Cartesian coordinates into
+ ! the rotated, local fault coordinates system.
+ !-----------------------------------------------
+ SUBROUTINE ref2local(x,y,z,xp,yp,zp)
+ REAL*8, INTENT(IN) :: x,y,z
+ REAL*8, INTENT(OUT) :: xp,yp,zp
+
+ REAL*8 :: x2
+
+ x2 = cstrike*x -sstrike*y
+ xp = cdip *x2 -sdip *z
+ yp = sstrike*x +cstrike*y
+ zp = sdip *x2 +cdip *z
+
+ END SUBROUTINE ref2local
+
+ !-----------------------------------------------
+ ! subroutine local2ref
+ ! converts a set of coordinates from the rotated
+ ! fault-aligned coordinate system into the
+ ! reference, Cartesian coordinates system.
+ !-----------------------------------------------
+ SUBROUTINE local2ref(xp,yp,zp,x,y,z)
+ REAL*8, INTENT(IN) :: xp,yp,zp
+ REAL*8, INTENT(OUT) :: x,y,z
+
+ REAL*8 :: x2p
+
+ x2p= cdip*xp+sdip*zp
+ x = cstrike*x2p+sstrike*yp
+ y = -sstrike*x2p+cstrike*yp
+ z = -sdip*xp +cdip*zp
+
+ END SUBROUTINE local2ref
+
+ END SUBROUTINE monitorstressfield
+
+ !---------------------------------------------------------------------
+ !> function MonitorField
+ !! samples a scalar field along a specified planar surface.
+ !!
+ !! \author sylvain barbot (10-16-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE monitorfield(x,y,z,L,W,strike,dip,beta, &
+ sx1,sx2,sx3,dx1,dx2,dx3,slip,patch)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: x,y,z,L,W,strike,dip,beta,dx1,dx2,dx3
+#ifdef ALIGN_DATA
+ REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(IN) :: slip
+#else
+ REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(IN) :: slip
+#endif
+ TYPE(SLIPPATCH_STRUCT), ALLOCATABLE, DIMENSION(:,:), INTENT(OUT) :: patch
+
+ INTEGER :: px2,px3,j2,j3,status
+ REAL*8 :: x1,x2,x3,xr,yr,zr,Wp,Lp, &
+ cstrike,sstrike,cdip,sdip,value
+ TYPE(TENSOR) :: sig0
+
+ sig0=TENSOR(0._8,0._8,0._8,0._8,0._8,0._8)
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! effective tapered dimensions
+ Wp=W*(1._8+2._8*beta) ! horizontal dimension for vertical fault
+ Lp=L*(1._8+2._8*beta) ! depth for a vertical fault
+
+ px3=fix(Lp/dx3)
+ px2=fix(Wp/dx2)
+
+ ALLOCATE(patch(px2+1,px3+1),STAT=status)
+ IF (status>0) STOP "could not allocate the slip patches for export"
+
+ DO j3=1,px3+1
+ DO j2=1,px2+1
+
+ CALL ref2local(x,y,z,xr,yr,zr)
+
+ ! no translation in out of plane direction
+ yr=REAL(yr)+REAL((DBLE(j2)-DBLE(px2)/2._8-1._8)*dx2)
+ zr=REAL(zr)+REAL((DBLE(j3)-DBLE(px3)/2._8-1._8)*dx3)
+
+ CALL local2ref(xr,yr,zr,x1,x2,x3)
+
+ ! discard out-of-bound locations
+ IF ( (x1 .gt. DBLE(sx1/2-1)*dx1) .or. (x1 .lt. -DBLE(sx1/2)*dx1) &
+ .or. (x2 .gt. DBLE(sx2/2-1)*dx2) .or. (x2 .lt. -DBLE(sx2/2)*dx2) &
+ .or. (x3 .gt. DBLE(sx3-1)*dx3) .or. (x3 .lt. 0._8) ) THEN
+ value=0._8
+ ELSE
+ CALL sample(x1,x2,x3,dx1,dx2,dx3,sx1,sx2,sx3,slip,value)
+ END IF
+
+ patch(j2,j3)=SLIPPATCH_STRUCT(x1,x2,x3,yr,zr,value,0._8,0._8, &
+ 0._8,0._8,0._8,0._8,sig0)
+
+ END DO
+ END DO
+
+ CONTAINS
+
+ !--------------------------------------------------------------
+ !> subroutine sample
+ !! interpolates the value of a discretized 3-dimensional field
+ !! at a subpixel location. method consists in correlating the
+ !! 3D field with a delta function filter. the delta function is
+ !! approximated with a narrow normalized gaussian.
+ !!
+ !! \author sylvain barbot (10-17-07) - original form
+ !--------------------------------------------------------------
+ SUBROUTINE sample(x1,x2,x3,dx1,dx2,dx3,sx1,sx2,sx3,field,value)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: x1,x2,x3,dx1,dx2,dx3
+ REAL*8, INTENT(OUT) :: value
+#ifdef ALIGN_DATA
+ REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(IN) :: field
+#else
+ REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(IN) :: field
+#endif
+
+ INTEGER :: i1,i2,i3,i,j,k,l1,l2,l3,i1p,i2p,i3p
+ INTEGER, PARAMETER :: RANGE=2
+ REAL*8 :: sum,weight,x,y,z
+ REAL*8, PARAMETER :: EPS=1e-2
+
+ sum=0._8
+ value=0._8
+
+ ! closest sample
+ CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i,j,k)
+ ! rounded coordinates of closest sample
+ CALL shiftedcoordinates(i,j,k,sx1,sx2,2*sx3,dx1,dx2,dx3,x,y,z)
+
+ ! no interpolation for node points
+ IF ( (abs(x-x1) .lt. EPS*dx1) .and. &
+ (abs(y-x2) .lt. EPS*dx2) .and. &
+ (abs(z-x3) .lt. EPS*dx3) ) THEN
+ value=field(i,j,k)
+ RETURN
+ END IF
+
+ DO l3=-RANGE,+RANGE
+ ! no periodicity in the 3-direction
+ IF ((k+l3 .le. 0) .or. (k+l3 .gt. sx3)) CYCLE
+
+ IF (l3 .ge. 0) THEN
+ i3p=mod(k-1+l3,sx3)+1
+ ELSE
+ i3p=mod(sx3+k-1+l3,sx3)+1
+ END IF
+
+ DO l2=-RANGE,+RANGE
+ IF (l2 .ge. 0) THEN
+ i2p=mod(j-1+l2,sx2)+1
+ ELSE
+ i2p=mod(sx2+j-1+l2,sx2)+1
+ END IF
+
+ DO l1=-RANGE,+RANGE
+ IF (l1 .ge. 0) THEN
+ i1p=mod(i-1+l1,sx1)+1
+ ELSE
+ i1p=mod(sx1+i-1+l1,sx1)+1
+ END IF
+
+ weight=sinc(((x+l1*dx1)-x1)/dx1)*dx1 &
+ *sinc(((y+l2*dx2)-x2)/dx2)*dx2 &
+ *sinc(((z+l3*dx3)-x3)/dx3)*dx3
+
+ !weight=gauss((x+l1*dx1)-x1,dx1)*dx1 &
+ ! *gauss((y+l2*dx2)-x2,dx2)*dx2 &
+ ! *gauss((z+l3*dx3)-x3,dx3)*dx3
+
+ value=value+weight*field(i1p,i2p,i3p)
+ sum =sum +weight
+
+ END DO
+ END DO
+ END DO
+ IF (sum .gt. 1e-6) value=value/sum
+
+ END SUBROUTINE sample
+
+ !-----------------------------------------------
+ ! subroutine ref2local
+ ! convert reference Cartesian coordinates into
+ ! the rotated, local fault coordinates system.
+ !-----------------------------------------------
+ SUBROUTINE ref2local(x,y,z,xp,yp,zp)
+ REAL*8, INTENT(IN) :: x,y,z
+ REAL*8, INTENT(OUT) :: xp,yp,zp
+
+ REAL*8 :: x2
+
+ x2 = cstrike*x -sstrike*y
+ xp = cdip *x2 -sdip *z
+ yp = sstrike*x +cstrike*y
+ zp = sdip *x2 +cdip *z
+
+ END SUBROUTINE ref2local
+
+ !-----------------------------------------------
+ ! subroutine local2ref
+ ! converts a set of coordinates from the rotated
+ ! fault-aligned coordinate system into the
+ ! reference, Cartesian coordinates system.
+ !-----------------------------------------------
+ SUBROUTINE local2ref(xp,yp,zp,x,y,z)
+ REAL*8, INTENT(IN) :: xp,yp,zp
+ REAL*8, INTENT(OUT) :: x,y,z
+
+ REAL*8 :: x2p
+
+ x2p= cdip*xp+sdip*zp
+ x = cstrike*x2p+sstrike*yp
+ y = -sstrike*x2p+cstrike*yp
+ z = -sdip*xp +cdip*zp
+
+ END SUBROUTINE local2ref
+
+ END SUBROUTINE monitorfield
+
+ !-----------------------------------------------------------------
+ ! subroutine FieldAdd
+ ! computes in place the sum of two scalar fields
+ !
+ ! u = c1 * u + c2 * v
+ !
+ ! the function is useful to add fields of different sizes.
+ !
+ ! sylvain barbot (07/27/07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE fieldadd(u,v,sx1,sx2,sx3,c1,c2)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: u
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v
+ REAL*4, INTENT(IN), OPTIONAL :: c1,c2
+
+ IF (PRESENT(c1)) THEN
+ IF (PRESENT(c2)) THEN
+ u=c1*u+c2*v
+ ELSE
+ u=c1*u+v
+ END IF
+ ELSE
+ IF (PRESENT(c2)) THEN
+ u=u+c2*v
+ ELSE
+ u=u+v
+ END IF
+ END IF
+
+ END SUBROUTINE fieldadd
+
+ !-----------------------------------------------------------------
+ ! subroutine FieldRep
+ !
+ ! u = c1 * v
+ !
+ ! the function is useful to add fields of different sizes.
+ !
+ ! sylvain barbot (07/27/07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE fieldrep(u,v,sx1,sx2,sx3,c1)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: u
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v
+ REAL*4, INTENT(IN), OPTIONAL :: c1
+
+ IF (PRESENT(c1)) THEN
+ u=u+c1*v
+ ELSE
+ u=v
+ END IF
+
+ END SUBROUTINE fieldrep
+
+ !-----------------------------------------------------------------
+ ! subroutine SliveAdd
+ ! computes in place the sum of two scalar fields
+ !
+ ! u = c1 * u + c2 * v
+ !
+ ! the function is useful to add fields of different sizes.
+ !
+ ! sylvain barbot (10/24/08) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE sliceadd(u,v,sx1,sx2,sx3,index,c1,c2)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,index
+ REAL*4, INTENT(INOUT), DIMENSION(sx1,sx2) :: u
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: v
+ REAL*4, INTENT(IN), OPTIONAL :: c1,c2
+
+ IF (PRESENT(c1)) THEN
+ IF (PRESENT(c2)) THEN
+ u=c1*u+c2*v(:,:,index)
+ ELSE
+ u=c1*u+v(:,:,index)
+ END IF
+ ELSE
+ IF (PRESENT(c2)) THEN
+ u=u+c2*v(:,:,index)
+ ELSE
+ u=u+v(:,:,index)
+ END IF
+ END IF
+
+ END SUBROUTINE sliceadd
+
+ !-----------------------------------------------------------------
+ !> subroutine TensorFieldAdd
+ !! computes the linear combination of two tensor fields
+ !!
+ !! t1 = c1 * t1 + c2 * t2
+ !!
+ !! where t1 and t2 are two tensor fields and c1 and c2 are scalars.
+ !! only tensor field t1 is modified.
+ !
+ ! sylvain barbot (07/27/07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE tensorfieldadd(t1,t2,sx1,sx2,sx3,c1,c2)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: t1
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: t2
+ REAL*4, INTENT(IN), OPTIONAL :: c1,c2
+
+ INTEGER :: i1,i2,i3
+
+ IF (PRESENT(c1)) THEN
+ IF (PRESENT(c2)) THEN
+ IF (0._4 .eq. c1) THEN
+ IF (0._4 .eq. c2) THEN
+ DO 05 i3=1,sx3; DO 05 i2=1,sx2; DO 05 i1=1,sx1
+ t1(i1,i2,i3)=TENSOR(0._4,0._4,0._4,0._4,0._4,0._4)
+05 CONTINUE
+ ELSE
+ DO 10 i3=1,sx3; DO 10 i2=1,sx2; DO 10 i1=1,sx1
+ t1(i1,i2,i3)=c2 .times. t2(i1,i2,i3)
+10 CONTINUE
+ END IF
+ ELSE
+ DO 20 i3=1,sx3; DO 20 i2=1,sx2; DO 20 i1=1,sx1
+ t1(i1,i2,i3)=(c1 .times. t1(i1,i2,i3)) .plus. &
+ (c2 .times. t2(i1,i2,i3))
+20 CONTINUE
+ END IF
+ ELSE
+ DO 30 i3=1,sx3; DO 30 i2=1,sx2; DO 30 i1=1,sx1
+ t1(i1,i2,i3)=(c1 .times. t1(i1,i2,i3)) .plus. t2(i1,i2,i3)
+30 CONTINUE
+ END IF
+ ELSE
+ IF (PRESENT(c2)) THEN
+ DO 40 i3=1,sx3; DO 40 i2=1,sx2; DO 40 i1=1,sx1
+ t1(i1,i2,i3)=t1(i1,i2,i3) .plus. (c2 .times. t2(i1,i2,i3))
+40 CONTINUE
+ ELSE
+ DO 50 i3=1,sx3; DO 50 i2=1,sx2; DO 50 i1=1,sx1
+ t1(i1,i2,i3)=t2(i1,i2,i3) .plus. t2(i1,i2,i3)
+50 CONTINUE
+ END IF
+ END IF
+
+ END SUBROUTINE tensorfieldadd
+
+
+ !-----------------------------------------------------------------
+ ! subroutine TensorIntegrate
+ ! computes a numercial integration with numerical viscosity
+ !
+ ! T^(n+1)_i = (T^n_(i-1)+T^n_(i+1))/2 + dt * S^n_i
+ !
+ ! instead of
+ !
+ ! T^(n+1)_i = T^n_i + dt * S^n_i
+ !
+ ! implementation is just generalized for a 3-dimensional field.
+ !
+ ! sylvain barbot (07/27/07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE tensorintegrate(T,S,sx1,sx2,sx3,dt)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: T
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: S
+ REAL*8, INTENT(IN) :: dt
+
+ INTEGER :: i1,i2,i3,i1m,i2m,i3m,i1p,i2p,i3p
+
+ DO i3=1,sx3
+ i3m=mod(sx3+i3-2,sx3)+1
+ i3p=mod(i3,sx3)+1
+ DO i2=1,sx2
+ i2m=mod(sx2+i2-2,sx2)+1
+ i2p=mod(i2,sx2)+1
+ DO i1=1,sx1
+ i1m=mod(sx1+i1-2,sx1)+1
+ i1p=mod(i1,sx1)+1
+
+ T(i1,i2,i3)=( &
+ (1._4/6._4) .times. (T(i1m,i2,i3) .plus. T(i1p,i2,i3) &
+ .plus. T(i1,i2m,i3) .plus. T(i1,i2p,i3) &
+ .plus. T(i1,i2,i3m) .plus. T(i1,i2,i3p))) &
+ .plus. &
+ (REAL(dt) .times. S(i1,i2,i3))
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE tensorintegrate
+
+ !---------------------------------------------------------------------
+ !> subroutine coordinates computes the xi coordinates from the
+ !! array index and sampling interval
+ !---------------------------------------------------------------------
+ SUBROUTINE coordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
+ INTEGER, INTENT(IN) :: i1,i2,i3,sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ REAL*8, INTENT(OUT) :: x1,x2,x3
+
+ x1=DBLE(i1-sx1/2-1)*dx1
+ x2=DBLE(i2-sx2/2-1)*dx2
+ x3=DBLE(i3-sx3/2-1)*dx3
+ END SUBROUTINE coordinates
+
+ !---------------------------------------------------------------------
+ !> subroutine ShiftedCoordinates
+ !! computes the xi coordinates from the array index and sampling
+ !! interval assuming data is order like fftshift.
+ !!
+ !! \author sylvain barbot (07/31/07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,x1,x2,x3)
+ INTEGER, INTENT(IN) :: i1,i2,i3,sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ REAL*8, INTENT(OUT) :: x1,x2,x3
+
+ IF (i1 .LE. sx1/2) THEN
+ x1=DBLE(i1-1)*dx1
+ ELSE
+ x1=DBLE(i1-sx1-1)*dx1
+ END IF
+ IF (i2 .LE. sx2/2) THEN
+ x2=DBLE(i2-1)*dx2
+ ELSE
+ x2=DBLE(i2-sx2-1)*dx2
+ END IF
+ IF (i3 .LE. sx3/2) THEN
+ x3=DBLE(i3-1)*dx3
+ ELSE
+ x3=DBLE(i3-sx3-1)*dx3
+ END IF
+
+ END SUBROUTINE shiftedcoordinates
+
+ !----------------------------------------------------------------------
+ !> subroutine ShiftedIndex
+ !! returns the integer index corresponding to the specified coordinates
+ !! assuming the data are ordered following fftshift. input coordinates
+ !! are assumed bounded -sx/2 <= x <= sx/2-1. out of bound input
+ !! purposefully triggers a fatal error. in the x3 direction, coordinates
+ !! are assumed bounded by 0 <= x3 <= (sx3-1)*dx3
+ !!
+ !! CALLED BY:
+ !! monitorfield/sample
+ !!
+ !! \author sylvain barbot (07/31/07) - original form
+ !----------------------------------------------------------------------
+ SUBROUTINE shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
+ REAL*8, INTENT(IN) :: x1,x2,x3,dx1,dx2,dx3
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ INTEGER, INTENT(OUT) :: i1,i2,i3
+
+ IF (x1 .gt. DBLE(sx1/2-1)*dx1) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("x1=",ES9.2E2,"; boundary at x1=",ES9.2E2)') x1, DBLE(sx1/2)*dx1
+ STOP "ShiftedIndex:invalid x1 coordinates (x1 too large)"
+ END IF
+ IF (x1 .lt. -DBLE(sx1/2)*dx1 ) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("x1=",ES9.2E2,"; boundary at x1=",ES9.2E2)') x1, -DBLE(sx1/2)*dx1
+ STOP "ShiftedIndex:coordinates out of range (-x1 too large)"
+ END IF
+ IF (x2 .gt. DBLE(sx2/2-1)*dx2) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("x2=",ES9.2E2,"; boundary at x2=",ES9.2E2)') x2, DBLE(sx2/2)*dx2
+ STOP "ShiftedIndex:invalid x2 coordinates (x2 too large)"
+ END IF
+ IF (x2 .lt. -DBLE(sx2/2)*dx2 ) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("x2=",ES9.2E2,"; boundary at x2=",ES9.2E2)') x2, -DBLE(sx2/2)*dx2
+ STOP "ShiftedIndex:coordinates out of range (-x2 too large)"
+ END IF
+ IF (x3 .gt. DBLE(sx3-1)*dx3) THEN
+ WRITE_DEBUG_INFO
+ STOP "ShiftedIndex:invalid x3 coordinates (x3 too large)"
+ END IF
+ IF (x3 .lt. 0 ) THEN
+ WRITE (0,'("x3=",ES9.2E2)') x3
+ STOP "ShiftedIndex:coordinates out of range (x3 negative)"
+ END IF
+
+ i1=MOD(sx1+fix(x1/dx1),sx1)+1
+ i2=MOD(sx2+fix(x2/dx2),sx2)+1
+ i3=fix(x3/dx3)+1
+
+ END SUBROUTINE shiftedindex
+
+ !-----------------------------------------------------------------
+ ! subroutine ExportSlice
+ ! computes the value of a scalar field at a horizontal plane.
+ ! the field if shifted such as the (0,0) coordinate is in the
+ ! middle of the array at (sx1/2+1,sx2/2+1).
+ !
+ ! sylvain barbot (07/09/07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE exportslice(field,odepth,dx1,dx2,dx3,s)
+ REAL*4, INTENT(IN), DIMENSION(:,:,:) :: field
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3,odepth
+ REAL*4, INTENT(OUT), DIMENSION(:,:) :: s
+
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3
+ REAL*8 :: k3
+ COMPLEX*8, PARAMETER :: i=CMPLX(0._8,pi2)
+ COMPLEX*8 :: sum,exp3
+ REAL*4 :: exp1,exp2
+
+ sx1=SIZE(field,1)-2
+ sx2=SIZE(field,2)
+ sx3=SIZE(field,3)
+
+ s=0
+ DO i3=1,sx3
+ CALL wavenumber3(i3,sx3,dx3,k3)
+ exp3=exp(i*k3*odepth)
+ DO i2=1,sx2
+ DO i1=1,sx1/2+1
+ sum=CMPLX(field(2*i1-1,i2,i3),field(2*i1,i2,i3))*exp3
+ s(2*i1-1:2*i1,i2)=s(2*i1-1:2*i1,i2)+(/REAL(sum),AIMAG(sum)/)
+ END DO
+ END DO
+ END DO
+ s=s/(sx3*dx3)
+
+ !fftshift
+ DO i2=1,sx2
+ IF (i2 < sx2/2+1) THEN
+ exp2= (i2-1._4)
+ ELSE
+ exp2=-(sx2-i2+1._4)
+ END IF
+ DO i1=1,sx1/2+1
+ exp1=i1-1._4
+ sum=CMPLX(s(2*i1-1,i2),s(2*i1,i2))*((-1._4)**(exp1+exp2))
+ s(2*i1-1:2*i1,i2)=(/REAL(sum),AIMAG(sum)/)
+ END DO
+ END DO
+ CALL fft2(s,sx1,sx2,dx1,dx2,FFT_INVERSE)
+
+ END SUBROUTINE exportslice
+
+ !-----------------------------------------------------------------
+ !> subroutine ExportSpatial
+ !! transfer a horizontal layer from array 'data' to smaller array
+ !! 'p' and shift center position so that coordinates (0,0) are in
+ !! center of array 'p'. optional parameter 'doflip' generates
+ !! output compatible with grd binary format.
+ !
+ ! sylvain barbot (07/09/07) - original form
+ ! (03/19/08) - compatibility with grd output
+ !-----------------------------------------------------------------
+ SUBROUTINE exportspatial(data,sx1,sx2,p,doflip)
+ INTEGER, INTENT(IN) :: sx1,sx2
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2) :: data
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2) :: data
+#endif
+ REAL*4, INTENT(OUT), DIMENSION(:,:) :: p
+ LOGICAL, INTENT(IN), OPTIONAL :: doflip
+
+ INTEGER :: i1,i2,i1s,i2s
+ LOGICAL :: flip
+
+ IF (PRESENT(doflip)) THEN
+ flip=doflip
+ ELSE
+ flip=.false.
+ END IF
+
+ DO i2=1,sx2
+ IF (i2 .LE. sx2/2) THEN
+ i2s=sx2/2+i2
+ ELSE
+ i2s=i2-sx2/2
+ END IF
+ DO i1=1,sx1
+ IF (i1 .LE. sx1/2) THEN
+ i1s=sx1/2+i1
+ ELSE
+ i1s=i1-sx1/2
+ END IF
+
+ IF (flip) THEN
+ p(i2s,sx1-i1s+1)=data(i1,i2)
+ ELSE
+ p(i1s,i2s)=data(i1,i2)
+ END IF
+
+ END DO
+ END DO
+
+ END SUBROUTINE exportspatial
+
+END MODULE elastic3d
diff -r 405d8f4fa05f -r e7295294f654 src/export.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/export.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,2478 @@
+!-----------------------------------------------------------------------
+! Copyright 2007, 2008, 2009 Sylvain Barbot
+!
+! This file is part of RELAX
+!
+! RELAX 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 3 of the License, or
+! (at your option) any later version.
+!
+! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
+!-----------------------------------------------------------------------
+
+#include "include.f90"
+
+MODULE export
+
+ USE elastic3d
+ USE viscoelastic3d
+ USE friction3d
+
+ IMPLICIT NONE
+
+ PRIVATE xyzwrite
+ PRIVATE geoxyzwrite
+
+CONTAINS
+
+ !-------------------------------------------------------------------
+ ! routine ReportTime
+ ! writes the times of exports
+ !
+ ! sylvain barbot (04/29/09) - original form
+ !-------------------------------------------------------------------
+ SUBROUTINE reporttime(i,t,repfile)
+ INTEGER, INTENT(IN) :: i
+ CHARACTER(80), INTENT(IN) :: repfile
+ REAL*8, INTENT(IN) :: t
+
+ INTEGER :: iostatus
+
+ IF (0 .eq. i) THEN
+ OPEN (UNIT=15,FILE=repfile,IOSTAT=iostatus,FORM="FORMATTED")
+ ELSE
+ OPEN (UNIT=15,FILE=repfile,POSITION="APPEND",&
+ IOSTAT=iostatus,FORM="FORMATTED")
+ END IF
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', repfile
+ STOP "could not open file for export"
+ END IF
+
+ WRITE (15,'(ES11.3E2)') t
+
+ CLOSE(15)
+
+ END SUBROUTINE reporttime
+
+ SUBROUTINE report(i,t,file1,file2,file3,sx1,sx2,repfile)
+ INTEGER, INTENT(IN) :: i,sx1,sx2
+ CHARACTER(80), INTENT(IN) :: file1,file2,file3,repfile
+ REAL*8, INTENT(IN) :: t
+
+ INTEGER :: iostatus, ind1,ind2,ind3
+
+ IF (0 .eq. i) THEN
+ OPEN (UNIT=15,FILE=repfile,IOSTAT=iostatus,FORM="FORMATTED")
+ ELSE
+ OPEN (UNIT=15,FILE=repfile,POSITION="APPEND",&
+ IOSTAT=iostatus,FORM="FORMATTED")
+ END IF
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', repfile
+ STOP "could not open file for export"
+ END IF
+
+ ind1=INDEX(file1," ")
+ ind2=INDEX(file2," ")
+ ind3=INDEX(file3," ")
+ WRITE (15,'(I3.3,2I6," ",f13.4," ",a," ",a," ",a)') i,sx1,sx2,t,&
+ file1(1:ind1-1),file2(1:ind2-1),file3(1:ind3-1)
+
+ CLOSE(15)
+
+ END SUBROUTINE report
+
+ SUBROUTINE export2d(data,sx1,sx2,filename)
+ INTEGER, INTENT(IN) :: sx1,sx2
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2) :: data
+ CHARACTER(80), INTENT(IN) :: filename
+
+ INTEGER :: iostatus,i1,i2
+ CHARACTER(15) :: form
+ CHARACTER(5) :: digit
+
+ WRITE (digit,'(I5.5)') sx1
+ form="("//digit//"ES11.3E2)"
+
+ OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ STOP "could not open file for export"
+ END IF
+
+ WRITE (15,form) ((data(i1,i2), i1=1,sx1), i2=1,sx2)
+ CLOSE(15)
+
+ END SUBROUTINE export2d
+
+ !------------------------------------------------------------------
+ ! subroutine geoxyzwrite
+ !
+ ! sylvain barbot (22/05/10) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE geoxyzwrite(x,y,z,sx1,sx2,filename)
+ INTEGER, INTENT(IN) :: sx1,sx2
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2) :: z
+ REAL*8, INTENT(IN), DIMENSION(sx1,sx2) :: x,y
+ CHARACTER(80), INTENT(IN) :: filename
+
+ INTEGER :: iostatus,i1,i2
+
+ OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) STOP "could not open file for proj export"
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ WRITE (15,'(ES15.8E1,ES15.8E1,ES11.3E2)'), &
+ x(i1,i2),y(i1,i2),z(i1,i2)
+ END DO
+ END DO
+ CLOSE(15)
+
+ END SUBROUTINE geoxyzwrite
+
+ !------------------------------------------------------------------
+ ! subroutine xyzwrite
+ !
+ ! sylvain barbot (06/10/09) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE xyzwrite(data,sx1,sx2,dx1,dx2,filename)
+ INTEGER, INTENT(IN) :: sx1,sx2
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2) :: data
+ CHARACTER(80), INTENT(IN) :: filename
+ REAL*8 :: dx1,dx2
+
+ INTEGER :: iostatus,i1,i2
+
+ OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) STOP "could not open file for export"
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ !x1=(mod(sx1/2+i1-1,sx1)-sx1/2)*dx1
+ !x2=(mod(sx2/2+i2-1,sx2)-sx2/2)*dx2
+ WRITE (15,'(ES11.3E2,ES11.3E2,ES11.3E2)'), &
+ DBLE(i2-1-sx2/2)*dx2,DBLE(i1-1-sx1/2)*dx1,data(i1,i2)
+ END DO
+ END DO
+ CLOSE(15)
+
+ END SUBROUTINE xyzwrite
+
+#ifdef PROJ
+ !------------------------------------------------------------------
+ !> subroutine ExportStressPROJ
+ !! export a map view of stress with coordinates in
+ !! longitude/latitude. Text format output is the GMT-compatible
+ !! .xyz file format where data in each file is organized as follows
+ !!
+ !! longitude latitude s11
+ !! longitude latitude s12
+ !! longitude latitude s13
+ !! longitude latitude s22
+ !! longitude latitude s23
+ !! longitude latitude s33
+ !!
+ !! this is an interface to exportproj.
+ !!
+ !! \author sylvain barbot (05/22/10) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportstressproj(sig,sx1,sx2,sx3,dx1,dx2,dx3,oz, &
+ x0,y0,lon0,lat0,zone,scale,wdir,index)
+ INTEGER, INTENT(IN) :: index,sx1,sx2,sx3,zone
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ REAL*8, INTENT(IN) :: oz,dx1,dx2,dx3,x0,y0,lon0,lat0,scale
+ CHARACTER(80), INTENT(IN) :: wdir
+
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: t1,t2,t3
+ INTEGER :: iostatus,i,j,k,l
+
+ ALLOCATE(t1(sx1+2,sx2),t2(sx1+2,sx2),t3(sx1+2,sx2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory for grid export"
+
+ k=fix(oz/dx3)+1
+ DO j=1,sx2
+ DO i=1,sx1
+#ifdef ALIGN_DATA
+ l=(j-1)*(sx1+2)+i
+#else
+ l=(j-1)*sx1+i
+#endif
+ t1(l,1)=sig(i,j,k)%s11
+ t2(l,1)=sig(i,j,k)%s12
+ t3(l,1)=sig(i,j,k)%s13
+ END DO
+ END DO
+
+ CALL exportproj(t1,t2,t3,sx1,sx2,1,dx1,dx2,dx3,0._8, &
+ x0,y0,lon0,lat0,zone,scale,wdir,index,convention=4)
+
+ DO j=1,sx2
+ DO i=1,sx1
+#ifdef ALIGN_DATA
+ l=(j-1)*(sx1+2)+i
+#else
+ l=(j-1)*sx1+i
+#endif
+ t1(l,1)=sig(i,j,k)%s22
+ t2(l,1)=sig(i,j,k)%s23
+ t3(l,1)=sig(i,j,k)%s33
+ END DO
+ END DO
+
+ CALL exportproj(t1,t2,t3,sx1,sx2,1,dx1,dx2,dx3,0._8, &
+ x0,y0,lon0,lat0,zone,scale,wdir,index,convention=5)
+
+ DEALLOCATE(t1,t2,t3)
+
+ END SUBROUTINE exportstressproj
+
+ !------------------------------------------------------------------
+ !> subroutine ExportPROJ
+ !! export a map view of displacements with coordinates in
+ !! longitude/latitude. Text format output is the GMT-compatible
+ !! .xyz file format where data in each file is organized as follows
+ !!
+ !! longitude latitude u1,
+ !! longitude latitude u2 and
+ !! longitude latitude -u3
+ !!
+ !! for index-geo-north.xyz,
+ !! index-geo-east.xyz and
+ !! index-geo-up.xyz, respectively.
+ !!
+ !! \author sylvain barbot (05/22/10) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportproj(c1,c2,c3,sx1,sx2,sx3,dx1,dx2,dx3,oz, &
+ x0,y0,lon0,lat0,zone,scale,wdir,i,convention)
+ INTEGER, INTENT(IN) :: i,sx1,sx2,sx3,zone
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
+#endif
+ REAL*8, INTENT(IN) :: oz,dx1,dx2,dx3,x0,y0,lon0,lat0,scale
+ CHARACTER(80), INTENT(IN) :: wdir
+ INTEGER, INTENT(IN), OPTIONAL :: convention
+
+ INTEGER :: iostatus,i1,i2,pos,conv
+ CHARACTER(3) :: digit
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: t1,t2,t3
+ REAL*8, DIMENSION(:,:), ALLOCATABLE :: x,y
+ CHARACTER(80) :: file1,file2,file3
+ REAL*8 :: lon1,lat1
+
+ IF (PRESENT(convention)) THEN
+ conv=convention
+ ELSE
+ conv=1
+ END IF
+
+ lon1=lon0
+ lat1=lat0
+
+ ALLOCATE(t1(sx1,sx2),t2(sx1,sx2),t3(sx1,sx2), &
+ x(sx1,sx2),y(sx1,sx2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory for export"
+
+ CALL exportspatial(c1(:,:,int(oz/dx3)+1),sx1,sx2,t1)
+ CALL exportspatial(c2(:,:,int(oz/dx3)+1),sx1,sx2,t2)
+ CALL exportspatial(c3(:,:,int(oz/dx3)+1),sx1,sx2,t3)
+ t3=-t3
+
+ ! grid coordinates (x=easting, y=northing)
+ DO i2=1,sx2
+ DO i1=1,sx1
+ y(i1,i2)=(i1-sx1/2)*(dx1*scale)+x0
+ x(i1,i2)=(i2-sx2/2)*(dx2*scale)+y0
+ END DO
+ END DO
+ CALL proj(x,y,sx1*sx2,lon1,lat1,zone)
+
+ pos=INDEX(wdir," ")
+ WRITE (digit,'(I3.3)') i
+ SELECT CASE(conv)
+ CASE (1) ! cumulative displacement
+ file1=wdir(1:pos-1) // "/" // digit // "-geo-north.xyz"
+ file2=wdir(1:pos-1) // "/" // digit // "-geo-east.xyz"
+ file3=wdir(1:pos-1) // "/" // digit // "-geo-up.xyz"
+ CASE (2) ! postseismic displacement
+ file1=wdir(1:pos-1) // "/" // digit // "-relax-geo-north.xyz"
+ file2=wdir(1:pos-1) // "/" // digit // "-relax-geo-east.xyz"
+ file3=wdir(1:pos-1) // "/" // digit // "-relax-geo-up.xyz"
+ CASE (3) ! equivalent body forces
+ file1=wdir(1:pos-1) // "/" // digit // "-eqbf-geo-north.xyz"
+ file2=wdir(1:pos-1) // "/" // digit // "-eqbf-geo-east.xyz"
+ file3=wdir(1:pos-1) // "/" // digit // "-eqbf-geo-up.xyz"
+ CASE (4) ! equivalent body forces
+ file1=wdir(1:pos-1) // "/" // digit // "-geo-s11.xyz"
+ file2=wdir(1:pos-1) // "/" // digit // "-geo-s12.xyz"
+ file3=wdir(1:pos-1) // "/" // digit // "-geo-s13.xyz"
+ CASE (5) ! equivalent body forces
+ file1=wdir(1:pos-1) // "/" // digit // "-geo-s22.xyz"
+ file2=wdir(1:pos-1) // "/" // digit // "-geo-s23.xyz"
+ file3=wdir(1:pos-1) // "/" // digit // "-geo-s33.xyz"
+ END SELECT
+
+ CALL geoxyzwrite(x,y,t1,sx1,sx2,file1)
+ CALL geoxyzwrite(x,y,t2,sx1,sx2,file2)
+ CALL geoxyzwrite(x,y,t3,sx1,sx2,file3)
+
+ DEALLOCATE(t1,t2,t3)
+
+ END SUBROUTINE exportproj
+#endif
+
+#ifdef XYZ
+ !------------------------------------------------------------------
+ !> subroutine ExportXYZ
+ !! export a map view of surface displacement into the GMT-compatible
+ !! .xyz file format where data in each file is organized as follows
+ !!
+ !! x1 x2 u1, x1 x2 u2 and x1 x2 -u3
+ !!
+ !! for index-north.xyz, index-east.xyz and index-up.xyz,
+ !! respectively.
+ !!
+ !! \author sylvain barbot (06/10/09) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportxyz(c1,c2,c3,sx1,sx2,sx3,oz,dx1,dx2,dx3,i,wdir)
+ INTEGER, INTENT(IN) :: i,sx1,sx2,sx3
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
+#endif
+ REAL*8, INTENT(IN) :: oz,dx1,dx2,dx3
+ CHARACTER(80), INTENT(IN) :: wdir
+
+ INTEGER :: iostatus,pos
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: temp1,temp2,temp3
+ CHARACTER(80) :: file1,file2,file3
+ CHARACTER(3) :: digit
+
+ ALLOCATE(temp1(sx1,sx2),temp2(sx1,sx2),temp3(sx1,sx2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory for export"
+
+ CALL exportspatial(c1(:,:,int(oz/dx3)+1),sx1,sx2,temp1)
+ CALL exportspatial(c2(:,:,int(oz/dx3)+1),sx1,sx2,temp2)
+ CALL exportspatial(c3(:,:,int(oz/dx3)+1),sx1,sx2,temp3)
+ temp3=-temp3
+
+ pos=INDEX(wdir," ")
+ WRITE (digit,'(I3.3)') i
+ file1=wdir(1:pos-1) // "/" // digit // "-north.xyz"
+ file2=wdir(1:pos-1) // "/" // digit // "-east.xyz"
+ file3=wdir(1:pos-1) // "/" // digit // "-up.xyz"
+
+ CALL xyzwrite(temp1,sx1,sx2,dx1,dx2,file1)
+ CALL xyzwrite(temp2,sx1,sx2,dx1,dx2,file2)
+ CALL xyzwrite(temp3,sx1,sx2,dx1,dx2,file3)
+
+ DEALLOCATE(temp1,temp2,temp3)
+
+ END SUBROUTINE exportxyz
+#endif
+
+#ifdef TXT
+ !------------------------------------------------------------------
+ ! subroutine ExportTXT
+ ! exports a horizontal slice of uniform depth into specified text
+ ! files and adds filenames in the report file.
+ ! if i is set to 0, the report file is reinitiated.
+ ! input data c1,c2,c3 are in the space domain.
+ !------------------------------------------------------------------
+ SUBROUTINE exporttxt(c1,c2,c3,sx1,sx2,sx3,oz,dx3,i,time,wdir,reportfilename)
+ INTEGER, INTENT(IN) :: i,sx1,sx2,sx3
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
+#endif
+ REAL*8, INTENT(IN) :: oz,dx3,time
+ CHARACTER(80), INTENT(IN) :: wdir,reportfilename
+
+ INTEGER :: iostatus,pos
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: temp1,temp2,temp3
+ CHARACTER(3) :: digit
+ CHARACTER(80) :: file1,file2,file3
+
+ ALLOCATE(temp1(sx1,sx2),temp2(sx1,sx2),temp3(sx1,sx2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory for export"
+
+ CALL exportspatial(c1(:,:,int(oz/dx3)+1),sx1,sx2,temp1)
+ CALL exportspatial(c2(:,:,int(oz/dx3)+1),sx1,sx2,temp2)
+ CALL exportspatial(c3(:,:,int(oz/dx3)+1),sx1,sx2,temp3)
+
+ pos=INDEX(wdir," ")
+ WRITE (digit,'(I3.3)') i
+ file1=wdir(1:pos-1) // "/" // digit // "-u1.txt"
+ file2=wdir(1:pos-1) // "/" // digit // "-u2.txt"
+ file3=wdir(1:pos-1) // "/" // digit // "-u3.txt"
+
+ CALL export2d(temp1,sx1,sx2,file1)
+ CALL export2d(temp2,sx1,sx2,file2)
+ CALL export2d(temp3,sx1,sx2,file3)
+
+ file1=digit // "-u1.txt "
+ file2=digit // "-u2.txt "
+ file3=digit // "-u3.txt "
+ CALL report(i,time,file1,file2,file3,sx1,sx2,reportfilename)
+
+ DEALLOCATE(temp1,temp2,temp3)
+
+ END SUBROUTINE exporttxt
+#endif
+
+ !------------------------------------------------------------------
+ !> subroutine exportpoints
+ !! sample a vector field at a series of points for export.
+ !! each location is attributed a file in which the time evolution
+ !! of the vector value is listed in the format:
+ !!
+ !! t_0 u(t_0) v(t_0) w(t_0)
+ !! t_1 u(t_1) v(t_1) w(t_1)
+ !! ...
+ !!
+ !! \author sylvain barbot (11/10/07) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportpoints(c1,c2,c3,sig,sx1,sx2,sx3,dx1,dx2,dx3, &
+ opts,ptsname,time,wdir,isnew,x0,y0,rot)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
+#endif
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ TYPE(VECTOR_STRUCT), INTENT(IN), DIMENSION(:) :: opts
+ CHARACTER(LEN=4), INTENT(IN), DIMENSION(:) :: ptsname
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3,time,x0,y0,rot
+ CHARACTER(80), INTENT(IN) :: wdir
+ LOGICAL, INTENT(IN) :: isnew
+
+ INTEGER :: i1,i2,i3,n,k
+ REAL*8 :: u1,u2,u3,v1,v2,v3,x1,x2,x3,y1,y2,y3
+ TYPE(TENSOR) :: lsig
+ INTEGER :: i,iostatus
+ CHARACTER(80) :: file1,file2
+
+ i=INDEX(wdir," ")
+ n=SIZE(ptsname)
+
+ DO k=1,n
+ file1=wdir(1:i-1) // "/" // ptsname(k) // ".txt"
+ file2=wdir(1:i-1) // "/" // ptsname(k) // ".c.txt"
+
+ IF (isnew) THEN
+ OPEN (UNIT=15,FILE=file1,IOSTAT=iostatus,FORM="FORMATTED")
+ WRITE (15,'("# t u1 u2 u3 ", &
+ "s11 s12 s13 s22 s23 s33")')
+ OPEN (UNIT=16,FILE=file2,IOSTAT=iostatus,FORM="FORMATTED")
+ ELSE
+ OPEN (UNIT=15,FILE=file1,POSITION="APPEND",&
+ IOSTAT=iostatus,FORM="FORMATTED")
+ OPEN (UNIT=16,FILE=file2,POSITION="APPEND",&
+ IOSTAT=iostatus,FORM="FORMATTED")
+ END IF
+ IF (iostatus>0) STOP "could not open point file for writing"
+
+ x1=opts(k)%v1
+ x2=opts(k)%v2
+ x3=opts(k)%v3
+
+ CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
+
+ u1=c1(i1,i2,i3)
+ u2=c2(i1,i2,i3)
+ u3=c3(i1,i2,i3)
+ lsig=sig(i1,i2,i3)
+
+ ! change from computational reference frame to user reference system
+ y1=x1;v1=u1
+ y2=x2;v2=u2
+ y3=x3;v3=u3
+
+ CALL rotation(y1,y2,-rot)
+ y1=y1+x0
+ y2=y2+y0
+ CALL rotation(v1,v2,-rot)
+
+ x1=x1+x0
+ x2=x2+y0
+
+ WRITE (15,'(13ES11.3E2)') time,v1,v2,v3, &
+ lsig%s11,lsig%s12,lsig%s13, &
+ lsig%s22,lsig%s23,lsig%s33
+ WRITE (16,'(7ES11.3E2)') x1,x2,x3,time,u1,u2,u3
+
+ CLOSE(15)
+ CLOSE(16)
+ END DO
+
+ CONTAINS
+
+ !------------------------------------------------------------------
+ ! subroutine Rotation
+ ! rotates a point coordinate into the computational reference
+ ! system.
+ !
+ ! sylvain barbot (04/16/09) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE rotation(x,y,rot)
+ REAL*8, INTENT(INOUT) :: x,y
+ REAL*8, INTENT(IN) :: rot
+
+ REAL*8 :: alpha,xx,yy
+ REAL*8, PARAMETER :: DEG2RAD = 0.01745329251994329547437168059786927_8
+
+
+ alpha=rot*DEG2RAD
+ xx=x
+ yy=y
+
+ x=+xx*cos(alpha)+yy*sin(alpha)
+ y=-xx*sin(alpha)+yy*cos(alpha)
+
+ END SUBROUTINE rotation
+
+ END SUBROUTINE exportpoints
+
+ !---------------------------------------------------------------------
+ !> subroutine exportoptsdat
+ !! export the coordinates and name of the observation points (often
+ !! coordinates of GPS instruments or such) for display with GMT in the
+ !! ASCII format. The file contains a list of x1,x2,x3 coordinates and
+ !! a 4-character name string.
+ !!
+ !! input variables
+ !! @param n - number of observation points
+ !! @param opts - coordinates of observation points
+ !! @param ptsname - name of obs. points
+ !! @param filename - output file (example: wdir/opts.xy)
+ !!
+ !! \author sylvain barbot (08/10/11) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE exportoptsdat(n,opts,ptsname,filename)
+ INTEGER, INTENT(IN) :: n
+ TYPE(VECTOR_STRUCT), DIMENSION(n) :: opts
+ CHARACTER(LEN=4), DIMENSION(n) :: ptsname
+ CHARACTER(80) :: filename
+
+ INTEGER :: k,iostatus
+
+ IF (n.LE.0) RETURN
+
+ OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) STOP "could not open .xy file to export observation points"
+ DO k=1,n
+ WRITE (15,'(3ES11.4E1,X,a)') opts(k)%v1,opts(k)%v2,opts(k)%v3,ptsname(k)
+ END DO
+ CLOSE(15)
+
+ END SUBROUTINE exportoptsdat
+
+ !---------------------------------------------------------------------
+ !> subroutine exportPlaneStress
+ !! samples the value of an input tensor field at the location of
+ !! defined plane (position, strike, dip, length and width).
+ !!
+ !! input variables
+ !! @param sig - sampled tensor array
+ !! @param nop - number of observation planes
+ !! @param op - structure of observation planes (position, orientation)
+ !! @param x0, y0 - origin position of coordinate system
+ !! @param dx1,2,3 - sampling size
+ !! @param sx1,2,3 - size of the scalar field
+ !! @param wdir - output directory for writing
+ !! @param i - loop index to suffix file names
+ !!
+ !! creates files
+ !!
+ !! wdir/index.s00001.estrain.txt with TXT_EXPORTEIGENSTRAIN option
+ !!
+ !! wdir/index.s00001.estrain.grd with GRD_EXPORTEIGENSTRAIN option
+ !!
+ !! \author sylvain barbot (01/01/07) - original form
+ ! (02/25/10) - output in TXT and GRD formats
+ !---------------------------------------------------------------------
+ SUBROUTINE exportplanestress(sig,nop,op,x0,y0,dx1,dx2,dx3,sx1,sx2,sx3,wdir,i)
+ INTEGER, INTENT(IN) :: nop,sx1,sx2,sx3,i
+ TYPE(PLANE_STRUCT), INTENT(IN), DIMENSION(nop) :: op
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ REAL*8, INTENT(IN) :: x0,y0,dx1,dx2,dx3
+ CHARACTER(80), INTENT(IN) :: wdir
+
+ INTEGER :: k,ns1,ns2
+ TYPE(SLIPPATCH_STRUCT), DIMENSION(:,:), ALLOCATABLE :: slippatch
+ CHARACTER(3) :: sdigit
+ CHARACTER(3) :: digit
+#ifdef TXT_EXPORTEIGENSTRAIN
+ INTEGER :: iostatus,i1,i2
+ CHARACTER(80) :: outfiletxt
+#endif
+!#_indef GRD_EXPORTEIGENSTRAIN
+ CHARACTER(80) :: fn11,fn12,fn13,fn22,fn23,fn33
+ INTEGER :: j,iostat,j1,j2
+ REAL*4, ALLOCATABLE, DIMENSION(:,:) :: temp11,temp12,temp13, &
+ temp22,temp23,temp33
+ REAL*8 :: rland=9998.,rdum=9999.
+ REAL*8 :: xmin,ymin
+ CHARACTER(80) :: title="monitor tensor field "
+!#_endif
+
+ IF (nop .le. 0) RETURN
+
+ WRITE (digit,'(I3.3)') i
+
+ DO k=1,nop
+ CALL monitorstressfield(op(k)%x,op(k)%y,op(k)%z, &
+ op(k)%width,op(k)%length,op(k)%strike,op(k)%dip, &
+ 0._8,sx1,sx2,sx3,dx1,dx2,dx3,sig,slippatch)
+
+ IF (.NOT. ALLOCATED(slippatch)) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("could not monitor slip")')
+ STOP 2
+ END IF
+
+ ns1=SIZE(slippatch,1)
+ ns2=SIZE(slippatch,2)
+
+ slippatch(:,:)%x1=slippatch(:,:)%x1+x0
+ slippatch(:,:)%x2=slippatch(:,:)%x2+y0
+
+ WRITE (sdigit,'(I3.3)') k
+
+!#_ifdef GRD_EXPORTEIGENSTRAIN
+ fn11=trim(wdir)//"/"//digit//".op"//sdigit//"-s11.grd"
+ fn12=trim(wdir)//"/"//digit//".op"//sdigit//"-s12.grd"
+ fn13=trim(wdir)//"/"//digit//".op"//sdigit//"-s13.grd"
+ fn22=trim(wdir)//"/"//digit//".op"//sdigit//"-s22.grd"
+ fn23=trim(wdir)//"/"//digit//".op"//sdigit//"-s23.grd"
+ fn33=trim(wdir)//"/"//digit//".op"//sdigit//"-s33.grd"
+
+ ! convert to c standard
+ j=INDEX(fn11," ")
+ fn11(j:j)=char(0)
+ fn12(j:j)=char(0)
+ fn13(j:j)=char(0)
+ fn22(j:j)=char(0)
+ fn23(j:j)=char(0)
+ fn33(j:j)=char(0)
+
+ ALLOCATE(temp11(ns1,ns2),temp12(ns1,ns2),temp13(ns1,ns2), &
+ temp22(ns1,ns2),temp23(ns1,ns2),temp33(ns1,ns2),STAT=iostat)
+ IF (iostatus>0) STOP "could not allocate temporary array for GRD slip export."
+
+ DO j2=1,ns2
+ DO j1=1,ns1
+ temp11(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s11
+ temp12(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s12
+ temp13(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s13
+ temp22(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s22
+ temp23(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s23
+ temp33(ns1+1-j1,j2)=slippatch(j1,j2)%sig%s33
+ END DO
+ END DO
+
+ ! xmin is the lowest coordinates (positive eastward in GMT)
+ xmin= MINVAL(slippatch(:,:)%lx)
+ ! ymin is the lowest coordinates (positive northward in GMT)
+ ymin=-MAXVAL(slippatch(:,:)%lz)
+
+ ! call the c function "writegrd_"
+ CALL writegrd(temp11,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn11)
+ CALL writegrd(temp12,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn12)
+ CALL writegrd(temp13,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn13)
+ CALL writegrd(temp22,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn22)
+ CALL writegrd(temp23,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn23)
+ CALL writegrd(temp33,ns1,ns2,ymin,xmin,dx3,dx2,rland,rdum,title,fn33)
+
+ DEALLOCATE(temp11,temp12,temp13,temp22,temp23,temp33)
+
+!#_endif
+
+ DEALLOCATE(slippatch)
+ END DO
+
+END SUBROUTINE exportplanestress
+
+ !---------------------------------------------------------------------
+ !> subroutine exportEigenstrain
+ !! samples the value of an input scalar field at the location of
+ !! defined plane (position, strike, dip, length and width).
+ !!
+ !! input variables
+ !! @param field - sampled scalar array
+ !! @param nop - number of observation planes
+ !! @param op - structure of observation planes (position, orientation)
+ !! @param x0, y0 - origin position of coordinate system
+ !! @param dx1,2,3 - sampling size
+ !! @param sx1,2,3 - size of the scalar field
+ !! @param wdir - output directory for writing
+ !! @param i - loop index to suffix file names
+ !!
+ !! creates files
+ !!
+ !! wdir/index.s00001.estrain.txt with TXT_EXPORTEIGENSTRAIN option
+ !!
+ !! wdir/index.s00001.estrain.grd with GRD_EXPORTEIGENSTRAIN option
+ !!
+ !! \author sylvain barbot (01/01/07) - original form
+ ! (02/25/10) - output in TXT and GRD formats
+ !---------------------------------------------------------------------
+ SUBROUTINE exporteigenstrain(field,nop,op,x0,y0,dx1,dx2,dx3,sx1,sx2,sx3,wdir,i)
+ INTEGER, INTENT(IN) :: nop,sx1,sx2,sx3,i
+ TYPE(PLANE_STRUCT), INTENT(IN), DIMENSION(nop) :: op
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: field
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: field
+#endif
+ REAL*8, INTENT(IN) :: x0,y0,dx1,dx2,dx3
+ CHARACTER(80), INTENT(IN) :: wdir
+
+ INTEGER :: k,ns1,ns2,pos
+ TYPE(SLIPPATCH_STRUCT), DIMENSION(:,:), ALLOCATABLE :: slippatch
+ CHARACTER(5) :: sdigit
+ CHARACTER(3) :: digit
+#ifdef TXT_EXPORTEIGENSTRAIN
+ INTEGER :: iostatus,i1,i2
+ CHARACTER(80) :: outfiletxt
+#endif
+!#_indef GRD_EXPORTEIGENSTRAIN
+ CHARACTER(80) :: outfilegrd
+ INTEGER :: j,iostat,j1,j2
+ REAL*4, ALLOCATABLE, DIMENSION(:,:) :: temp
+ REAL*8 :: rland=9998.,rdum=9999.
+ REAL*8 :: xmin,ymin
+ CHARACTER(80) :: title="monitor field "
+!#_endif
+
+ IF (nop .le. 0) RETURN
+
+ pos=INDEX(wdir," ")
+ WRITE (digit,'(I3.3)') i
+
+ DO k=1,nop
+ CALL monitorfield(op(k)%x,op(k)%y,op(k)%z, &
+ op(k)%width,op(k)%length,op(k)%strike,op(k)%dip, &
+ 0._8,sx1,sx2,sx3,dx1,dx2,dx3,field,slippatch)
+
+ IF (.NOT. ALLOCATED(slippatch)) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("could not monitor slip")')
+ STOP 2
+ END IF
+
+ ns1=SIZE(slippatch,1)
+ ns2=SIZE(slippatch,2)
+
+ slippatch(:,:)%x1=slippatch(:,:)%x1+x0
+ slippatch(:,:)%x2=slippatch(:,:)%x2+y0
+
+ WRITE (sdigit,'(I5.5)') k
+#ifdef TXT_EXPORTEIGENSTRAIN
+ outfiletxt=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".estrain.txt"
+
+ OPEN (UNIT=15,FILE=outfiletxt,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) STOP "could not open file for export"
+
+ WRITE (15,'(6ES11.3E2)') ((slippatch(i1,i2), i1=1,ns1), i2=1,ns2)
+
+ CLOSE(15)
+#endif
+
+!#_ifdef GRD_EXPORTEIGENSTRAIN
+ outfilegrd=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".estrain.grd"
+
+ ! convert to c standard
+ j=INDEX(outfilegrd," ")
+ outfilegrd(j:j)=char(0)
+
+ ALLOCATE(temp(ns1,ns2),STAT=iostat)
+ IF (iostatus>0) STOP "could not allocate temporary array for GRD slip export."
+
+ DO j2=1,ns2
+ DO j1=1,ns1
+ temp(ns1+1-j1,j2)=slippatch(j1,j2)%slip
+ END DO
+ END DO
+
+ ! xmin is the lowest coordinates (positive eastward in GMT)
+ xmin= MINVAL(slippatch(:,:)%lx)
+ ! ymin is the lowest coordinates (positive northward in GMT)
+ ymin=-MAXVAL(slippatch(:,:)%lz)
+
+ ! call the c function "writegrd_"
+ CALL writegrd(temp,ns1,ns2,ymin,xmin,dx3,dx2, &
+ rland,rdum,title,outfilegrd)
+
+ DEALLOCATE(temp)
+
+!#_endif
+
+ DEALLOCATE(slippatch)
+ END DO
+
+END SUBROUTINE exporteigenstrain
+
+ !---------------------------------------------------------------------
+ !> subroutine exportCreep
+ !! evaluates the value of creep velocity at the location of
+ !! defined plane (position, strike, dip, length and width).
+ !!
+ !! input variables
+ !! @param np - number of frictional planes
+ !! @param n - array of frictional planes (position, orientation)
+ !! @param structure - array of depth-dependent frictional properties
+ !! @param x0, y0 - origin position of coordinate system
+ !! @param dx1,2,3 - sampling size
+ !! @param sx1,2,3 - size of the stress tensor field
+ !! @param beta - smoothing factor controlling the extent of planes
+ !! @param wdir - output directory for writing
+ !! @param i - loop index to suffix file names
+ !!
+ !! creates files
+ !!
+ !! wdir/index.s00001.creep.txt
+ !!
+ !! containing
+ !!
+ !! x,y,z,x',y',sqrt(vx'^2+vy'^2),vx',vy'
+ !!
+ !! with TXT_EXPORTCREEP option and
+ !!
+ !! wdir/index.s00001.creep-north.grd
+ !! wdir/index.s00001.creep-east.grd
+ !! wdir/index.s00001.creep-up.grd
+ !!
+ !! with GRD_EXPORTCREEP option where the suffix -north stands for
+ !! dip slip, -east for strike slip and -up for amplitude of slip.
+ !!
+ !! file wdir/index.s00001.creep.txt is subsampled by a factor "skip"
+ !! compared to the grd files.
+ !!
+ !! \author sylvain barbot (01/01/07) - original form
+ !! (02/25/10) - output in TXT and GRD formats
+ !---------------------------------------------------------------------
+#define TXT_EXPORTCREEP
+ SUBROUTINE exportcreep(np,n,beta,sig,structure, &
+ sx1,sx2,sx3,dx1,dx2,dx3,x0,y0,wdir,i)
+ INTEGER, INTENT(IN) :: np,sx1,sx2,sx3,i
+ TYPE(PLANE_STRUCT), INTENT(INOUT), DIMENSION(np) :: n
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
+ REAL*8, INTENT(IN) :: x0,y0,dx1,dx2,dx3,beta
+ CHARACTER(80), INTENT(IN) :: wdir
+
+ INTEGER :: k,ns1,ns2,pos
+ CHARACTER(5) :: sdigit
+ CHARACTER(3) :: digit
+#ifdef TXT_EXPORTCREEP
+ CHARACTER(80) :: outfile
+ INTEGER :: skip=3
+#endif
+#ifdef GRD_EXPORTCREEP
+ INTEGER :: j,iostatus,i1,i2
+ REAL*4, ALLOCATABLE, DIMENSION(:,:) :: temp1,temp2,temp3
+ REAL*8 :: rland=9998.,rdum=9999.
+ REAL*8 :: xmin,ymin
+ CHARACTER(80) :: title="monitor field "
+ CHARACTER(80) :: file1,file2,file3
+#endif
+
+ IF (np .le. 0) RETURN
+
+ pos=INDEX(wdir," ")
+ WRITE (digit,'(I3.3)') i
+
+ DO k=1,np
+ CALL monitorfriction(n(k)%x,n(k)%y,n(k)%z, &
+ n(k)%width,n(k)%length,n(k)%strike,n(k)%dip,n(k)%rake,beta, &
+ sx1,sx2,sx3,dx1,dx2,dx3,sig,structure,n(k)%patch)
+
+ ns1=SIZE(n(k)%patch,1)
+ ns2=SIZE(n(k)%patch,2)
+
+ !patch(:,:)%x1=patch(:,:)%x1+x0
+ !patch(:,:)%x2=patch(:,:)%x2+y0
+
+ WRITE (sdigit,'(I5.5)') k
+#ifdef TXT_EXPORTCREEP
+ outfile=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".creep.txt"
+
+ OPEN (UNIT=15,FILE=outfile,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) STOP "could not open file for export"
+
+ WRITE (15,'("# x1 x2 x3 yr yz", &
+ " slip strike-slip dip-slip")')
+ WRITE (15,'(8ES11.3E2)') ((n(k)%patch(i1,i2), i1=1,ns1,skip), i2=1,ns2,skip)
+
+ CLOSE(15)
+#endif
+
+#ifdef GRD_EXPORTCREEP
+ file1=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".creep-north.grd"
+ file2=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".creep-east.grd"
+ file3=wdir(1:pos-1)//"/"//digit//".s"//sdigit//".creep-up.grd"
+
+ ! convert to c standard
+ j=INDEX(file1," ")
+ file1(j:j)=char(0)
+ j=INDEX(file2," ")
+ file2(j:j)=char(0)
+ j=INDEX(file3," ")
+ file3(j:j)=char(0)
+
+ ALLOCATE(temp1(ns1,ns2),temp2(ns1,ns2),temp3(ns1,ns2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate temporary arrays for GRD slip export."
+
+ DO i2=1,ns2
+ DO i1=1,ns1
+ temp1(ns1+1-i1,i2)=n(k)%patch(i1,i2)%ds
+ temp2(ns1+1-i1,i2)=n(k)%patch(i1,i2)%ss
+ temp3(ns1+1-i1,i2)=n(k)%patch(i1,i2)%slip
+ END DO
+ END DO
+
+ ! xmin is the lowest coordinates (positive eastward in GMT)
+ xmin= MINVAL(n(k)%patch(:,:)%lx)
+ ! ymin is the lowest coordinates (positive northward in GMT)
+ ymin=-MAXVAL(n(k)%patch(:,:)%lz)
+
+ ! call the c function "writegrd_"
+ CALL writegrd(temp1,ns1,ns2,ymin,xmin,dx3,dx2, &
+ rland,rdum,title,file1)
+ CALL writegrd(temp2,ns1,ns2,ymin,xmin,dx3,dx2, &
+ rland,rdum,title,file2)
+ CALL writegrd(temp3,ns1,ns2,ymin,xmin,dx3,dx2, &
+ rland,rdum,title,file3)
+
+ DEALLOCATE(temp1,temp2,temp3)
+
+#endif
+
+ END DO
+
+END SUBROUTINE exportcreep
+
+#ifdef GRD
+ !------------------------------------------------------------------
+ !> subroutine ExportStressGRD
+ !! writes the 6 components of deformation in map view in the GMT
+ !! (Generic Mapping Tools) GRD binary format. This is an interface
+ !! to exportgrd.
+ !!
+ !! \author sylvain barbot 03/19/08 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportstressgrd(sig,sx1,sx2,sx3,dx1,dx2,dx3, &
+ oz,origx,origy,wdir,index)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,index
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3,origx,origy,oz
+ CHARACTER(80), INTENT(IN) :: wdir
+
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: t1,t2,t3
+ INTEGER :: iostatus,i,j,k,l
+
+ ALLOCATE(t1(sx1+2,sx2),t2(sx1+2,sx2),t3(sx1+2,sx2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory for grid export"
+
+ k=fix(oz/dx3)+1
+ DO j=1,sx2
+ DO i=1,sx1
+#ifdef ALIGN_DATA
+ l=(j-1)*(sx1+2)+i
+#else
+ l=(j-1)*sx1+i
+#endif
+ t1(l,1)=sig(i,j,k)%s11
+ t2(l,1)=sig(i,j,k)%s12
+ t3(l,1)=sig(i,j,k)%s13
+ END DO
+ END DO
+
+ CALL exportgrd(t1,t2,t3,sx1,sx2,1, &
+ dx1,dx2,dx3,0._8,origx,origy,wdir,index,convention=4)
+
+ DO j=1,sx2
+ DO i=1,sx1
+#ifdef ALIGN_DATA
+ l=(j-1)*(sx1+2)+i
+#else
+ l=(j-1)*sx1+i
+#endif
+ t1(l,1)=sig(i,j,k)%s22
+ t2(l,1)=sig(i,j,k)%s23
+ t3(l,1)=sig(i,j,k)%s33
+ END DO
+ END DO
+
+ CALL exportgrd(t1,t2,t3,sx1,sx2,1, &
+ dx1,dx2,dx3,0._8,origx,origy,wdir,index,convention=5)
+
+ DEALLOCATE(t1,t2,t3)
+
+ END SUBROUTINE exportstressgrd
+
+
+ !------------------------------------------------------------------
+ !> subroutine ExportGRD
+ !! writes the 3 components of deformation in map view in the GMT
+ !! (Generic Mapping Tools) GRD binary format.
+ !!
+ !! \author sylvain barbot 03/19/08 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportgrd(c1,c2,c3,sx1,sx2,sx3,dx1,dx2,dx3,oz,origx,origy,&
+ wdir,i,convention)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,i
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: c1,c2,c3
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: c1,c2,c3
+#endif
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3,origx,origy,oz
+ CHARACTER(80), INTENT(IN) :: wdir
+ INTEGER, INTENT(IN), OPTIONAL :: convention
+
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: temp1,temp2,temp3
+ REAL*8 :: rland=9998.,rdum=9999.
+ INTEGER :: iostatus,k,pos,conv
+ REAL*8 :: xmin,ymin
+ CHARACTER(80) :: file1,file2,file3
+ CHARACTER(3) :: digit
+
+ IF (PRESENT(convention)) THEN
+ conv=convention
+ ELSE
+ conv=1
+ END IF
+
+ ALLOCATE(temp1(sx2,sx1),temp2(sx2,sx1),temp3(sx2,sx1),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory for grid export"
+
+ CALL exportspatial(c1(:,:,int(oz/dx3)+1),sx1,sx2,temp1,doflip=.true.)
+ CALL exportspatial(c2(:,:,int(oz/dx3)+1),sx1,sx2,temp2,doflip=.true.)
+ CALL exportspatial(c3(:,:,int(oz/dx3)+1),sx1,sx2,temp3,doflip=.true.)
+
+ ! positive up
+ temp3=-temp3
+
+ pos=INDEX(wdir," ")
+ WRITE (digit,'(I3.3)') i
+
+ SELECT CASE(conv)
+ CASE (1) ! cumulative displacement
+ file1=wdir(1:pos-1) // "/" // digit // "-north.grd"
+ file2=wdir(1:pos-1) // "/" // digit // "-east.grd"
+ file3=wdir(1:pos-1) // "/" // digit // "-up.grd"
+ CASE (2) ! postseismic displacement
+ file1=wdir(1:pos-1) // "/" // digit // "-relax-north.grd"
+ file2=wdir(1:pos-1) // "/" // digit // "-relax-east.grd"
+ file3=wdir(1:pos-1) // "/" // digit // "-relax-up.grd"
+ CASE (3) ! equivalent body forces
+ file1=wdir(1:pos-1) // "/" // digit // "-eqbf-north.grd"
+ file2=wdir(1:pos-1) // "/" // digit // "-eqbf-east.grd"
+ file3=wdir(1:pos-1) // "/" // digit // "-eqbf-up.grd"
+ CASE (4) ! equivalent body forces
+ file1=wdir(1:pos-1) // "/" // digit // "-s11.grd"
+ file2=wdir(1:pos-1) // "/" // digit // "-s12.grd"
+ file3=wdir(1:pos-1) // "/" // digit // "-s13.grd"
+ CASE (5) ! equivalent body forces
+ file1=wdir(1:pos-1) // "/" // digit // "-s22.grd"
+ file2=wdir(1:pos-1) // "/" // digit // "-s23.grd"
+ file3=wdir(1:pos-1) // "/" // digit // "-s33.grd"
+ END SELECT
+
+ ! convert to c standard
+ k=INDEX(file1," ")
+ file1(k:k)=char(0)
+ k=INDEX(file2," ")
+ file2(k:k)=char(0)
+ k=INDEX(file3," ")
+ file3(k:k)=char(0)
+
+ ! xmin is the lowest coordinates (positive eastward)
+ xmin=origy-sx2/2*dx2
+ ! ymin is the lowest coordinates (positive northward)
+ ymin=origx-sx1/2*dx1
+
+ ! call the c function "writegrd_"
+ CALL writegrd(temp1,sx2,sx1,ymin,xmin,dx1,dx2, &
+ rland,rdum,file1,file1)
+ CALL writegrd(temp2,sx2,sx1,ymin,xmin,dx1,dx2, &
+ rland,rdum,file2,file2)
+ CALL writegrd(temp3,sx2,sx1,ymin,xmin,dx1,dx2, &
+ rland,rdum,file3,file3)
+
+ DEALLOCATE(temp1,temp2,temp3)
+
+ END SUBROUTINE exportgrd
+#endif
+
+#ifdef VTK
+ !------------------------------------------------------------------
+ !> subroutine ExportVTK_Grid
+ !! creates a .vtp file (in the VTK PolyData XML format) containing
+ !! the dimension of the computational grid
+ !!
+ !! \author sylvain barbot 06/24/09 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportvtk_grid(sx1,sx2,sx3,dx1,dx2,dx3,cgfilename)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ CHARACTER(80), INTENT(IN) :: cgfilename
+
+ INTEGER :: iostatus
+ CHARACTER :: q
+
+ q=char(34)
+
+ OPEN (UNIT=15,FILE=cgfilename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', cgfilename
+ STOP "could not open file for export"
+ END IF
+
+ WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
+ WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
+ WRITE (15,'(" <PolyData>")')
+ WRITE (15,'(" <Piece NumberOfPoints=",a,"8",a," NumberOfPolys=",a,"6",a,">")'),q,q,q,q
+ WRITE (15,'(" <Points>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Comp. Grid",a, &
+ " NumberOfComponents=",a,"3",a, &
+ " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
+ WRITE (15,'(24ES9.2E1)') &
+ -sx1*dx1/2, -sx2*dx2/2, sx3*dx3/2, &
+ +sx1*dx1/2, -sx2*dx2/2, sx3*dx3/2, &
+ +sx1*dx1/2, +sx2*dx2/2, sx3*dx3/2, &
+ -sx1*dx1/2, +sx2*dx2/2, sx3*dx3/2, &
+ -sx1*dx1/2, -sx2*dx2/2, 0.0, &
+ +sx1*dx1/2, -sx2*dx2/2, 0.0, &
+ +sx1*dx1/2, +sx2*dx2/2, 0.0, &
+ -sx1*dx1/2, +sx2*dx2/2, 0.0
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Points>")')
+ WRITE (15,'(" <Polys>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"connectivity",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"0",a, &
+ " RangeMax=",a,"7",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'("0 1 2 3 4 5 6 7 2 3 7 6 0 3 7 4 0 1 5 4 1 2 6 5")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"offsets",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"4",a, &
+ " RangeMax=",a,"24",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'(" 4 8 12 16 20 24")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Polys>")')
+ WRITE (15,'(" </Piece>")')
+ WRITE (15,'(" </PolyData>")')
+ WRITE (15,'("</VTKFile>")')
+
+ CLOSE(15)
+
+ END SUBROUTINE exportvtk_grid
+
+ !------------------------------------------------------------------
+ !> subroutine ExportXY_RFaults
+ !! creates a .xy file (in the GMT closed-polygon format) containing
+ !! the rectangular faults. Each fault segemnt is described by a
+ !! closed polygon (rectangle) associated with a slip amplitude.
+ !! use pxzy with the -Cpalette.cpt -L -M options to color rectangles
+ !! by slip.
+ !!
+ !! \author sylvain barbot 03/05/11 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportxy_rfaults(e,x0,y0,rffilename)
+ TYPE(EVENT_STRUC), INTENT(IN) :: e
+ REAL*8, INTENT(IN) :: x0, y0
+ CHARACTER(80), INTENT(IN) :: rffilename
+
+ INTEGER :: iostatus,k
+ CHARACTER :: q
+
+ REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W,slip
+
+ REAL*8, DIMENSION(3) :: s,d
+
+ ! double-quote character
+ q=char(34)
+
+ OPEN (UNIT=15,FILE=rffilename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', rffilename
+ STOP "could not open file for export"
+ END IF
+
+ WRITE (15,'("> # east, north")')
+ DO k=1,e%ns
+
+ ! fault slip
+ slip=e%s(k)%slip
+
+ ! fault orientation
+ strike=e%s(k)%strike
+ dip=e%s(k)%dip
+
+ ! fault center position
+ x1=e%s(k)%x+x0
+ x2=e%s(k)%y+y0
+ x3=e%s(k)%z
+
+ ! fault dimension
+ W=e%s(k)%width
+ L=e%s(k)%length
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! strike-slip unit direction
+ s(1)=sstrike
+ s(2)=cstrike
+ s(3)=0._8
+
+ ! dip-slip unit direction
+ d(1)=+cstrike*sdip
+ d(2)=-sstrike*sdip
+ d(3)=+cdip
+
+ ! fault edge coordinates - export east (x2) and north (x1)
+ WRITE (15,'("> -Z",3ES11.2)') ABS(slip)
+ WRITE (15,'(3ES11.2)') x2-d(2)*W/2-s(2)*L/2, x1-d(1)*W/2-s(1)*L/2
+ WRITE (15,'(3ES11.2)') x2-d(2)*W/2+s(2)*L/2, x1-d(1)*W/2+s(1)*L/2
+ WRITE (15,'(3ES11.2)') x2+d(2)*W/2+s(2)*L/2, x1+d(1)*W/2+s(1)*L/2
+ WRITE (15,'(3ES11.2)') x2+d(2)*W/2-s(2)*L/2, x1+d(1)*W/2-s(1)*L/2
+
+ END DO
+
+ CLOSE(15)
+
+ END SUBROUTINE exportxy_rfaults
+
+ !------------------------------------------------------------------
+ !> subroutine ExportVTK_RFaults
+ !! creates a .vtp file (in the VTK PolyData XML format) containing
+ !! the rectangular faults. The faults are characterized with a set
+ !! of subsegments (rectangles) each associated with a slip vector.
+ !!
+ !! \author sylvain barbot 06/24/09 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportvtk_rfaults(e,rffilename)
+ TYPE(EVENT_STRUC), INTENT(IN) :: e
+ CHARACTER(80), INTENT(IN) :: rffilename
+
+ INTEGER :: iostatus,k
+ CHARACTER :: q
+
+ REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W,slip
+
+ REAL*8, DIMENSION(3) :: s,d
+
+ ! double-quote character
+ q=char(34)
+
+ OPEN (UNIT=15,FILE=rffilename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', rffilename
+ STOP "could not open file for export"
+ END IF
+
+ WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
+ WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
+ WRITE (15,'(" <PolyData>")')
+
+ DO k=1,e%ns
+
+ ! fault slip
+ slip=e%s(k)%slip
+
+ ! fault orientation
+ strike=e%s(k)%strike
+ dip=e%s(k)%dip
+
+ ! fault center position
+ x1=e%s(k)%x
+ x2=e%s(k)%y
+ x3=e%s(k)%z
+
+ ! fault dimension
+ W=e%s(k)%width
+ L=e%s(k)%length
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! strike-slip unit direction
+ s(1)=sstrike
+ s(2)=cstrike
+ s(3)=0._8
+
+ ! dip-slip unit direction
+ d(1)=+cstrike*sdip
+ d(2)=-sstrike*sdip
+ d(3)=+cdip
+
+ WRITE (15,'(" <Piece NumberOfPoints=",a,"4",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
+ WRITE (15,'(" <Points>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Fault Patch",a, &
+ " NumberOfComponents=",a,"3",a, &
+ " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
+
+ ! fault edge coordinates
+ WRITE (15,'(12ES11.2)') &
+ x1-d(1)*W/2-s(1)*L/2,x2-d(2)*W/2-s(2)*L/2,x3-d(3)*W/2-s(3)*L/2, &
+ x1-d(1)*W/2+s(1)*L/2,x2-d(2)*W/2+s(2)*L/2,x3-d(3)*W/2+s(3)*L/2, &
+ x1+d(1)*W/2+s(1)*L/2,x2+d(2)*W/2+s(2)*L/2,x3+d(3)*W/2+s(3)*L/2, &
+ x1+d(1)*W/2-s(1)*L/2,x2+d(2)*W/2-s(2)*L/2,x3+d(3)*W/2-s(3)*L/2
+
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Points>")')
+ WRITE (15,'(" <Polys>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"connectivity",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"0",a, &
+ " RangeMax=",a,"3",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'("0 1 2 3")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"offsets",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"4",a, &
+ " RangeMax=",a,"4",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'(" 4")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Polys>")')
+
+ WRITE (15,'(" <CellData Normals=",a,"slip",a,">")'), q,q
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"slip",a, &
+ " NumberOfComponents=",a,"3",a, &
+ " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
+
+
+ WRITE (15,'(3ES11.2)'), (s(1)+d(1))*slip,(s(2)+d(2))*slip,(s(3)+s(3))*slip
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </CellData>")')
+
+ WRITE (15,'(" </Piece>")')
+
+ END DO
+
+ WRITE (15,'(" </PolyData>")')
+ WRITE (15,'("</VTKFile>")')
+
+ CLOSE(15)
+
+ END SUBROUTINE exportvtk_rfaults
+
+ !------------------------------------------------------------------
+ !> subroutine ExportVTK_RFaults_Stress_Init
+ !! creates a .vtp file (in the VTK PolyData XML format) containing
+ !! the rectangular faults. The faults are characterized with a set
+ !! of subsegments (rectangles) each associated with stress values.
+ !!
+ !! \author sylvain barbot 06/06/11 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE export_rfaults_stress_init(sig,sx1,sx2,sx3,dx1,dx2,dx3, &
+ nsop,sop)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,nsop
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ TYPE(SEGMENT_STRUCT), INTENT(INOUT), DIMENSION(nsop) :: sop
+
+ INTEGER :: k,i1,i2,i3
+ REAL*8 :: x1,x2,x3
+ ! local value of stress
+ TYPE(TENSOR) :: lsig
+
+ DO k=1,nsop
+ ! fault center position
+ x1=sop(k)%x
+ x2=sop(k)%y
+ x3=sop(k)%z
+
+ CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
+ lsig=sig(i1,i2,i3)
+
+ sop(k)%sig0%s11=lsig%s11
+ sop(k)%sig0%s12=lsig%s12
+ sop(k)%sig0%s13=lsig%s13
+ sop(k)%sig0%s22=lsig%s22
+ sop(k)%sig0%s23=lsig%s23
+ sop(k)%sig0%s33=lsig%s33
+
+ END DO
+
+ END SUBROUTINE export_rfaults_stress_init
+
+ !------------------------------------------------------------------
+ !> subroutine ExportGMT_RFaults_Stress
+ !! creates a .vtp file (in the VTK PolyData XML format) containing
+ !! the rectangular faults. The faults are characterized with a set
+ !! of subsegments (rectangles) each associated with stress values.
+ !!
+ !! \author sylvain barbot 06/06/11 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportgmt_rfaults_stress(sx1,sx2,sx3,dx1,dx2,dx3, &
+ nsop,sop,rffilename,convention,sig)
+ USE elastic3d
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,nsop
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ TYPE(SEGMENT_STRUCT), INTENT(INOUT), DIMENSION(nsop) :: sop
+ CHARACTER(80), INTENT(IN) :: rffilename
+ INTEGER, INTENT(IN), OPTIONAL :: convention
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3), OPTIONAL :: sig
+
+ INTEGER :: iostatus,k,i1,i2,i3,conv
+ CHARACTER :: q
+ REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W
+ ! segment normal vector, strike direction, dip direction
+ REAL*8, DIMENSION(3) :: n,s,d
+ ! local value of stress
+ TYPE(TENSOR) :: lsig
+ ! stress components
+ REAL*8 :: taun,taus,taustrike,taudip,taucoulomb
+ ! friction coefficient
+ REAL*8 :: friction
+ ! traction components
+ REAL*8, DIMENSION(3) :: t,ts
+
+ IF (0.GE.nsop) RETURN
+
+ ! double-quote character
+ q=char(34)
+
+ IF (PRESENT(convention)) THEN
+ conv=convention
+ ELSE
+ conv=0
+ END IF
+
+ OPEN (UNIT=15,FILE=rffilename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', rffilename
+ STOP "could not open file for export"
+ END IF
+
+ DO k=1,nsop
+ ! friction coefficient
+ friction=sop(k)%friction
+
+ ! fault orientation
+ strike=sop(k)%strike
+ dip=sop(k)%dip
+
+ ! fault center position
+ x1=sop(k)%x
+ x2=sop(k)%y
+ x3=sop(k)%z
+
+ IF (PRESENT(sig)) THEN
+
+ CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
+ lsig=sig(i1,i2,i3)
+
+ IF (1.EQ.conv) THEN
+ lsig%s11=lsig%s11-sop(k)%sig0%s11
+ lsig%s12=lsig%s12-sop(k)%sig0%s12
+ lsig%s13=lsig%s13-sop(k)%sig0%s13
+ lsig%s22=lsig%s22-sop(k)%sig0%s22
+ lsig%s23=lsig%s23-sop(k)%sig0%s23
+ lsig%s33=lsig%s33-sop(k)%sig0%s33
+ END IF
+ ELSE
+ lsig=TENSOR(0.d0,0.d0,0.d0,0.d0,0.d0,0.d0)
+ END IF
+
+ ! fault dimension
+ W=sop(k)%width
+ L=sop(k)%length
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike
+ n(2)=-cdip*sstrike
+ n(3)=-sdip
+
+ ! strike-slip unit direction
+ s(1)=sstrike
+ s(2)=cstrike
+ s(3)=0._8
+
+ ! dip-slip unit direction
+ d(1)=+cstrike*sdip
+ d(2)=-sstrike*sdip
+ d(3)=+cdip
+
+ ! traction vector
+ t=lsig .tdot. n
+
+ ! signed normal component
+ taun=SUM(t*n)
+
+ ! shear traction
+ ts=t-taun*n
+
+ ! absolute value of shear component
+ taus=SQRT(SUM(ts*ts))
+
+ ! strike-direction shear component
+ taustrike=SUM(ts*s)
+
+ ! dip-direction shear component
+ taudip=SUM(ts*d)
+
+ ! Coulomb stress
+ taucoulomb=taus+friction*taun
+
+ WRITE (15,'("> -Z",5ES11.2)') taus, taun, taucoulomb, taustrike, taudip
+ WRITE (15,'(3ES11.2)') x1-d(1)*W/2-s(1)*L/2, x2-d(2)*W/2-s(2)*L/2
+ WRITE (15,'(3ES11.2)') x1-d(1)*W/2+s(1)*L/2, x2-d(2)*W/2+s(2)*L/2
+ WRITE (15,'(3ES11.2)') x1+d(1)*W/2+s(1)*L/2, x2+d(2)*W/2+s(2)*L/2
+ WRITE (15,'(3ES11.2)') x1+d(1)*W/2-s(1)*L/2, x2+d(2)*W/2-s(2)*L/2
+
+ END DO
+
+ CLOSE(15)
+
+ END SUBROUTINE exportgmt_rfaults_stress
+
+ !------------------------------------------------------------------
+ !> subroutine ExportVTK_RFaults_Stress
+ !! creates a .vtp file (in the VTK PolyData XML format) containing
+ !! the rectangular faults. The faults are characterized with a set
+ !! of subsegments (rectangles) each associated with stress values.
+ !!
+ !! \author sylvain barbot 06/06/11 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportvtk_rfaults_stress(sx1,sx2,sx3,dx1,dx2,dx3, &
+ nsop,sop,rffilename,convention,sig)
+ USE elastic3d
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,nsop
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ TYPE(SEGMENT_STRUCT), INTENT(INOUT), DIMENSION(nsop) :: sop
+ CHARACTER(80), INTENT(IN) :: rffilename
+ INTEGER, INTENT(IN), OPTIONAL :: convention
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3), OPTIONAL :: sig
+
+ INTEGER :: iostatus,k,i1,i2,i3,conv
+ CHARACTER :: q
+ REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W
+ ! segment normal vector, strike direction, dip direction
+ REAL*8, DIMENSION(3) :: n,s,d
+ ! local value of stress
+ TYPE(TENSOR) :: lsig
+ ! stress components
+ REAL*8 :: taun,taus,taustrike,taudip,taucoulomb
+ ! friction coefficient
+ REAL*8 :: friction
+ ! traction components
+ REAL*8, DIMENSION(3) :: t,ts
+
+ IF (0.GE.nsop) RETURN
+
+ ! double-quote character
+ q=char(34)
+
+ IF (PRESENT(convention)) THEN
+ conv=convention
+ ELSE
+ conv=0
+ END IF
+
+ OPEN (UNIT=15,FILE=rffilename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', rffilename
+ STOP "could not open file for export"
+ END IF
+
+ WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
+ WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
+ WRITE (15,'(" <PolyData>")')
+
+ DO k=1,nsop
+ ! friction coefficient
+ friction=sop(k)%friction
+
+ ! fault orientation
+ strike=sop(k)%strike
+ dip=sop(k)%dip
+
+ ! fault center position
+ x1=sop(k)%x
+ x2=sop(k)%y
+ x3=sop(k)%z
+
+ IF (PRESENT(sig)) THEN
+
+ CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
+ lsig=sig(i1,i2,i3)
+
+ IF (1.EQ.conv) THEN
+ lsig%s11=lsig%s11-sop(k)%sig0%s11
+ lsig%s12=lsig%s12-sop(k)%sig0%s12
+ lsig%s13=lsig%s13-sop(k)%sig0%s13
+ lsig%s22=lsig%s22-sop(k)%sig0%s22
+ lsig%s23=lsig%s23-sop(k)%sig0%s23
+ lsig%s33=lsig%s33-sop(k)%sig0%s33
+ END IF
+ ELSE
+ lsig=TENSOR(0.d0,0.d0,0.d0,0.d0,0.d0,0.d0)
+ END IF
+
+ ! fault dimension
+ W=sop(k)%width
+ L=sop(k)%length
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike
+ n(2)=-cdip*sstrike
+ n(3)=-sdip
+
+ ! strike-slip unit direction
+ s(1)=sstrike
+ s(2)=cstrike
+ s(3)=0._8
+
+ ! dip-slip unit direction
+ d(1)=+cstrike*sdip
+ d(2)=-sstrike*sdip
+ d(3)=+cdip
+
+ ! traction vector
+ t=lsig .tdot. n
+
+ ! signed normal component
+ taun=SUM(t*n)
+
+ ! shear traction
+ ts=t-taun*n
+
+ ! absolute value of shear component
+ taus=SQRT(SUM(ts*ts))
+
+ ! strike-direction shear component
+ taustrike=SUM(ts*s)
+
+ ! dip-direction shear component
+ taudip=SUM(ts*d)
+
+ ! Coulomb stress
+ taucoulomb=taus+friction*taun
+
+ WRITE (15,'(" <Piece NumberOfPoints=",a,"4",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
+ WRITE (15,'(" <Points>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Fault Patch",a, &
+ " NumberOfComponents=",a,"3",a, &
+ " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
+ ! fault edge coordinates
+ WRITE (15,'(12ES11.2)') &
+ x1-d(1)*W/2-s(1)*L/2, x2-d(2)*W/2-s(2)*L/2, x3-d(3)*W/2-s(3)*L/2, &
+ x1-d(1)*W/2+s(1)*L/2, x2-d(2)*W/2+s(2)*L/2, x3-d(3)*W/2+s(3)*L/2, &
+ x1+d(1)*W/2+s(1)*L/2, x2+d(2)*W/2+s(2)*L/2, x3+d(3)*W/2+s(3)*L/2, &
+ x1+d(1)*W/2-s(1)*L/2, x2+d(2)*W/2-s(2)*L/2, x3+d(3)*W/2-s(3)*L/2
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" </Points>")')
+ WRITE (15,'(" <Polys>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"connectivity",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"0",a, &
+ " RangeMax=",a,"3",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'("0 1 2 3")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"offsets",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"4",a, &
+ " RangeMax=",a,"4",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'(" 4")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Polys>")')
+
+ WRITE (15,'(" <CellData Normals=",a,"stress",a,">")'), q,q
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"stress tensor",a, &
+ " NumberOfComponents=",a,"6",a, &
+ " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
+ WRITE (15,'(6ES11.2)'), lsig%s11,lsig%s12,lsig%s13,lsig%s22,lsig%s23,lsig%s33
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"shear stress",a, &
+ " NumberOfComponents=",a,"1",a, &
+ " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
+ WRITE (15,'(ES11.2)'), taus
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"normal stress",a, &
+ " NumberOfComponents=",a,"1",a, &
+ " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
+ WRITE (15,'(ES11.2)'), taun
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Coulomb stress",a, &
+ " NumberOfComponents=",a,"1",a, &
+ " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
+ WRITE (15,'(ES11.2)'), taucoulomb
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"stress in strike direction",a, &
+ " NumberOfComponents=",a,"1",a, &
+ " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
+ WRITE (15,'(ES11.2)'), taustrike
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"stress in dip direction",a, &
+ " NumberOfComponents=",a,"1",a, &
+ " format=",a,"ascii",a,">")'), q,q,q,q,q,q,q,q
+ WRITE (15,'(ES11.2)'), taudip
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" </CellData>")')
+
+ WRITE (15,'(" </Piece>")')
+
+ END DO
+
+ WRITE (15,'(" </PolyData>")')
+ WRITE (15,'("</VTKFile>")')
+
+ CLOSE(15)
+
+ END SUBROUTINE exportvtk_rfaults_stress
+
+ !--------------------------------------------------------------------------------
+ !> subroutine ExportCoulombStress
+ !! sample the stress tensor, shear and normal stress and Coulomb
+ !! stress at a series of locations.
+ !!
+ !! each fault patch is attributed to a file in which the time
+ !! evolution is listed in the following format:
+ !!
+ !! #t s11 s12 s13 s22 s23 s33 taus taud tau taun Coulomb
+ !! t0 s11(t0) s12(t0) s13(t0) s22(t0) s23(t0) s33(t0) taus(t0) taud(t0) tau(t0) taun(t0) Coulomb(t0)
+ !! t1 s11(t1) s12(t1) s13(t1) s22(t1) s23(t1) s33(t1) taus(t1) taud(t1) tau(t1) taun(t1) Coulomb(t0)
+ !! ...
+ !!
+ !! where sij(t0) is the component ij of the stress tensor at time t0, taus is
+ !! the component of shear in the strike direction, taud is the component of shear
+ !! in the fault dip direction, tau^2=taus^2+taud^2, taun is the fault normal
+ !! stress and Coulomb(t0) is the Coulomb stress tau+mu*taun.
+ !!
+ !! \author sylvain barbot (10/05/11) - original form
+ !--------------------------------------------------------------------------------
+ SUBROUTINE exportcoulombstress(sig,sx1,sx2,sx3,dx1,dx2,dx3, &
+ nsop,sop,time,wdir,isnew)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,nsop
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ TYPE(SEGMENT_STRUCT), INTENT(INOUT), DIMENSION(nsop) :: sop
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3,time
+ CHARACTER(80), INTENT(IN) :: wdir
+ LOGICAL, INTENT(IN) :: isnew
+
+ INTEGER :: iostatus,k,i1,i2,i3
+ CHARACTER :: q
+ CHARACTER(4) :: digit4
+ CHARACTER(80) :: file
+ REAL*8 :: strike,dip,x1,x2,x3,cstrike,sstrike,cdip,sdip,L,W
+ ! segment normal vector, strike direction, dip direction
+ REAL*8, DIMENSION(3) :: n,s,d
+ ! local value of stress
+ TYPE(TENSOR) :: lsig
+ ! stress components
+ REAL*8 :: taun,taus,taustrike,taudip,taucoulomb
+ ! friction coefficient
+ REAL*8 :: friction
+ ! traction components
+ REAL*8, DIMENSION(3) :: t,ts
+
+ IF (0.GE.nsop) RETURN
+
+ ! double-quote character
+ q=char(34)
+
+ DO k=1,nsop
+ WRITE (digit4,'(I4.4)') k
+ file=trim(wdir)//"/cfaults-sigma-"//digit4//".txt"
+
+ ! fault center position
+ x1=sop(k)%x
+ x2=sop(k)%y
+ x3=sop(k)%z
+
+ IF (isnew) THEN
+ OPEN (UNIT=15,FILE=file,IOSTAT=iostatus,FORM="FORMATTED")
+ WRITE (15,'("# center position (north, east, down): ",3ES9.2)') x1,x2,x3
+ WRITE (15,'("# t s11 s12 s13 ", &
+ "s22 s23 s33 taus taud tau taun Coulomb")')
+ ELSE
+ OPEN (UNIT=15,FILE=file,POSITION="APPEND",&
+ IOSTAT=iostatus,FORM="FORMATTED")
+ END IF
+ IF (iostatus>0) STOP "could not open point file for writing"
+
+ ! friction coefficient
+ friction=sop(k)%friction
+
+ ! fault orientation
+ strike=sop(k)%strike
+ dip=sop(k)%dip
+
+ CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
+ lsig=sig(i1,i2,i3)
+
+ ! fault dimension
+ W=sop(k)%width
+ L=sop(k)%length
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike
+ n(2)=-cdip*sstrike
+ n(3)=-sdip
+
+ ! strike-slip unit direction
+ s(1)=sstrike
+ s(2)=cstrike
+ s(3)=0._8
+
+ ! dip-slip unit direction
+ d(1)=+cstrike*sdip
+ d(2)=-sstrike*sdip
+ d(3)=+cdip
+
+ ! traction vector
+ t=lsig .tdot. n
+
+ ! signed normal component
+ taun=SUM(t*n)
+
+ ! shear traction
+ ts=t-taun*n
+
+ ! absolute value of shear component
+ taus=SQRT(SUM(ts*ts))
+
+ ! strike-direction shear component
+ taustrike=SUM(ts*s)
+
+ ! dip-direction shear component
+ taudip=SUM(ts*d)
+
+ ! Coulomb stress
+ taucoulomb=taus+friction*taun
+
+ WRITE (15,'(12ES11.3E2)') time, &
+ lsig%s11,lsig%s12,lsig%s13, &
+ lsig%s22,lsig%s23,lsig%s33, &
+ taustrike,taudip,taus,taun,taucoulomb
+ CLOSE(15)
+ END DO
+
+ END SUBROUTINE exportcoulombstress
+
+ !------------------------------------------------------------------
+ !> subroutine ExportVTK_Rectangle
+ !! creates a .vtp file (in the VTK PolyData XML format) containing
+ !! a rectangle.
+ !!
+ !! \author sylvain barbot 06/24/09 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportvtk_rectangle(x1,x2,x3,L,W,strike,dip,filename)
+ REAL*8 :: x1,x2,x3,L,W,strike,dip
+ CHARACTER(80), INTENT(IN) :: filename
+
+ INTEGER :: iostatus
+ CHARACTER :: q
+
+ REAL*8 :: cstrike,sstrike,cdip,sdip
+ REAL*8, DIMENSION(3) :: s,d
+
+ ! double-quote character
+ q=char(34)
+
+ OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', filename
+ STOP "could not open file for export in ExportVTK_Rectangle"
+ END IF
+
+ WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
+ WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
+ WRITE (15,'(" <PolyData>")')
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! strike-slip unit direction
+ s(1)=sstrike
+ s(2)=cstrike
+ s(3)=0._8
+
+ ! dip-slip unit direction
+ d(1)=+cstrike*sdip
+ d(2)=-sstrike*sdip
+ d(3)=+cdip
+
+ WRITE (15,'(" <Piece NumberOfPoints=",a,"4",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
+ WRITE (15,'(" <Points>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Fault Patch",a, &
+ " NumberOfComponents=",a,"3",a, &
+ " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
+
+ ! fault edge coordinates
+ WRITE (15,'(12ES11.2)') &
+ x1-d(1)*W/2-s(1)*L/2,x2-d(2)*W/2-s(2)*L/2,x3-d(3)*W/2-s(3)*L/2, &
+ x1-d(1)*W/2+s(1)*L/2,x2-d(2)*W/2+s(2)*L/2,x3-d(3)*W/2+s(3)*L/2, &
+ x1+d(1)*W/2+s(1)*L/2,x2+d(2)*W/2+s(2)*L/2,x3+d(3)*W/2+s(3)*L/2, &
+ x1+d(1)*W/2-s(1)*L/2,x2+d(2)*W/2-s(2)*L/2,x3+d(3)*W/2-s(3)*L/2
+
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Points>")')
+ WRITE (15,'(" <Polys>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"connectivity",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"0",a, &
+ " RangeMax=",a,"3",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'("0 1 2 3")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"offsets",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"4",a, &
+ " RangeMax=",a,"4",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'(" 4")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Polys>")')
+
+ WRITE (15,'(" </Piece>")')
+
+ WRITE (15,'(" </PolyData>")')
+ WRITE (15,'("</VTKFile>")')
+
+ CLOSE(15)
+
+ END SUBROUTINE exportvtk_rectangle
+
+ !------------------------------------------------------------------
+ !> subroutine ExportXY_Brick
+ !! creates a .xy file containing a brick (3d rectangle, cuboid).
+ !!
+ !! \author sylvain barbot 11/29/11 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportxy_brick(x1,x2,x3,L,W,T,strike,dip,filename)
+ REAL*8 :: x1,x2,x3,L,W,T,strike,dip
+ CHARACTER(80), INTENT(IN) :: filename
+
+ INTEGER :: iostatus
+
+ REAL*8 :: cstrike,sstrike,cdip,sdip
+ REAL*8, DIMENSION(3) :: s,d,n
+
+ OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', filename
+ STOP "could not open file for export in ExportXY_Brick"
+ END IF
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! strike-slip unit direction
+ s(1)=sstrike
+ s(2)=cstrike
+ s(3)=0._8
+
+ ! dip-slip unit direction
+ d(1)=+cstrike*sdip
+ d(2)=-sstrike*sdip
+ d(3)=+cdip
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike
+ n(2)=-cdip*sstrike
+ n(3)=-sdip
+
+ ! fault edge coordinates
+ WRITE (15,'(">")')
+ WRITE (15,'(3ES11.2)') x2-d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x1-d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x3-d(3)*W/2-s(3)*L/2-n(3)*T/2.d0
+ WRITE (15,'(3ES11.2)') x2-d(2)*W/2+s(2)*L/2-n(2)*T/2.d0, x1-d(1)*W/2+s(1)*L/2-n(1)*T/2.d0, x3-d(3)*W/2+s(3)*L/2-n(3)*T/2.d0
+ WRITE (15,'(3ES11.2)') x2-d(2)*W/2+s(2)*L/2+n(2)*T/2.d0, x1-d(1)*W/2+s(1)*L/2+n(1)*T/2.d0, x3-d(3)*W/2+s(3)*L/2+n(3)*T/2.d0
+ WRITE (15,'(3ES11.2)') x2-d(2)*W/2-s(2)*L/2+n(2)*T/2.d0, x1-d(1)*W/2-s(1)*L/2+n(1)*T/2.d0, x3-d(3)*W/2-s(3)*L/2+n(3)*T/2.d0
+ WRITE (15,'(3ES11.2)') x2-d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x1-d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x3-d(3)*W/2-s(3)*L/2-n(3)*T/2.d0
+ WRITE (15,'(">")')
+ WRITE (15,'(3ES11.2)') x2+d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x1+d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x3+d(3)*W/2-s(3)*L/2-n(3)*T/2.d0
+ WRITE (15,'(3ES11.2)') x2+d(2)*W/2+s(2)*L/2-n(2)*T/2.d0, x1+d(1)*W/2+s(1)*L/2-n(1)*T/2.d0, x3+d(3)*W/2+s(3)*L/2-n(3)*T/2.d0
+ WRITE (15,'(3ES11.2)') x2+d(2)*W/2+s(2)*L/2+n(2)*T/2.d0, x1+d(1)*W/2+s(1)*L/2+n(1)*T/2.d0, x3+d(3)*W/2+s(3)*L/2+n(3)*T/2.d0
+ WRITE (15,'(3ES11.2)') x2+d(2)*W/2-s(2)*L/2+n(2)*T/2.d0, x1+d(1)*W/2-s(1)*L/2+n(1)*T/2.d0, x3+d(3)*W/2-s(3)*L/2+n(3)*T/2.d0
+ WRITE (15,'(3ES11.2)') x2+d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x1+d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x3+d(3)*W/2-s(3)*L/2-n(3)*T/2.d0
+
+ CLOSE(15)
+
+ END SUBROUTINE exportxy_brick
+
+ !------------------------------------------------------------------
+ !> subroutine ExportVTK_Brick
+ !! creates a .vtp file (in the VTK PolyData XML format) containing
+ !! a brick (3d rectangle, cuboid).
+ !!
+ !! \author sylvain barbot 06/24/09 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportvtk_brick(x1,x2,x3,L,W,T,strike,dip,filename)
+ REAL*8 :: x1,x2,x3,L,W,T,strike,dip
+ CHARACTER(80), INTENT(IN) :: filename
+
+ INTEGER :: iostatus
+ CHARACTER :: q
+
+ REAL*8 :: cstrike,sstrike,cdip,sdip
+ REAL*8, DIMENSION(3) :: s,d,n
+
+ ! double-quote character
+ q=char(34)
+
+ OPEN (UNIT=15,FILE=filename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', filename
+ STOP "could not open file for export in ExportVTK_Brick"
+ END IF
+
+ WRITE (15,'("<?xml version=",a,"1.0",a,"?>")') q,q
+ WRITE (15,'("<VTKFile type=",a,"PolyData",a," version=",a,"0.1",a,">")') q,q,q,q
+ WRITE (15,'(" <PolyData>")')
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! strike-slip unit direction
+ s(1)=sstrike
+ s(2)=cstrike
+ s(3)=0._8
+
+ ! dip-slip unit direction
+ d(1)=+cstrike*sdip
+ d(2)=-sstrike*sdip
+ d(3)=+cdip
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike
+ n(2)=-cdip*sstrike
+ n(3)=-sdip
+
+ WRITE (15,'(" <Piece NumberOfPoints=",a,"8",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
+ WRITE (15,'(" <Points>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Weak Zone",a, &
+ " NumberOfComponents=",a,"3",a, &
+ " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
+
+ ! fault edge coordinates
+ WRITE (15,'(24ES11.2)') &
+ x1-d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x2-d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x3-d(3)*W/2-s(3)*L/2-n(3)*T/2.d0, &
+ x1-d(1)*W/2+s(1)*L/2-n(1)*T/2.d0, x2-d(2)*W/2+s(2)*L/2-n(2)*T/2.d0, x3-d(3)*W/2+s(3)*L/2-n(3)*T/2.d0, &
+ x1+d(1)*W/2+s(1)*L/2-n(1)*T/2.d0, x2+d(2)*W/2+s(2)*L/2-n(2)*T/2.d0, x3+d(3)*W/2+s(3)*L/2-n(3)*T/2.d0, &
+ x1+d(1)*W/2-s(1)*L/2-n(1)*T/2.d0, x2+d(2)*W/2-s(2)*L/2-n(2)*T/2.d0, x3+d(3)*W/2-s(3)*L/2-n(3)*T/2.d0, &
+ x1+d(1)*W/2-s(1)*L/2+n(1)*T/2.d0, x2+d(2)*W/2-s(2)*L/2+n(2)*T/2.d0, x3+d(3)*W/2-s(3)*L/2+n(3)*T/2.d0, &
+ x1-d(1)*W/2-s(1)*L/2+n(1)*T/2.d0, x2-d(2)*W/2-s(2)*L/2+n(2)*T/2.d0, x3-d(3)*W/2-s(3)*L/2+n(3)*T/2.d0, &
+ x1-d(1)*W/2+s(1)*L/2+n(1)*T/2.d0, x2-d(2)*W/2+s(2)*L/2+n(2)*T/2.d0, x3-d(3)*W/2+s(3)*L/2+n(3)*T/2.d0, &
+ x1+d(1)*W/2+s(1)*L/2+n(1)*T/2.d0, x2+d(2)*W/2+s(2)*L/2+n(2)*T/2.d0, x3+d(3)*W/2+s(3)*L/2+n(3)*T/2.d0
+
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Points>")')
+ WRITE (15,'(" <Polys>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"connectivity",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"0",a, &
+ " RangeMax=",a,"6",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'("7 4 5 6 7 4 3 2 7 2 1 6")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"offsets",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"12",a, &
+ " RangeMax=",a,"12",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'(" 12")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Polys>")')
+ WRITE (15,'(" </Piece>")')
+
+ WRITE (15,'(" <Piece NumberOfPoints=",a,"8",a," NumberOfPolys=",a,"1",a,">")'),q,q,q,q
+ WRITE (15,'(" <Points>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Weak Zone",a, &
+ " NumberOfComponents=",a,"3",a, &
+ " format=",a,"ascii",a,">")'),q,q,q,q,q,q,q,q
+
+ ! fault edge coordinates
+ WRITE (15,'(24ES11.2)') &
+ x1-d(1)*W/2.d0-s(1)*L/2.d0-n(1)*T/2.d0, x2-d(2)*W/2.d0-s(2)*L/2.d0-n(2)*T/2.d0,x3-d(3)*W/2-s(3)*L/2-n(3)*T/2.d0, &
+ x1-d(1)*W/2.d0+s(1)*L/2.d0-n(1)*T/2.d0, x2-d(2)*W/2.d0+s(2)*L/2.d0-n(2)*T/2.d0,x3-d(3)*W/2+s(3)*L/2-n(3)*T/2.d0, &
+ x1+d(1)*W/2.d0+s(1)*L/2.d0-n(1)*T/2.d0, x2+d(2)*W/2.d0+s(2)*L/2.d0-n(2)*T/2.d0,x3+d(3)*W/2+s(3)*L/2-n(3)*T/2.d0, &
+ x1+d(1)*W/2.d0-s(1)*L/2.d0-n(1)*T/2.d0, x2+d(2)*W/2.d0-s(2)*L/2.d0-n(2)*T/2.d0,x3+d(3)*W/2-s(3)*L/2-n(3)*T/2.d0, &
+ x1+d(1)*W/2.d0-s(1)*L/2.d0+n(1)*T/2.d0, x2+d(2)*W/2.d0-s(2)*L/2.d0+n(2)*T/2.d0,x3+d(3)*W/2-s(3)*L/2+n(3)*T/2.d0, &
+ x1-d(1)*W/2.d0-s(1)*L/2.d0+n(1)*T/2.d0, x2-d(2)*W/2.d0-s(2)*L/2.d0+n(2)*T/2.d0,x3-d(3)*W/2-s(3)*L/2+n(3)*T/2.d0, &
+ x1-d(1)*W/2.d0+s(1)*L/2.d0+n(1)*T/2.d0, x2-d(2)*W/2.d0+s(2)*L/2.d0+n(2)*T/2.d0,x3-d(3)*W/2+s(3)*L/2+n(3)*T/2.d0, &
+ x1+d(1)*W/2.d0+s(1)*L/2.d0+n(1)*T/2.d0, x2+d(2)*W/2.d0+s(2)*L/2.d0+n(2)*T/2.d0,x3+d(3)*W/2+s(3)*L/2+n(3)*T/2.d0
+
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Points>")')
+ WRITE (15,'(" <Polys>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"connectivity",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"0",a, &
+ " RangeMax=",a,"7",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'("0 1 2 3 0 5 4 3 0 1 6 5")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Int32",a, &
+ " Name=",a,"offsets",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,"12",a, &
+ " RangeMax=",a,"12",a,">")'), q,q,q,q,q,q,q,q,q,q
+ WRITE (15,'(" 12")')
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" </Polys>")')
+ WRITE (15,'(" </Piece>")')
+ WRITE (15,'(" </PolyData>")')
+ WRITE (15,'("</VTKFile>")')
+
+ CLOSE(15)
+
+ END SUBROUTINE exportvtk_brick
+
+ !------------------------------------------------------------------
+ !> subroutine ExportVTK_Vectors
+ !! creates a .vtr file (in the VTK Rectilinear XML format)
+ !! containing a vector field.
+ !!
+ !! \author sylvain barbot 06/25/09 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportvtk_vectors(u1,u2,u3,sx1,sx2,sx3,dx1,dx2,dx3,j1,j2,j3,vcfilename)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,j1,j2,j3
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: u1,u2,u3
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: u1,u2,u3
+#endif
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ CHARACTER(80), INTENT(IN) :: vcfilename
+
+ INTEGER :: iostatus,idum,i1,i2,i3
+ CHARACTER :: q
+ INTEGER :: k1,k2,k3
+ REAL*8 :: x1,x2,x3
+
+ ! double-quote character
+ q=char(34)
+
+ OPEN (UNIT=15,FILE=vcfilename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', vcfilename
+ STOP "could not open file for export"
+ END IF
+
+ WRITE (15,'("<?xml version=",a,"0.1",a,"?>")') q,q
+ WRITE (15,'("<VTKFile type=",a,"RectilinearGrid",a," version=",a,"0.1",a,">")') q,q,q,q
+ WRITE (15,'(" <RectilinearGrid WholeExtent=",a,6I5.4,a,">")') q,1,sx1/j1,1,sx2/j2,1,sx3/j3,q
+ WRITE (15,'(" <Piece Extent=",a,6I5.4,a,">")') q,1,sx1/j1,1,sx2/j2,1,sx3/j3,q
+ WRITE (15,'(" <PointData Scalars=",a,"Vector Field",a,">")') q,q
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"X Velocity",a, &
+ " format=",a,"ascii",a,">")') q,q,q,q,q,q
+
+ ! write first component values
+ DO k3=0,sx3-1,j3
+ x3=REAL(k3,8)
+ DO k2=-sx2/2,sx2/2-1,j2
+ x2=REAL(k2,8)
+ DO k1=-sx1/2,sx1/2-1,j1
+ x1=REAL(k1,8)
+
+ CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
+ WRITE (15,'(ES12.2)') u1(i1,i2,k3+1)
+ END DO
+ END DO
+ END DO
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Y Velocity",a, &
+ " format=",a,"ascii",a,">")') q,q,q,q,q,q
+
+ ! write second component values
+ DO k3=0,sx3-1,j3
+ x3=REAL(k3,8)
+ DO k2=-sx2/2,sx2/2-1,j2
+ x2=REAL(k2,8)
+ DO k1=-sx1/2,sx1/2-1,j1
+ x1=REAL(k1,8)
+
+ CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
+ WRITE (15,'(ES12.2)') u2(i1,i2,k3+1)
+
+ END DO
+ END DO
+ END DO
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Z Velocity",a, &
+ " format=",a,"ascii",a,">")') q,q,q,q,q,q
+
+ ! write third component values
+ DO k3=0,sx3-1,j3
+ x3=REAL(k3,8)
+ DO k2=-sx2/2,sx2/2-1,j2
+ x2=REAL(k2,8)
+ DO k1=-sx1/2,sx1/2-1,j1
+ x1=REAL(k1,8)
+
+ CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
+ WRITE (15,'(ES12.2)') u3(i1,i2,k3+1)
+
+ END DO
+ END DO
+ END DO
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" </PointData>")')
+
+ WRITE (15,'(" <Coordinates>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Array 1",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,ES12.2,a, &
+ " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,-sx1/2*dx1,q,q,(sx1/2-1)*dx1,q
+ DO k1=-sx1/2,sx1/2-1,j1
+ x1=REAL(k1,8)
+ WRITE (15,'(ES12.2)') x1*dx1
+ END DO
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Array 2",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,ES12.2,a, &
+ " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,-sx2/2*dx2,q,q,(sx2/2-1)*dx2,q
+ DO k2=-sx2/2,sx2/2-1,j2
+ x2=REAL(k2,8)
+ WRITE (15,'(ES12.2)') x2*dx2
+ END DO
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Array 3",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,ES12.2,a, &
+ " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,0,q,q,(sx3-1)*dx3,q
+ DO k3=0,sx3-1,j3
+ x3=REAL(k3,8)
+ WRITE (15,'(ES12.2)') x3*dx3
+ END DO
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" </Coordinates>")')
+ WRITE (15,'("</Piece>")')
+ WRITE (15,'("</RectilinearGrid>")')
+ WRITE (15,'("</VTKFile>")')
+
+ CLOSE(15)
+
+ END SUBROUTINE exportvtk_vectors
+
+ !------------------------------------------------------------------
+ !> subroutine ExportVTK_Vectors_Slice
+ !! creates a .vtr file (in the VTK Rectilinear XML format)
+ !! containing a vector field.
+ !!
+ !! \author sylvain barbot 06/25/09 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportvtk_vectors_slice(u1,u2,u3,sx1,sx2,sx3,dx1,dx2,dx3,oz,j1,j2,vcfilename)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,j1,j2
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: u1,u2,u3
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: u1,u2,u3
+#endif
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3,oz
+ CHARACTER(80), INTENT(IN) :: vcfilename
+
+ INTEGER :: iostatus,idum,i1,i2
+ CHARACTER :: q
+ INTEGER :: k1,k2,k3
+ REAL*8 :: x1,x2,x3
+
+ ! double-quote character
+ q=char(34)
+
+ OPEN (UNIT=15,FILE=vcfilename,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ PRINT '(a)', vcfilename
+ STOP "could not open file for export"
+ END IF
+
+ WRITE (15,'("<?xml version=",a,"0.1",a,"?>")') q,q
+ WRITE (15,'("<VTKFile type=",a,"RectilinearGrid",a," version=",a,"0.1",a,">")') q,q,q,q
+ WRITE (15,'(" <RectilinearGrid WholeExtent=",a,6I5.4,a,">")') q,1,sx1/j1,1,sx2/j2,1,1,q
+ WRITE (15,'(" <Piece Extent=",a,6I5.4,a,">")') q,1,sx1/j1,1,sx2/j2,1,1,q
+ WRITE (15,'(" <PointData Scalars=",a,"Vector Field",a,">")') q,q
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"X Velocity",a, &
+ " format=",a,"ascii",a,">")') q,q,q,q,q,q
+
+ ! write first component values
+ x3=oz/dx3
+ DO k2=-sx2/2,sx2/2-1,j2
+ x2=REAL(k2,8)
+ DO k1=-sx1/2,sx1/2-1,j1
+ x1=REAL(k1,8)
+
+ CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
+ WRITE (15,'(ES12.2)') u1(i1,i2,k3+1)
+ END DO
+ END DO
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Y Velocity",a, &
+ " format=",a,"ascii",a,">")') q,q,q,q,q,q
+
+ ! write second component values
+ x3=oz/dx3
+ DO k2=-sx2/2,sx2/2-1,j2
+ x2=REAL(k2,8)
+ DO k1=-sx1/2,sx1/2-1,j1
+ x1=REAL(k1,8)
+
+ CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
+ WRITE (15,'(ES12.2)') u2(i1,i2,k3+1)
+
+ END DO
+ END DO
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Z Velocity",a, &
+ " format=",a,"ascii",a,">")') q,q,q,q,q,q
+
+ ! write third component values
+ x3=oz/dx3
+ DO k2=-sx2/2,sx2/2-1,j2
+ x2=REAL(k2,8)
+ DO k1=-sx1/2,sx1/2-1,j1
+ x1=REAL(k1,8)
+
+ CALL shiftedindex(x1,x2,1._8,sx1,sx2,sx3,1._8,1._8,1._8,i1,i2,idum)
+ WRITE (15,'(ES12.2)') u3(i1,i2,k3+1)
+
+ END DO
+ END DO
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" </PointData>")')
+
+ WRITE (15,'(" <Coordinates>")')
+
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Array 1",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,ES12.2,a, &
+ " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,-sx1/2*dx1,q,q,(sx1/2-1)*dx1,q
+ DO k1=-sx1/2,sx1/2-1,j1
+ x1=REAL(k1,8)
+ WRITE (15,'(ES12.2)') x1*dx1
+ END DO
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Array 2",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,ES12.2,a, &
+ " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,-sx2/2*dx1,q,q,(sx2/2-1)*dx2,q
+ DO k2=-sx2/2,sx2/2-1,j2
+ x2=REAL(k2,8)
+ WRITE (15,'(ES12.2)') x2*dx2
+ END DO
+ WRITE (15,'(" </DataArray>")')
+ WRITE (15,'(" <DataArray type=",a,"Float32",a, &
+ " Name=",a,"Array 3",a, &
+ " format=",a,"ascii",a, &
+ " RangeMin=",a,ES12.2,a, &
+ " RangeMax=",a,ES12.2,a,">")') q,q,q,q,q,q,q,oz,q,q,oz,q
+ WRITE (15,'(2ES12.2)') oz
+ WRITE (15,'(" </DataArray>")')
+
+ WRITE (15,'(" </Coordinates>")')
+ WRITE (15,'("</Piece>")')
+ WRITE (15,'("</RectilinearGrid>")')
+ WRITE (15,'("</VTKFile>")')
+
+ CLOSE(15)
+
+ END SUBROUTINE exportvtk_vectors_slice
+#endif
+
+END MODULE export
diff -r 405d8f4fa05f -r e7295294f654 src/fourier.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/fourier.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,631 @@
+!-----------------------------------------------------------------------
+! Copyright 2007, 2008, 2009 Sylvain Barbot
+!
+! This file is part of RELAX
+!
+! RELAX 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 3 of the License, or
+! (at your option) any later version.
+!
+! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
+!-----------------------------------------------------------------------
+
+#include "include.f90"
+
+MODULE fourier
+
+#ifdef IMKL_FFT
+ USE MKL_DFTI
+#endif
+
+ IMPLICIT NONE
+
+ PUBLIC
+
+#ifdef FFTW3
+ INCLUDE 'fftw3.f'
+#endif
+
+ INTEGER, PARAMETER :: FFT_FORWARD=-1,FFT_INVERSE=1
+
+CONTAINS
+
+ !---------------------------------------------------------------------
+ !> subroutine wavenumbers
+ !! computes the values of the wavenumbers
+ !! in the sequential order required when using subroutine FOURT
+ !! to perform forward and backward inverse transforms.
+ !!
+ !! INPUT
+ !! @param i1 running index in the discrete Fourier domain array
+ !! @param i2 running index in the discrete Fourier domain array
+ !! @param i3 running index in the discrete Fourier domain array
+ !! @param sx1 number of elements in the x1-direction
+ !! @param sx2 number of elements in the x2-direction
+ !! @param sx3 number of elements in the x3-direction
+ !! @param dx1 sampling interval in the x1-direction
+ !! @param dx2 sampling interval in the x2-direction
+ !! @param dx3 sampling interval in the x3-direction
+ !!
+ !! OUTPUT
+ !! @param k1 wavenumber in the x1 direction
+ !! @param k2 wavenumber in the x2 direction
+ !! @param k3 wavenumber in the x3 direction
+ !!
+ !! \author sylvain barbot (04-14-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE wavenumbers(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,k1,k2,k3)
+ INTEGER, INTENT(IN) :: i1, i2, i3, sx1, sx2, sx3
+ REAL*8, INTENT(IN) :: dx1, dx2, dx3
+ REAL*8, INTENT(OUT) :: k1, k2, k3
+
+ IF (i3 < sx3/2+1) THEN
+ k3= (DBLE(i3)-1._8)/(sx3*dx3)
+ ELSE
+ k3=-(DBLE(sx3-i3)+1._8)/(sx3*dx3)
+ END IF
+ IF (i2 < sx2/2+1) THEN
+ k2= (DBLE(i2)-1._8)/(sx2*dx2)
+ ELSE
+ k2=-(DBLE(sx2-i2)+1._8)/(sx2*dx2)
+ END IF
+ k1=(DBLE(i1)-1._8)/(sx1*dx1)
+
+ END SUBROUTINE wavenumbers
+
+ SUBROUTINE wavenumber1(i1,sx1,dx1,k1)
+ INTEGER, INTENT(IN) :: i1,sx1
+ REAL*8, INTENT(IN) :: dx1
+ REAL*8, INTENT(OUT) :: k1
+
+ k1=(DBLE(i1)-1._8)/(sx1*dx1)
+ END SUBROUTINE wavenumber1
+
+ SUBROUTINE wavenumber2(i2,sx2,dx2,k2)
+ INTEGER, INTENT(IN) :: i2,sx2
+ REAL*8, INTENT(IN) :: dx2
+ REAL*8, INTENT(OUT) :: k2
+
+ IF (i2 < sx2/2+1) THEN
+ k2= (DBLE(i2)-1._8)/(sx2*dx2)
+ ELSE
+ k2=-(DBLE(sx2-i2)+1._8)/(sx2*dx2)
+ END IF
+ END SUBROUTINE wavenumber2
+
+ SUBROUTINE wavenumber3(i3,sx3,dx3,k3)
+ INTEGER, INTENT(IN) :: i3,sx3
+ REAL*8, INTENT(IN) :: dx3
+ REAL*8, INTENT(OUT) :: k3
+
+ IF (i3 < sx3/2+1) THEN
+ k3= (DBLE(i3)-1._8)/(sx3*dx3)
+ ELSE
+ k3=-(DBLE(sx3-i3)+1._8)/(sx3*dx3)
+ END IF
+ END SUBROUTINE wavenumber3
+
+ !---------------------------------------------------------------------
+ ! subroutine FFTshift_TF applies the transfer function
+ ! in the Fourier domain corresponding to shifting the space
+ ! domain array by sx1*dx1/2 in the 1-direction and sx3*dx3/2
+ ! in the 3-direction.
+ !
+ ! fftshift_tf follows the data storage convention in
+ ! agreement with DFT subroutine FOURT
+ !
+ ! sylvain barbot (05-01-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE fftshift_tf(spec)
+ REAL*4, INTENT(INOUT), DIMENSION(:,:,:) :: spec
+
+ INTEGER :: sx1, sx2, sx3, i1, i2, i3
+ REAL*4 :: exp1, exp2, exp3
+
+ sx1=SIZE(spec, 1)-2
+ sx2=SIZE(spec, 2)
+ sx3=SIZE(spec, 3)
+
+ DO i3=1,sx3
+ IF (i3 < sx3/2+1) THEN
+ exp3=-(DBLE(i3)-1._8)
+ ELSE
+ exp3= (DBLE(sx3-i3)+1._8)
+ END IF
+ DO i2=1,sx2
+ IF (i2 < sx2/2+1) THEN
+ exp2=-(DBLE(i2)-1._8)
+ ELSE
+ exp2= (DBLE(sx2-i2)+1._8)
+ END IF
+ DO i1=1,sx1/2+1
+ exp1=(DBLE(i1)-1._8)
+ spec(2*i1-1:2*i1,i2,i3) = &
+ spec(2*i1-1:2*i1,i2,i3)*((-1._4)**(exp1+exp2+exp3))
+ END DO
+ END DO
+ END DO
+ END SUBROUTINE fftshift_tf
+
+ !----------------------------------------------------------------------
+ !> subroutine FFT3 performs normalized forward and
+ !! inverse fourier transforms of real 3d data
+ !
+ !! USES
+ !! ctfft (Brenner, 1968) by default
+ !! fftw3 (Frigo & Jonhson) with preproc FFTW3 flag
+ !! scfft (SGI library) with preproc SGI_FFT flag
+ !! ctfft (Cooley-Tuckey) by default (slowest FFT)
+ !!
+ !! for real array the fourier transform returns a sx1/2+1 complex array
+ !! and the enough space must be reserved
+ !----------------------------------------------------------------------
+#ifdef FFTW3
+ !--------------------------------------------------------
+ ! implementation of FFTW3
+ ! must be linked with -lfftw3f (single-threaded version)
+ !
+ ! sylvain barbot (09-28-08) - original form
+ !--------------------------------------------------------
+ SUBROUTINE fft3(data,sx1,sx2,sx3,dx1,dx2,dx3,direction)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,direction
+ REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+
+ INTEGER*8 :: plan
+
+ IF (FFT_FORWARD == direction) THEN
+ CALL sfftw_plan_dft_r2c_3d(plan,sx1,sx2,sx3, &
+ data(1,1,1),data(1,1,1),FFTW_ESTIMATE)
+ ELSE
+ CALL sfftw_plan_dft_c2r_3d(plan,sx1,sx2,sx3, &
+ data(1,1,1),data(1,1,1),FFTW_ESTIMATE)
+ END IF
+
+ CALL sfftw_execute(plan)
+ CALL sfftw_destroy_plan(plan)
+
+ IF (FFT_INVERSE == direction) THEN
+ data=data/(sx1*dx1*sx2*dx2*sx3*dx3)
+ ELSE
+ data=data*(dx1*dx2*dx3)
+ END IF
+
+ END SUBROUTINE fft3
+#else
+#ifdef SGI_FFT
+ !--------------------------------------------------------------------
+ ! implementation of SGI SCFFT
+ ! must be linked with -L/usr/lib -lscs or -L/usr/lib -lscs_mp for
+ ! multithread version expect up x8 performance increase compared to
+ ! ctfft implementation. check out the SGI documentation at:
+ !
+ ! http://techpubs.sgi.com/library/tpl/cgi-bin/getdoc.cgi?coll=linux&
+ ! db=man&fname=/usr/share/catman/man3/ccfft.3s.html&srch=ccfft
+ !
+ ! sylvain barbot (09-28-08) - original form
+ !--------------------------------------------------------------------
+ SUBROUTINE fft3(data,sx1,sx2,sx3,dx1,dx2,dx3,direction)
+ INTEGER, INTENT(IN) :: direction,sx1,sx2,sx3
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+
+ INTEGER, PARAMETER :: NF=256, NFR=256
+
+ REAL*4, DIMENSION(sx1+NFR+(2*sx2+NF)+(2*sx3+NF)) :: table
+ REAL*4, DIMENSION(sx1+4*sx3) :: work
+ INTEGER, DIMENSION(2) :: isys
+ REAL*4 :: scale
+
+ isys(1)=1
+
+ IF (FFT_FORWARD == direction) THEN
+ scale=dx1*dx2*dx3
+ ! initialize the sin/cos table
+ CALL SCFFT3D(+0,sx1,sx2,sx3,scale,data(1,1,1),sx1+2,sx2, &
+ data(1,1,1),sx1/2+1,sx2,table,work,isys)
+ CALL SCFFT3D(-1,sx1,sx2,sx3,scale,data(1,1,1),sx1+2,sx2, &
+ data(1,1,1),sx1/2+1,sx2,table,work,isys)
+ ELSE
+ scale=1._4/(sx1*dx1*sx2*dx2*sx3*dx3)
+ ! initialize the sin/cos table
+ CALL CSFFT3D(+0,sx1,sx2,sx3,scale,data(1,1,1),sx1/2+1,sx2, &
+ data(1,1,1),sx1+2,sx2,table,work,isys)
+ CALL CSFFT3D(+1,sx1,sx2,sx3,scale,data(1,1,1),sx1/2+1,sx2, &
+ data(1,1,1),sx1+2,sx2,table,work,isys)
+ END IF
+
+ END SUBROUTINE fft3
+#else
+#ifdef IMKL_FFT
+ !-------------------------------------------------------------------------
+ ! implementation IMKL_FFT (Intel Math Kernel Library)
+ ! for information and example calculations with the
+ ! mkl FFT, see:
+ !
+ ! http://www.intel.com/software/products/mkl/docs/webhelp/appendices/ ...
+ ! mkl_appC_DFT.html#appC-exC-25
+ !
+ ! and a thread (Fortran 3-D FFT real-to-complex ...)
+ ! on the intel forum
+ !
+ ! http://software.intel.com/en-us/forums/intel-math-kernel-library/
+ !
+ ! sylvain barbot (04-30-10) - original form
+ !-------------------------------------------------------------------------
+ SUBROUTINE fft3(data,sx1,sx2,sx3,dx1,dx2,dx3,direction)
+ REAL*4, DIMENSION(0:*), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,direction
+
+ INTEGER :: iret,size(3),rstrides(4),cstrides(4)
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL*4 :: scale
+
+ rstrides=(/ 0,1,(sx1/2+1)*2,(sx1/2+1)*2*sx2 /)
+ cstrides=(/ 0,1,sx1/2+1,(sx1/2+1)*sx2 /)
+ size=(/ sx1,sx2,sx3 /)
+
+ iret=DftiCreateDescriptor(desc,DFTI_SINGLE,DFTI_REAL,3,size)
+ iret=DftiSetValue(desc,DFTI_CONJUGATE_EVEN_STORAGE,DFTI_COMPLEX_COMPLEX)
+
+ IF(iret.NE.0) THEN
+ IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,*) DftiErrorMessage(iret)
+ STOP 1
+ END IF
+ END IF
+
+ IF (FFT_FORWARD == direction) THEN
+ scale=dx1*dx2*dx3
+ iret=DftiSetValue(desc,DFTI_FORWARD_SCALE,scale)
+ iret=DftiSetValue(desc,DFTI_INPUT_STRIDES,rstrides);
+ iret=DftiSetValue(desc,DFTI_OUTPUT_STRIDES,cstrides);
+ iret=DftiCommitDescriptor(desc)
+ iret=DftiComputeForward(desc,data)
+ ELSE
+ scale=1._4/(sx1*dx1*sx2*dx2*sx3*dx3)
+ iret=DftiSetValue(desc,DFTI_BACKWARD_SCALE,scale)
+ iret=DftiSetValue(desc,DFTI_INPUT_STRIDES,cstrides);
+ iret=DftiSetValue(desc,DFTI_OUTPUT_STRIDES,rstrides);
+ iret=DftiCommitDescriptor(desc)
+ iret=DftiComputeBackward(desc,data)
+ END IF
+ iret=DftiFreeDescriptor(desc)
+ IF(iret.NE.0) THEN
+ IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,*) DftiErrorMessage(iret)
+ STOP 1
+ END IF
+ END IF
+
+ END SUBROUTINE fft3
+#else
+ !------------------------------------------------------
+ ! implementation of ctfft (N. Brenner, 1968)
+ ! must be linked with ctfft.o
+ !------------------------------------------------------
+ SUBROUTINE fft3(data,sx1,sx2,sx3,dx1,dx2,dx3,direction)
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3,direction
+
+ INTEGER :: dim(3)
+ INTEGER :: FOURT_DS ! data storage
+ INTEGER, PARAMETER :: FOURT_NW = 128 ! extra work space size
+ REAL*4, DIMENSION(FOURT_NW) :: FOURT_WORK ! extra work space
+
+ dim=(/ sx1,sx2,sx3 /)
+
+ IF (FFT_FORWARD == direction) THEN
+ FOURT_DS=0
+ ELSE
+ FOURT_DS=-1
+ END IF
+ CALL ctfft(data,dim,3,direction,FOURT_DS,FOURT_WORK,FOURT_NW)
+
+ IF (FFT_INVERSE == direction) THEN
+ data=data/(sx1*dx1*sx2*dx2*sx3*dx3)
+ ELSE
+ data=data*(dx1*dx2*dx3)
+ END IF
+
+ END SUBROUTINE fft3
+#endif
+#endif
+#endif
+ !----------------------------------------------------------------------
+ !> subroutine FFT2 performs normalized forward and
+ !! inverse fourier transforms of real 2d data
+ !!
+ !! USES subroutine FOURT
+ !! ctfft(data,n,ndim,isign,iform,work,nwork)
+ !! or
+ !! fftw3
+ !!
+ !! for real array the fourier transform returns a sx1/2+1 complex array
+ !! and the enough space must be reserved
+ !----------------------------------------------------------------------
+#ifdef FFTW3
+ SUBROUTINE fft2(data,sx1,sx2,dx1,dx2,direction)
+ INTEGER, INTENT(IN) :: sx1,sx2,direction
+ REAL*4, DIMENSION(sx1+2,sx2), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx1,dx2
+
+ INTEGER*8 :: plan
+
+ IF (FFT_FORWARD == direction) THEN
+ CALL sfftw_plan_dft_r2c_2d(plan,sx1,sx2, &
+ data(1,1),data(1,1),FFTW_ESTIMATE)
+ ELSE
+ CALL sfftw_plan_dft_c2r_2d(plan,sx1,sx2, &
+ data(1,1),data(1,1),FFTW_ESTIMATE)
+ END IF
+
+ CALL sfftw_execute(plan)
+ CALL sfftw_destroy_plan(plan)
+
+ IF (FFT_INVERSE == direction) THEN
+ data=data/(sx1*dx1*sx2*dx2)
+ ELSE
+ data=data*(dx1*dx2)
+ END IF
+
+ END SUBROUTINE fft2
+#else
+#ifdef SGI_FFT
+ SUBROUTINE fft2(data,sx1,sx2,dx1,dx2,direction)
+ REAL*4, DIMENSION(:,:), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx1,dx2
+ INTEGER, INTENT(IN) :: sx1,sx2,direction
+
+ INTEGER, PARAMETER :: NF=256, NFR=256
+
+ REAL*4, DIMENSION(sx1+NFR+2*sx2+NF) :: table
+ REAL*4, DIMENSION(sx1+4*sx2) :: work
+ INTEGER, DIMENSION(2) :: isys
+ REAL*4 :: scale
+
+ isys(1)=1
+
+ IF (FFT_FORWARD == direction) THEN
+ scale=dx1*dx2
+ ! initialize the sin/cos table
+ CALL SCFFT2D(+0,sx1,sx2,scale,data(1,1),sx1+2, &
+ data(1,1),sx1/2+1,table,work,isys)
+ CALL SCFFT2D(-1,sx1,sx2,scale,data(1,1),sx1+2, &
+ data(1,1),sx1/2+1,table,work,isys)
+ ELSE
+ scale=1._4/(sx1*dx1*sx2*dx2)
+ ! initialize the sin/cos table
+ CALL CSFFT2D(+0,sx1,sx2,scale,data(1,1),sx1/2+1, &
+ data(1,1),sx1+2,table,work,isys)
+ CALL CSFFT2D(+1,sx1,sx2,scale,data(1,1),sx1/2+1, &
+ data(1,1),sx1+2,table,work,isys)
+ END IF
+
+ END SUBROUTINE fft2
+#else
+#ifdef IMKL_FFT
+ !------------------------------------------------------
+ ! implementation IMKL_FFT (Intel Math Kernel Library)
+ ! for information and example calculations with the
+ ! mkl FFT, see:
+ !
+ ! http://www.intel.com/software/products/mkl/ ...
+ ! docs/webhelp/appendices/ ...
+ ! mkl_appC_DFT.html#appC-exC-25
+ !
+ ! sylvain barbot (04-30-10) - original form
+ !------------------------------------------------------
+ SUBROUTINE fft2(data,sx1,sx2,dx1,dx2,direction)
+ REAL*4, DIMENSION(0:*), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx1,dx2
+ INTEGER, INTENT(IN) :: sx1,sx2,direction
+
+ INTEGER :: iret,size(2),rstrides(3),cstrides(3)
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL*4 :: scale
+
+ rstrides=(/ 0,1,sx1+2 /)
+ cstrides=(/ 0,1,sx1/2+1 /)
+ size=(/ sx1,sx2 /)
+
+ iret=DftiCreateDescriptor(desc,DFTI_SINGLE,DFTI_REAL,2,size);
+ iret=DftiSetValue(desc,DFTI_CONJUGATE_EVEN_STORAGE,DFTI_COMPLEX_COMPLEX)
+
+ IF(iret.NE.0) THEN
+ IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,*) DftiErrorMessage(iret)
+ STOP 1
+ END IF
+ END IF
+
+ IF (FFT_FORWARD == direction) THEN
+ scale=dx1*dx2
+ iret=DftiSetValue(desc,DFTI_FORWARD_SCALE,scale)
+ iret=DftiSetValue(desc,DFTI_INPUT_STRIDES,rstrides);
+ iret=DftiSetValue(desc,DFTI_OUTPUT_STRIDES,cstrides);
+ iret=DftiCommitDescriptor(desc)
+ iret=DftiComputeForward(desc,data)
+ ELSE
+ scale=1._4/(sx1*dx1*sx2*dx2)
+ iret=DftiSetValue(desc,DFTI_BACKWARD_SCALE,scale)
+ iret=DftiSetValue(desc,DFTI_INPUT_STRIDES,cstrides);
+ iret=DftiSetValue(desc,DFTI_OUTPUT_STRIDES,rstrides);
+ iret=DftiCommitDescriptor(desc)
+ iret=DftiComputeBackward(desc,data)
+ END IF
+ iret=DftiFreeDescriptor(desc)
+ IF(iret.NE.0) THEN
+ IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,*) DftiErrorMessage(iret)
+ STOP 1
+ END IF
+ END IF
+
+ END SUBROUTINE fft2
+#else
+ !------------------------------------------------------
+ ! Couley-Tuckey implementation of the Fourier
+ ! transform with built-in FFT code (ctfft.f).
+ !------------------------------------------------------
+ SUBROUTINE fft2(data,sx1,sx2,dx1,dx2,direction)
+ REAL*4, DIMENSION(:,:), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx1,dx2
+ INTEGER, INTENT(IN) :: sx1,sx2,direction
+
+ INTEGER :: dim(2)
+ INTEGER :: FOURT_DS ! data storage
+ INTEGER, PARAMETER :: FOURT_NW = 64 ! extra work space size
+ REAL*4, DIMENSION(FOURT_NW) :: FOURT_WORK ! extra work space
+
+ dim=(/ sx1,sx2 /)
+
+ IF (FFT_FORWARD == direction) THEN
+ FOURT_DS=0
+ ELSE
+ FOURT_DS=-1
+ END IF
+ CALL ctfft(data,dim,2,direction,FOURT_DS,FOURT_WORK,FOURT_NW)
+
+ IF (FFT_INVERSE == direction) THEN
+ data=data/(sx1*dx1*sx2*dx2)
+ ELSE
+ data=data*(dx1*dx2)
+ END IF
+
+ END SUBROUTINE fft2
+#endif
+#endif
+#endif
+
+ !-----------------------------------------------------------------
+ !> subroutine FFT1
+ !! performs a one dimensional complex to complex Fourier
+ !! transform
+ !!
+ !! uses complex DFT ctfft (N. Brenner, 1968) by default
+ !! or CCFFT (SGI library) with compile flag SGI_FFT
+ !!
+ !! \author sylvain barbot (05-02-07) - original form
+ !-----------------------------------------------------------------
+#ifdef SGI_FFT
+ !------------------------------------------------------
+ ! implementation CCFFT
+ !
+ ! sylvain barbot (09-28-08) - original form
+ !------------------------------------------------------
+ SUBROUTINE fft1(data,sx,dx,direction)
+ INTEGER, INTENT(IN) :: sx,direction
+ COMPLEX(KIND=4), DIMENSION(:), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx
+
+ INTEGER, PARAMETER :: NF=256
+
+ REAL*4, DIMENSION(2*sx+NF) :: table
+ REAL*4, DIMENSION(2*sx) :: work
+ INTEGER, DIMENSION(2) :: isys
+ REAL*4 :: scale
+
+ isys(1)=1
+
+ IF (FFT_FORWARD == direction) THEN
+ scale=dx
+ ! initialize the sin/cos table
+ CALL CCFFT(+0,sx,scale,data,data,table,work,isys)
+ CALL CCFFT(-1,sx,scale,data,data,table,work,isys)
+ ELSE
+ scale=1._4/(sx*dx)
+ ! initialize the sin/cos table
+ CALL CCFFT(+0,sx,scale,data,data,table,work,isys)
+ CALL CCFFT(+1,sx,scale,data,data,table,work,isys)
+ END IF
+
+ END SUBROUTINE fft1
+#else
+#ifdef IMKL_FFT
+ !------------------------------------------------------
+ ! implementation IMKL_FFT (Intel Math Kernel Library)
+ ! evaluates a complex-to-complex Fourier transform
+ !
+ ! sylvain barbot (04-30-10) - original form
+ !------------------------------------------------------
+ SUBROUTINE fft1(data,sx,dx,direction)
+ INTEGER, INTENT(IN) :: sx,direction
+ COMPLEX(KIND=4), DIMENSION(0:*), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx
+
+ INTEGER :: iret
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+
+ REAL*4 :: scale
+
+ iret=DftiCreateDescriptor(desc,DFTI_SINGLE,DFTI_COMPLEX,1,sx)
+ IF(iret.NE.0) THEN
+ IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,*) DftiErrorMessage(iret)
+ STOP 1
+ END IF
+ END IF
+
+ IF (FFT_FORWARD == direction) THEN
+ scale=dx
+ iret=DftiSetValue(desc,DFTI_FORWARD_SCALE,scale)
+ iret=DftiCommitDescriptor(desc)
+ iret=DftiComputeForward(desc,data)
+ ELSE
+ scale=1._4/(sx*dx)
+ iret=DftiSetValue(desc,DFTI_BACKWARD_SCALE,scale)
+ iret=DftiCommitDescriptor(desc)
+ iret=DftiComputeBackward(desc,data)
+ END IF
+ iret=DftiFreeDescriptor(desc)
+ IF(iret.NE.0) THEN
+ IF(.NOT.DftiErrorClass(iret,DFTI_NO_ERROR)) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,*) DftiErrorMessage(iret)
+ STOP 1
+ END IF
+ END IF
+
+ END SUBROUTINE fft1
+#else
+ !----------------------------------------------------
+ ! implementation ctfft
+ !
+ ! sylvain barbot (05-02-07) - original form
+ !----------------------------------------------------
+ SUBROUTINE fft1(data,sx,dx,direction)
+ COMPLEX(KIND=4),DIMENSION(:), INTENT(INOUT) :: data
+ REAL*8, INTENT(IN) :: dx
+ INTEGER, INTENT(IN) :: sx,direction
+
+ INTEGER, PARAMETER :: FOURT_NW = 32 ! extra work space size
+ REAL*4, DIMENSION(FOURT_NW) :: FOURT_WORK ! extra work space
+ INTEGER :: FOURT_DS = 1
+
+ CALL ctfft(data,sx,1,direction,FOURT_DS,FOURT_WORK,FOURT_NW)
+ IF (FFT_INVERSE == direction) THEN
+ data=data/(sx*dx)
+ ELSE
+ data=data*dx
+ END IF
+
+ END SUBROUTINE fft1
+#endif
+#endif
+
+END MODULE fourier
diff -r 405d8f4fa05f -r e7295294f654 src/friction3d.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/friction3d.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,553 @@
+!-----------------------------------------------------------------------
+! Copyright 2007, 2008, 2009 Sylvain Barbot
+!
+! This file is part of RELAX
+!
+! RELAX 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 3 of the License, or
+! (at your option) any later version.
+!
+! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
+!-----------------------------------------------------------------------
+
+MODULE friction3d
+
+ USE elastic3d
+
+ IMPLICIT NONE
+
+#include "include.f90"
+
+ REAL*8, PRIVATE, PARAMETER :: pi = 3.141592653589793115997963468544185161_8
+ REAL*8, PRIVATE, PARAMETER :: pi2 = 6.28318530717958623199592693708837032318_8
+ REAL*8, PRIVATE, PARAMETER :: pid2 = 1.57079632679489655799898173427209258079_8
+
+CONTAINS
+
+ !-----------------------------------------------------------------
+ !> subroutine FrictionPlaneExpEigenStress
+ !!
+ !! *** this function is deprecated ***
+ !
+ ! compute the eigen-stress (forcing moment) to be relaxed by
+ ! rate-dependent inelastic deformation in the case of a frictional
+ ! surface:
+ !
+ ! sigma^i = C:F:sigma
+ !
+ ! where C is the elastic moduli tensor, F is the heterogeneous
+ ! fluidity moduli tensor and sigma is the instantaneous stress
+ ! tensor. for a frictional surface, the eigenstrain-rate is given
+ ! by
+ !
+ ! epsilon^i^dot = F:sigma = gamma^dot R
+ !
+ ! where gamma^dot is the slip rate (a scalar) and R is the
+ ! deviatoric, symmetric, and unitary, tensor:
+ !
+ ! R_ij = 1/2 ( t_i n_j + t_j n_i ) / sqrt( t_j t_j )
+ !
+ ! where the shear traction t_i is the projection of the traction
+ ! vector on the plane surface. the strain amplitude is given by
+ !
+ ! gamma^dot = vo sinh( taus / (t_c )
+ !
+ ! where taus is the effective shear on the fault plane,
+ !
+ ! taus = tau + mu*sigma
+ !
+ ! where tau is the shear and sigma the normal stress. tau and sigma
+ ! assumed to be the co-seismic change only, not the absolute
+ ! stress. vo is a reference slip velocity, and t_c, the critical
+ ! stress, corresponds to (a-b)*sigma in the framework of rate-and-
+ ! state friction. the effective viscosity eta* and the fluidity
+ !
+ ! eta* = tau / gamma^dot
+ ! fluidity = 1 / eta*
+ !
+ ! are used to compute the optimal time-step.
+ !
+ ! sylvain barbot (07/24/07) - original form
+ ! (07/24/07) - deprecated (see frictioneigenstress)
+ !-----------------------------------------------------------------
+ SUBROUTINE frictionplaneeigenstress(sig,mu,structure, &
+ n1,n2,n3,sx1,sx2,sx3,dx1,dx2,dx3,moment,maxwelltime,gamma,dt)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: mu,dx1,dx2,dx3
+ TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: moment
+ REAL*8, OPTIONAL, INTENT(INOUT) :: maxwelltime
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(IN), DIMENSION(sx1+2,sx2,sx3) :: n1,n2,n3
+ REAL*4, INTENT(OUT), DIMENSION(sx1+2,sx2,sx3), OPTIONAL :: gamma
+#else
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: n1,n2,n3
+ REAL*4, INTENT(OUT), DIMENSION(sx1,sx2,sx3), OPTIONAL :: gamma
+#endif
+ REAL*8, INTENT(IN), OPTIONAL :: dt
+
+ INTEGER :: i1,i2,i3
+ TYPE(TENSOR) :: s
+ REAL*8, DIMENSION(3) :: t,ts,n
+ REAL*8 :: vo,taue,tauc,taun,taus,gammadot,impulse, &
+ friction,tau,scaling,cohesion
+
+ ! delta function scaling
+ scaling=sqrt(pi2)*dx1
+
+ DO i3=1,sx3
+
+ vo=structure(i3)%gammadot0
+ tauc=structure(i3)%stressexponent
+ friction=structure(i3)%friction
+ cohesion=structure(i3)%cohesion
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ n=(/ DBLE(n1(i1,i2,i3)),DBLE(n2(i1,i2,i3)),DBLE(n3(i1,i2,i3))/)
+ impulse=sqrt(sum(n*n))
+
+ IF (impulse .LE. 0.01_8/dx1) CYCLE
+
+ ! discrete delta function impulse
+ n=n/impulse
+
+ ! traction = sigma . n
+ s=sig(i1,i2,i3)
+ t=s .tdot. n
+
+ ! signed normal component
+ taun=SUM(t*n)
+
+ ! absolute value of shear component
+ ts=t-taun*n
+ taus=SQRT(SUM(ts*ts))
+
+ ! effective shear stress on fault plane
+ tau=taus+friction*taun
+
+ ! warning for wrong input
+ IF ((tau/tauc) .gt. 20) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("------------------------------------------")')
+ WRITE (0,'("wrong value of (a-b)sigma gives rise to")')
+ WRITE (0,'("(a-b)sigma=",3ES11.3E2)') tauc
+ WRITE (0,'("tau=",3ES11.3E2)') tau
+ WRITE (0,'("taus=",3ES11.3E2)') taus
+ WRITE (0,'("taun=",3ES11.3E2)') taun
+ WRITE (0,'("tau/((a-b)sigma)=",3ES11.3E2)') tau/tauc
+ WRITE (0,'("------------------------------------------")')
+ STOP 5
+ END IF
+
+ ! effective stress
+ taue=tau-cohesion
+
+ ! yield surface test
+ IF ((0._8 .GE. taus) .OR. (taue .LE. 1e-8)) CYCLE
+
+ ! shear traction direction
+ ts=ts/taus
+
+ ! deviatoric strain rate
+ gammadot=vo*2*sinh(taue/tauc)
+
+ IF (PRESENT(maxwelltime)) &
+ maxwelltime=MIN(maxwelltime,taue/mu/gammadot)
+
+ ! provide the strain-rate on request
+ IF (PRESENT(gamma)) THEN
+ gamma(i1,i2,i3)=gamma(i1,i2,i3)+gammadot*impulse*scaling*dt
+ END IF
+
+ ! deviatoric strain
+ moment(i1,i2,i3)=moment(i1,i2,i3) .plus. &
+ (ts .sdyad. ((2._8*mu*impulse*gammadot)*n))
+
+ END DO
+ END DO
+ END DO
+
+ END SUBROUTINE frictionplaneeigenstress
+
+ !-----------------------------------------------------------------
+ !> subroutine FrictionEigenStress
+ !! compute the eigen-stress (forcing moment) to be relaxed by
+ !! rate-dependent inelastic deformation in the case of a frictional
+ !! surface:
+ !!
+ !! sigma^i = C:F:sigma
+ !!
+ !! where C is the elastic moduli tensor, F is the heterogeneous
+ !! fluidity moduli tensor and sigma is the instantaneous stress
+ !! tensor. for a frictional surface, the eigenstrain-rate is given
+ !! by
+ !!
+ !! epsilon^i^dot = F:sigma = gamma^dot R
+ !!
+ !! where gamma^dot is the slip rate (a scalar) and R is the
+ !! deviatoric, symmetric, and unitary, tensor:
+ !!
+ !! R_ij = 1/2 ( t_i n_j + t_j n_i ) / sqrt( t_j t_j )
+ !!
+ !! where the shear traction t_i is the projection of the traction
+ !! vector on the plane surface. the strain amplitude is given by
+ !!
+ !! gamma^dot = H( t_j r_j ) 2 vo sinh( taus / (t_c )
+ !!
+ !! where taus is the effective shear on the fault plane,
+ !!
+ !! taus = tau + mu*sigma
+ !!
+ !! where tau is the shear and sigma the normal stress. tau and sigma
+ !! assumed to be the co-seismic change only, not the absolute
+ !! stress. vo is a reference slip velocity, and t_c, the critical
+ !! stress, corresponds to (a-b)*sigma in the framework of rate-and-
+ !! state friction. the effective viscosity eta* and the fluidity
+ !!
+ !! eta* = tau / gamma^dot
+ !! fluidity = 1 / eta*
+ !!
+ !! are used to compute the optimal time-step. H( x ) is the
+ !! Heaviside function and r_i is the rake vector. I impose
+ !! gamma^dot to be zero is t_j r_j < 0. This constraint is
+ !! enforced to ensure that no back slip occurs on faults.
+ !!
+ !! \author sylvain barbot (07/24/07) - original form
+ !! (02/28/11) - add constraints on the direction
+ !! of afterslip
+ !-----------------------------------------------------------------
+ SUBROUTINE frictioneigenstress(x,y,z,L,W,strike,dip,rake,beta, &
+ sig,mu,structure,sx1,sx2,sx3,dx1,dx2,dx3,moment,maxwelltime,vel)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: mu,dx1,dx2,dx3,x,y,z,L,W,strike,dip,rake,beta
+ TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ TYPE(TENSOR), INTENT(INOUT), DIMENSION(sx1,sx2,sx3) :: moment
+ REAL*8, OPTIONAL, INTENT(INOUT) :: maxwelltime
+#ifdef ALIGN_DATA
+ REAL*4, INTENT(OUT), DIMENSION(sx1+2,sx2,sx3), OPTIONAL :: vel
+#else
+ REAL*4, INTENT(OUT), DIMENSION(sx1,sx2,sx3), OPTIONAL :: vel
+#endif
+
+ INTEGER :: i1,i2,i3
+ TYPE(TENSOR) :: s
+ REAL*8, DIMENSION(3) :: t,ts,n,r
+ REAL*8 :: vo,tauc,taun,taus,gammadot,impulse, &
+ friction,tau,scaling,cohesion
+ REAL*8 :: x1,x2,x3,x1s,x2s,x3s,x1i,x3i, &
+ cstrike,sstrike,cdip,sdip,cr,sr,x2r,&
+ temp1,temp2,temp3,sourc,image,xr,yr,zr,Wp,Lp,dum
+ REAL*4 :: tm
+
+ IF (PRESENT(maxwelltime)) THEN
+ tm=maxwelltime
+ ELSE
+ tm=1e30
+ END IF
+
+ ! delta function scaling
+ scaling=sqrt(pi2)*dx1
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+ cr=cos(rake)
+ sr=sin(rake)
+
+ ! effective tapered dimensions
+ Wp=W*(1._8+2._8*beta)/2._8
+ Lp=L*(1._8+2._8*beta)/2._8
+
+ ! rotate centre coordinates of source and images
+ x2r= cstrike*x -sstrike*y
+ xr = cdip *x2r-sdip *z
+ yr = sstrike*x +cstrike*y
+ zr = sdip *x2r+cdip *z
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike
+ n(2)=-cdip*sstrike
+ n(3)=-sdip
+
+ ! rake vector component
+ r(1)=sstrike*cr+cstrike*sdip*sr
+ r(2)=cstrike*cr-sstrike*sdip*sr
+ r(3)=cdip*sr
+
+ DO i3=1,sx3
+ x3=DBLE(i3-1)*dx3
+ IF ((abs(x3-z).gt.Lp) .and. (abs(x3+z).gt.Lp)) CYCLE
+
+ vo=structure(i3)%gammadot0
+ tauc=structure(i3)%stressexponent
+ friction=structure(i3)%friction
+ cohesion=structure(i3)%cohesion
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
+ dx1,dx2,dx3,x1,x2,dum)
+ IF ((ABS(x1-x).gt.MAX(Wp,Lp)) .OR. (ABS(x2-y).gt.MAX(Wp,Lp))) CYCLE
+
+ x2r= cstrike*x1-sstrike*x2
+ x1s= cdip*x2r-sdip*x3
+ x1i= cdip*x2r+sdip*x3
+ IF ((ABS(x1s-xr).GT.7.01_8*dx1).AND.(ABS(x1i-xr).GT.7.01_8*dx1)) CYCLE
+ x2s= sstrike*x1+cstrike*x2
+ x3s= sdip*x2r+cdip*x3
+ x3i=-sdip*x2r+cdip*x3
+
+ ! integrate at depth and along strike with raised cosine taper
+ ! and shift sources to x,y,z coordinate
+ temp1=gauss(x1s-xr,dx1)
+ temp2=omega((x2s-yr)/W,beta)
+ temp3=omega((x3s-zr)/L,beta)
+ sourc=temp1*temp2*temp3
+
+ temp1=gauss(x1i-xr,dx1)
+ temp3=omega((x3i+zr)/L,beta)
+ image=temp1*temp2*temp3
+
+ impulse=sourc+image
+
+ ! traction = sigma . n
+ s=sig(i1,i2,i3)
+ t=s .tdot. n
+
+ ! signed normal component
+ taun=SUM(t*n)
+
+ ! absolute value of shear component
+ ts=t-taun*n
+ taus=SQRT(SUM(ts*ts))
+
+ ! effective shear stress on fault plane
+ tau=MAX(0.d0,taus+friction*taun-cohesion)
+
+ ! rake direction test only if | rake | < 3*Pi
+ IF (SUM(ts*r).LT.0.d0 .AND. ABS(rake).LT.pi2*1.5d0) CYCLE
+
+ ! warning for wrong input
+ IF ((tau/tauc) .gt. 20) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("------------------------------------------")')
+ WRITE (0,'("wrong value of (a-b)sigma gives rise to")')
+ WRITE (0,'("(a - b) * sigma = ",ES11.3E2)') tauc
+ WRITE (0,'("tau = ",ES11.3E2)') tau
+ WRITE (0,'("tau_s = ",ES11.3E2)') taus
+ WRITE (0,'("tau_n = ",ES11.3E2)') taun
+ WRITE (0,'("tau / ((a - b) sigma) = ",ES11.3E2)') tau/tauc
+ WRITE (0,'("------------------------------------------")')
+ STOP 5
+ END IF
+
+ ! shear traction direction
+ ts=ts/taus
+
+ ! deviatoric strain rate
+ gammadot=vo*2._8*sinh(tau/tauc)
+
+ tm=MIN(tm,tau/mu/gammadot*(MIN(L,W)/sqrt(dx1*dx3)))
+
+ ! provide the strain-rate on request
+ IF (PRESENT(vel)) THEN
+ vel(i1,i2,i3)=vel(i1,i2,i3)+gammadot*impulse*scaling
+ END IF
+
+ ! deviatoric strain
+ moment(i1,i2,i3)=moment(i1,i2,i3) .plus. &
+ (ts .sdyad. ((2._8*mu*impulse*gammadot)*n))
+
+ END DO
+ END DO
+ END DO
+
+ IF (PRESENT(maxwelltime)) maxwelltime=MIN(tm,maxwelltime)
+
+ END SUBROUTINE frictioneigenstress
+
+ !---------------------------------------------------------------------
+ !> function MonitorFriction
+ !! samples a scalar field along a specified planar surface.
+ !!
+ !! input:
+ !! @param x,y,z coordinates of the creeping segment
+ !! @param L dimension of segment in the depth direction
+ !! @param W dimension of segment in the strike direction
+ !! @param beta smoothing factor
+ !! @param sx1,2,3 dimension of the stress tensor array
+ !! @param dx1,2,3 sampling size
+ !! @param sig stress tensor array
+ !! @param structure frictional properties as a function of depth
+ !!
+ !! output:
+ !! @param patch list of strike- and dip-slip as a function of position
+ !! on the fault.
+ !!
+ !! \author sylvain barbot (10-16-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE monitorfriction(x,y,z,L,W,strike,dip,rake,beta, &
+ sx1,sx2,sx3,dx1,dx2,dx3,sig,structure,patch)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: x,y,z,L,W,strike,rake,dip,beta,dx1,dx2,dx3
+ TYPE(TENSOR), DIMENSION(sx1,sx2,sx3), INTENT(IN) :: sig
+ TYPE(SLIPPATCH_STRUCT), ALLOCATABLE, DIMENSION(:,:), INTENT(INOUT) :: patch
+ TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
+
+ INTEGER :: i1,i2,i3,px2,px3,j2,j3,status
+ REAL*8 :: cstrike,sstrike,cdip,sdip,cr,sr
+ REAL*8 :: vo,tauc,taun,taus, &
+ friction,tau,cohesion
+ REAL*8 :: x1,x2,x3,xr,yr,zr
+ TYPE(TENSOR) :: s
+ REAL*8, DIMENSION(3) :: t,ts,n,sv,dv,r
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+ cr=cos(rake)
+ sr=sin(rake)
+
+ ! strike direction vector
+ sv=(/ sstrike, cstrike, 0._8 /)
+
+ ! dip direction vector
+ dv=(/ -cstrike*sdip, +sstrike*sdip, -cdip /)
+
+ ! number of samples in the dip and strike direction
+ px2=SIZE(patch,1)
+ px3=SIZE(patch,2)
+
+ ! surface normal vector components
+ n(1)=+cdip*cstrike
+ n(2)=-cdip*sstrike
+ n(3)=-sdip
+
+ ! rake vector component
+ r(1)=sstrike*cr+cstrike*sdip*sr
+ r(2)=cstrike*cr-sstrike*sdip*sr
+ r(3)=cdip*sr
+
+ ! loop in the dip direction
+ DO j3=1,px3
+ ! loop in the strike direction
+ DO j2=1,px2
+
+ CALL ref2local(x,y,z,xr,yr,zr)
+
+ ! no translation in out of plane direction
+ yr=REAL(yr)+REAL((DBLE(j2)-DBLE(px2)/2._8-1._8)*dx2)
+ zr=REAL(zr)+REAL((DBLE(j3)-DBLE(px3)/2._8-1._8)*dx3)
+
+ CALL local2ref(xr,yr,zr,x1,x2,x3)
+
+ ! initialize zero slip velocity
+ patch(j2,j3)=SLIPPATCH_STRUCT(x1,x2,x3,yr,zr,0._8,0._8,0._8, &
+ 0._8,0._8,0._8,0._8,s)
+
+ ! discard out-of-bound locations
+ IF ( (x1 .GT. DBLE(sx1/2-1)*dx1) .OR. (x1 .LT. -DBLE(sx1/2)*dx1) &
+ .OR. (x2 .GT. DBLE(sx2/2-1)*dx2) .OR. (x2 .LT. -DBLE(sx2/2)*dx2) &
+ .OR. (x3 .GT. DBLE(sx3-1)*dx3) .OR. (x3 .LT. 0._8) ) CYCLE
+
+ ! evaluates instantaneous creep velocity
+ CALL shiftedindex(x1,x2,x3,sx1,sx2,sx3,dx1,dx2,dx3,i1,i2,i3)
+
+ ! retrieve friction parameters
+ vo=structure(i3)%gammadot0
+ tauc=structure(i3)%stressexponent
+ friction=structure(i3)%friction
+ cohesion=structure(i3)%cohesion
+
+ ! traction = sigma . n
+ s=sig(i1,i2,i3)
+ t=s .tdot. n
+
+ ! signed normal component
+ taun=SUM(t*n)
+
+ ! absolute value of shear component
+ ts=t-taun*n
+ taus=SQRT(SUM(ts*ts))
+
+ ! effective shear stress on fault plane
+ tau=MAX(0.d0,taus+friction*taun-cohesion)
+
+ ! rake direction test only if | rake | < 3*Pi
+ IF (SUM(ts*r).LT.0.d0 .AND. ABS(rake).LT.pi2*1.5d0) CYCLE
+
+ ! shear stress
+ patch(j2,j3)%taus=taus
+
+ ! creep rate
+ patch(j2,j3)%slip=vo*2._8*sinh(tau/tauc)
+ patch(j2,j3)%v=vo*2._8*sinh(tau/tauc)
+
+ ! shear traction direction
+ ts=ts/taus
+
+ ! strike-direction creep rate
+ patch(j2,j3)%ss=patch(j2,j3)%slip*SUM(ts*sv)
+ patch(j2,j3)%vss=patch(j2,j3)%v*SUM(ts*sv)
+
+ ! dip-direction creep rate
+ patch(j2,j3)%ds=patch(j2,j3)%slip*SUM(ts*dv)
+ patch(j2,j3)%vds=patch(j2,j3)%v*SUM(ts*dv)
+
+ END DO
+ END DO
+
+ CONTAINS
+
+ !-----------------------------------------------
+ ! subroutine ref2local
+ ! convert reference Cartesian coordinates into
+ ! the rotated, local fault coordinates system.
+ !-----------------------------------------------
+ SUBROUTINE ref2local(x,y,z,xp,yp,zp)
+ REAL*8, INTENT(IN) :: x,y,z
+ REAL*8, INTENT(OUT) :: xp,yp,zp
+
+ REAL*8 :: x2
+
+ x2 = cstrike*x -sstrike*y
+ xp = cdip *x2 -sdip *z
+ yp = sstrike*x +cstrike*y
+ zp = sdip *x2 +cdip *z
+
+ END SUBROUTINE ref2local
+
+ !-----------------------------------------------
+ ! subroutine local2ref
+ ! converts a set of coordinates from the rotated
+ ! fault-aligned coordinate system into the
+ ! reference, Cartesian coordinates system.
+ !-----------------------------------------------
+ SUBROUTINE local2ref(xp,yp,zp,x,y,z)
+ REAL*8, INTENT(IN) :: xp,yp,zp
+ REAL*8, INTENT(OUT) :: x,y,z
+
+ REAL*8 :: x2p
+
+ x2p= cdip*xp+sdip*zp
+ x = cstrike*x2p+sstrike*yp
+ y = -sstrike*x2p+cstrike*yp
+ z = -sdip*xp +cdip*zp
+
+ END SUBROUTINE local2ref
+
+ END SUBROUTINE monitorfriction
+
+END MODULE friction3d
diff -r 405d8f4fa05f -r e7295294f654 src/getdata.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/getdata.f Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,30 @@
+ subroutine getdata(unit,line)
+ implicit none
+c
+c First implemented in Potsdam, Feb, 1999
+c Last modified: Potsdam, Nov, 2001, by R. Wang
+c
+ integer unit
+ character line*180,char*1
+c
+ integer i
+c
+c this subroutine reads over all comment lines starting with "#".
+c
+ char='#'
+100 continue
+ if(char.eq.'#')then
+ read(unit,'(a)')line
+ i=1
+ char=line(1:1)
+200 continue
+ if(char.eq.' ')then
+ i=i+1
+ char=line(i:i)
+ goto 200
+ endif
+ goto 100
+ endif
+c
+ return
+ end
diff -r 405d8f4fa05f -r e7295294f654 src/getopt_m.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/getopt_m.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,233 @@
+! ------------------------------------------------------------
+! Copyright 2008 by Mark Gates
+!
+! This program is free software; you can redistribute or modify it under
+! the terms of the GNU general public license (GPL), version 2 or later.
+!
+! 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.
+!
+! If you wish to incorporate this into non-GPL software, please contact
+! me regarding licensing terms.
+!
+! ------------------------------------------------------------
+! Fortran 95 getopt() and getopt_long(), similar to those in standard C library.
+!
+! ch = getopt( optstring, [longopts] )
+! Returns next option character from command line arguments.
+! If an option is not recognized, it returns '?'.
+! If no options are left, it returns a null character, char(0).
+!
+! optstring contains characters that are recognized as options.
+! If a character is followed by a colon, then it takes a required argument.
+! For example, "x" recognizes "-x", while "x:" recognizes "-x arg" or "-xarg".
+!
+! optopt is set to the option character, even if it isn't recognized.
+! optarg is set to the option's argument.
+! optind has the index of the next argument to process. Initially optind=1.
+! Errors are printed by default. Set opterr=.false. to suppress them.
+!
+! Grouped options are allowed, so "-abc" is the same as "-a -b -c".
+!
+! If longopts is present, it is an array of type(option_s), where each entry
+! describes one long option.
+!
+! type option_s
+! character(len=80) :: name
+! logical :: has_arg
+! character :: val
+! end type
+!
+! The name field is the option name, without the leading -- double dash.
+! Set the has_arg field to true if it requires an argument, false if not.
+! The val field is returned. Typically this is set to the corresponding short
+! option, so short and long options can be processed together. (But there
+! is no requirement that every long option has a short option, or vice-versa.)
+!
+! -----
+! EXAMPLE
+! program test
+! use getopt_m
+! implicit none
+! character:: ch
+! type(option_s):: opts(2)
+! opts(1) = option_s( "alpha", .false., 'a' )
+! opts(2) = option_s( "beta", .true., 'b' )
+! do
+! select case( getopt( "ab:c", opts ))
+! case( char(0))
+! exit
+! case( 'a' )
+! print *, 'option alpha/a'
+! case( 'b' )
+! print *, 'option beta/b=', optarg
+! case( '?' )
+! print *, 'unknown option ', optopt
+! stop
+! case default
+! print *, 'unhandled option ', optopt, ' (this is a bug)'
+! end select
+! end do
+! end program test
+!
+! Differences from C version:
+! - when options are finished, C version returns -1 instead of char(0),
+! and thus stupidly requires an int instead of a char.
+! - does not support optreset
+! - does not support "--" as last argument
+! - if no argument, optarg is blank, not NULL
+! - argc and argv are implicit
+!
+! Differences for long options:
+! - optional argument to getopt(), rather than separate function getopt_long()
+! - has_arg is logical, and does not support optional_argument
+! - does not support flag field (and thus always returns val)
+! - does not support longindex
+! - does not support "--opt=value" syntax, only "--opt value"
+! - knows the length of longopts, so does not need an empty last record
+
+module getopt_m
+ implicit none
+ character(len=80):: optarg
+ character:: optopt
+ integer:: optind=1
+ logical:: opterr=.true.
+
+ type option_s
+ character(len=80) :: name
+ logical :: has_arg
+ character :: val
+ end type
+
+ ! grpind is index of next option within group; always >= 2
+ integer, private:: grpind=2
+
+contains
+
+! ----------------------------------------
+! Return str(i:j) if 1 <= i <= j <= len(str),
+! else return empty string.
+! This is needed because Fortran standard allows but doesn't *require* short-circuited
+! logical AND and OR operators. So this sometimes fails:
+! if ( i < len(str) .and. str(i+1:i+1) == ':' ) then
+! but this works:
+! if ( substr(str, i+1, i+1) == ':' ) then
+
+character function substr( str, i, j )
+ ! arguments
+ character(len=*), intent(in):: str
+ integer, intent(in):: i, j
+
+ if ( 1 <= i .and. i <= j .and. j <= len(str)) then
+ substr = str(i:j)
+ else
+ substr = ''
+ endif
+end function substr
+
+
+! ----------------------------------------
+character function getopt( optstring, longopts )
+ ! arguments
+ character(len=*), intent(in):: optstring
+ type(option_s), intent(in), optional:: longopts(:)
+
+ ! local variables
+ character(len=80):: arg
+
+ optarg = ''
+ if ( optind > iargc()) then
+ getopt = char(0)
+ endif
+
+ call getarg( optind, arg )
+ if ( present( longopts ) .and. arg(1:2) == '--' ) then
+ getopt = process_long( longopts, arg )
+ elseif ( arg(1:1) == '-' ) then
+ getopt = process_short( optstring, arg )
+ else
+ getopt = char(0)
+ endif
+end function getopt
+
+
+! ----------------------------------------
+character function process_long( longopts, arg )
+ ! arguments
+ type(option_s), intent(in):: longopts(:)
+ character(len=*), intent(in):: arg
+
+ ! local variables
+ integer:: i
+
+ ! search for matching long option
+ optind = optind + 1
+ do i = 1, size(longopts)
+ if ( arg(3:) == longopts(i)%name ) then
+ optopt = longopts(i)%val
+ process_long = optopt
+ if ( longopts(i)%has_arg ) then
+ if ( optind <= iargc()) then
+ call getarg( optind, optarg )
+ optind = optind + 1
+ elseif ( opterr ) then
+ WRITE (0,'(a,a,a)') "error: option '", trim(arg), "' requires an argument"
+ endif
+ endif
+ return
+ endif
+ end do
+ ! else not found
+ process_long = '?'
+ if ( opterr ) then
+ WRITE (0,'(a,a,a)'), "error: unrecognized option '", trim(arg), "'"
+ endif
+end function process_long
+
+
+! ----------------------------------------
+character function process_short( optstring, arg )
+ ! arguments
+ character(len=*), intent(in):: optstring, arg
+
+ ! local variables
+ integer:: i, arglen
+
+ arglen = len( trim( arg ))
+ optopt = arg(grpind:grpind)
+ process_short = optopt
+
+ i = index( optstring, optopt )
+ if ( i == 0 ) then
+ ! unrecognized option
+ process_short = '?'
+ if ( opterr ) then
+ print '(a,a,a)', "Error: unrecognized option '-", optopt, "'"
+ endif
+ endif
+ if ( i > 0 .and. substr( optstring, i+1, i+1 ) == ':' ) then
+ ! required argument
+ optind = optind + 1
+ if ( arglen > grpind ) then
+ ! -xarg, return remainder of arg
+ optarg = arg(grpind+1:arglen)
+ elseif ( optind <= iargc()) then
+ ! -x arg, return next arg
+ call getarg( optind, optarg )
+ optind = optind + 1
+ elseif ( opterr ) then
+ WRITE (0,'(a,a,a)') "error: option '-", optopt, "' requires an argument"
+ endif
+ grpind = 2
+ elseif ( arglen > grpind ) then
+ ! no argument (or unrecognized), go to next option in argument (-xyz)
+ grpind = grpind + 1
+ else
+ ! no argument (or unrecognized), go to next argument
+ grpind = 2
+ optind = optind + 1
+ endif
+end function process_short
+
+end module getopt_m
diff -r 405d8f4fa05f -r e7295294f654 src/green.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/green.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,953 @@
+!-----------------------------------------------------------------------
+! Copyright 2007, 2008, 2009 Sylvain Barbot
+!
+! This file is part of RELAX
+!
+! RELAX 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 3 of the License, or
+! (at your option) any later version.
+!
+! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
+!-----------------------------------------------------------------------
+
+MODULE green
+
+ USE fourier
+
+ IMPLICIT NONE
+
+#include "include.f90"
+
+ PUBLIC
+ REAL*8, PRIVATE, PARAMETER :: pi = 3.141592653589793115997963468544185161_8
+ REAL*8, PRIVATE, PARAMETER :: pi2 = 6.28318530717958623199592693708837032318_8
+ REAL*8, PRIVATE, PARAMETER :: pid2 = 1.57079632679489655799898173427209258079_8
+
+ INTEGER, PARAMETER :: GRN_IMAGE=1,GRN_HS=0
+
+CONTAINS
+
+ !------------------------------------------------------------------------
+ !> Subroutine ElasticResponse
+ !! apply the 2d elastic (half-space) transfert function
+ !! to the set of body forces.
+ !!
+ !! INPUT:
+ !! @param mu shear modulus
+ !! @param f1,2,3 equivalent body-forces in the Fourier domain
+ !! @param dx1,2,3 sampling size
+ !!
+ !! \author sylvain barbot (04/14/07) - original form
+ !! (02/06/09) - parallel implementation with MPI and OpenMP
+ !! (01/06/11) - remove implementation with MPI
+ !------------------------------------------------------------------------
+ SUBROUTINE elasticresponse(lambda,mu,f1,f2,f3,dx1,dx2,dx3)
+ REAL*8, INTENT(IN) :: lambda,mu,dx1,dx2,dx3
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: f1,f2,f3
+
+ REAL*8 :: k1,k2,k3,denom,r2,ratio1,ratio2
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3,ubound3
+ COMPLEX(kind=8) :: buf1,buf2,buf3,c1,c2,c3
+
+ sx1=SIZE(f2,1)-2
+ sx2=SIZE(f2,2)
+ sx3=SIZE(f2,3)
+
+ ratio1=(lambda+mu)/(lambda+2._8*mu)/mu/(pi2**2._8)
+ ratio2=mu/(lambda+mu)
+
+ ubound3=sx3
+
+ ! serial computation
+!$omp parallel do private(i1,i2,k1,k2,k3,r2,denom,c1,c2,c3,buf1,buf2,buf3)
+ DO i3=1,ubound3
+ CALL wavenumber3(i3,sx3,dx3,k3)
+ DO i2=1,sx2
+ CALL wavenumber2(i2,sx2,dx2,k2)
+ DO i1=1,sx1/2+1
+ CALL wavenumber1(i1,sx1,dx1,k1)
+
+ r2=k1**2._8+k2**2._8+k3**2._8
+ denom=ratio1/r2**2
+
+ c1=CMPLX(f1(2*i1-1,i2,i3),f1(2*i1,i2,i3),8)
+ c2=CMPLX(f2(2*i1-1,i2,i3),f2(2*i1,i2,i3),8)
+ c3=CMPLX(f3(2*i1-1,i2,i3),f3(2*i1,i2,i3),8)
+
+ buf1=((k2**2._8+k3**2._8+ratio2*r2)*c1-k1*(k2*c2+k3*c3))*denom
+ buf2=((k1**2._8+k3**2._8+ratio2*r2)*c2-k2*(k1*c1+k3*c3))*denom
+ buf3=((k1**2._8+k2**2._8+ratio2*r2)*c3-k3*(k1*c1+k2*c2))*denom
+
+ f1(2*i1-1:2*i1,i2,i3)=REAL((/ REAL(buf1),AIMAG(buf1) /))
+ f2(2*i1-1:2*i1,i2,i3)=REAL((/ REAL(buf2),AIMAG(buf2) /))
+ f3(2*i1-1:2*i1,i2,i3)=REAL((/ REAL(buf3),AIMAG(buf3) /))
+ END DO
+ END DO
+ END DO
+!$omp end parallel do
+
+ ! zero wavenumber, no net body-force
+ f1(1:2,1,1)=(/ 0._4, 0._4 /)
+ f2(1:2,1,1)=(/ 0._4, 0._4 /)
+ f3(1:2,1,1)=(/ 0._4, 0._4 /)
+
+ END SUBROUTINE elasticresponse
+
+ !---------------------------------------------------------------------
+ !> subroutine SurfaceNormalTraction
+ !! computes the two-dimensional field of surface normal stress
+ !! expressed in the Fourier domain.
+ !! The surface (x3=0) solution is obtained by integrating over the
+ !! wavenumbers in 3-direction in the Fourier domain.
+ !!
+ !! \author sylvain barbot (05-01-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE surfacenormaltraction(lambda, mu, u1, u2, u3, dx1, dx2, dx3, p)
+ REAL*4, INTENT(IN), DIMENSION(:,:,:) :: u1, u2, u3
+ REAL*8, INTENT(IN) :: lambda, mu, dx1, dx2, dx3
+ REAL*4, INTENT(OUT), DIMENSION(:,:) :: p
+
+ INTEGER :: i1, i2, i3, sx1, sx2, sx3
+ REAL*8 :: k1, k2, k3, modulus
+ COMPLEX*8, PARAMETER :: i = CMPLX(0._8,pi2)
+ COMPLEX*8 :: sum, c1, c2, c3
+
+ sx1=SIZE(u1,1)-2
+ sx2=SIZE(u1,2)
+ sx3=SIZE(u1,3)
+
+ modulus=lambda+2*mu
+
+ p=0
+ DO i3=1,sx3
+ DO i2=1,sx2
+ DO i1=1,sx1/2+1
+ CALL wavenumbers(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,k1,k2,k3)
+
+ c1=CMPLX(u1(2*i1-1,i2,i3),u1(2*i1,i2,i3))
+ c2=CMPLX(u2(2*i1-1,i2,i3),u2(2*i1,i2,i3))
+ c3=CMPLX(u3(2*i1-1,i2,i3),u3(2*i1,i2,i3))
+
+ sum=i*(modulus*k3*c3+lambda*(k1*c1+k2*c2))
+
+ p(2*i1-1,i2)=p(2*i1-1,i2)+REAL( REAL(sum))
+ p(2*i1 ,i2)=p(2*i1 ,i2)+REAL(AIMAG(sum))
+ END DO
+ END DO
+ END DO
+ p=p/(sx3*dx3)
+
+ END SUBROUTINE surfacenormaltraction
+
+ !---------------------------------------------------------------------
+ !> subroutine Boussinesq3D
+ !! computes the deformation field in the 3-dimensional grid
+ !! due to a normal stress at the surface. Apply the Fourier domain
+ !! solution of Steketee [1958].
+ !---------------------------------------------------------------------
+ SUBROUTINE boussinesq3d(p,lambda,mu,u1,u2,u3,dx1,dx2,dx3)
+ REAL*4, DIMENSION(:,:), INTENT(IN) :: p
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: u1, u2, u3
+ REAL*8, INTENT(IN) :: lambda, mu, dx1, dx2, dx3
+
+ INTEGER :: i1, i2, i3, sx1, sx2, sx3, status
+ REAL*8 :: k1, k2, k3, x3, alpha
+ COMPLEX, ALLOCATABLE, DIMENSION(:) :: b1, b2, b3
+ COMPLEX :: load
+
+ sx1=SIZE(u1,1)-2
+ sx2=SIZE(u1,2)
+ sx3=SIZE(u1,3)
+
+ ALLOCATE(b1(sx3),b2(sx3),b3(sx3),STAT=status)
+ IF (0/=status) STOP "could not allocate arrays for Boussinesq3D"
+
+ alpha=(lambda+mu)/(lambda+2*mu)
+
+ DO i2=1,sx2
+ DO i1=1,sx1/2+1
+ CALL wavenumbers(i1,i2,1,sx1,sx2,1,dx1,dx2,1._8,k1,k2,k3)
+ load=CMPLX(p(2*i1-1,i2),p(2*i1,i2))
+ DO i3=1,sx3
+ IF (i3<=sx3/2) THEN
+ x3=DBLE(i3-1)*dx3
+ ELSE
+ x3=ABS(DBLE(i3-sx3-1)*dx3)
+ END IF
+ CALL steketeesolution(load,alpha,b1(i3),b2(i3),b3(i3),k1,k2,x3)
+ END DO
+
+ ! transforms the Steketee solution into a full 3-dimensional
+ ! Fourier transform by 1d transforming in the 3-direction
+ CALL fft1(b1,sx3,dx3,FFT_FORWARD)
+ CALL fft1(b2,sx3,dx3,FFT_FORWARD)
+ CALL fft1(b3,sx3,dx3,FFT_FORWARD)
+
+ ! add the Boussinesq contribution to the deformation field
+ DO i3=1,sx3
+ u1(2*i1-1:2*i1,i2,i3)=u1(2*i1-1:2*i1,i2,i3)+ &
+ (/REAL(b1(i3)),AIMAG(b1(i3))/)
+ u2(2*i1-1:2*i1,i2,i3)=u2(2*i1-1:2*i1,i2,i3)+ &
+ (/REAL(b2(i3)),AIMAG(b2(i3))/)
+ u3(2*i1-1:2*i1,i2,i3)=u3(2*i1-1:2*i1,i2,i3)+ &
+ (/REAL(b3(i3)),AIMAG(b3(i3))/)
+ END DO
+ END DO
+ END DO
+
+ DEALLOCATE(b1,b2,b3)
+
+ CONTAINS
+ !-----------------------------------------------------------------
+ !> subroutine SteketeeSolution
+ !! computes the spectrum (two-dimensional Fourier transform)
+ !! of the 3 components of the deformation field u1, u2, u3
+ !! at wavenumbers k1, k2 and position x3. This is the analytical
+ !! solution of [J. A. Steketee, On Volterra's dislocations in a
+ !! semi-infinite elastic medium, Canadian Journal of Physics, 1958]
+ !!
+ !! \author sylvain barbot (05-02-07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE steketeesolution(p,alpha,u1,u2,u3,k1,k2,x3)
+ COMPLEX, INTENT(INOUT) :: u1, u2, u3
+ REAL*8, INTENT(IN) :: alpha, k1, k2, x3
+ COMPLEX, INTENT(IN) :: p
+
+ REAL*8 :: beta, depthdecay
+ COMPLEX, PARAMETER :: i=CMPLX(0,1)
+ COMPLEX :: b
+
+ beta=pi2*sqrt(k1**2._8+k2**2._8)
+ depthdecay=exp(-beta*abs(x3))
+
+ IF (0==k1 .AND. 0==k2) THEN
+ u1=CMPLX(0.,0.)
+ u2=CMPLX(0.,0.)
+ u3=CMPLX(0.,0.)
+ ELSE
+ b=p/(2._8*mu*alpha*beta**3._8)
+ u1=i*alpha*pi2*beta*b*(1._8-1._8/alpha+beta*x3)*depthdecay
+ u2=u1
+ u1=u1*k1
+ u2=u2*k2
+ u3=-p/(2*mu*beta)*(1._8/alpha+beta*x3)*depthdecay
+ END IF
+
+ END SUBROUTINE steketeesolution
+
+ END SUBROUTINE boussinesq3d
+
+ !---------------------------------------------------------------------
+ !> subroutine SurfaceTraction
+ !! computes the two-dimensional field of surface normal stress
+ !! expressed in the Fourier domain.
+ !! The surface (x3=0) solution is obtained by integrating over the
+ !! wavenumbers in 3-direction in the Fourier domain.
+ !!
+ !! \author sylvain barbot (07-07-07) - original form
+ ! (02-09-09) - parallelized with mpi and openmp
+ !---------------------------------------------------------------------
+ SUBROUTINE surfacetraction(lambda,mu,u1,u2,u3,dx1,dx2,dx3,p1,p2,p3)
+ REAL*4, INTENT(IN), DIMENSION(:,:,:) :: u1,u2,u3
+ REAL*8, INTENT(IN) :: lambda,mu,dx1,dx2,dx3
+ REAL*4, INTENT(OUT), DIMENSION(:,:) :: p1,p2,p3
+
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3
+ REAL*8 :: k1,k2,k3,modulus
+ COMPLEX(KIND=8), PARAMETER :: i=CMPLX(0._8,pi2,8)
+ COMPLEX(KIND=8) :: sum1,sum2,sum3,c1,c2,c3
+
+ sx1=SIZE(u1,1)-2
+ sx2=SIZE(u1,2)
+ sx3=SIZE(u1,3)
+
+ modulus=lambda+2._8*mu
+
+ p1=0
+ p2=0
+ p3=0
+
+!$omp parallel do private(i1,i2,k1,k2,k3,c1,c2,c3,sum1,sum2,sum3), &
+!$omp reduction(+:p1,p2,p3)
+ DO i3=1,sx3
+ DO i2=1,sx2
+ DO i1=1,sx1/2+1
+ CALL wavenumbers(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,k1,k2,k3)
+
+ c1=CMPLX(u1(2*i1-1,i2,i3),u1(2*i1,i2,i3),8)
+ c2=CMPLX(u2(2*i1-1,i2,i3),u2(2*i1,i2,i3),8)
+ c3=CMPLX(u3(2*i1-1,i2,i3),u3(2*i1,i2,i3),8)
+
+ sum1=i*mu*(k3*c1+k1*c3)
+ sum2=i*mu*(k3*c2+k2*c3)
+ sum3=i*(modulus*k3*c3+lambda*(k1*c1+k2*c2))
+
+ p1(2*i1-1:2*i1,i2)=p1(2*i1-1:2*i1,i2) &
+ +(/REAL(REAL(sum1)),REAL(AIMAG(sum1))/)
+ p2(2*i1-1:2*i1,i2)=p2(2*i1-1:2*i1,i2) &
+ +(/REAL(REAL(sum2)),REAL(AIMAG(sum2))/)
+ p3(2*i1-1:2*i1,i2)=p3(2*i1-1:2*i1,i2) &
+ +(/REAL(REAL(sum3)),REAL(AIMAG(sum3))/)
+
+ END DO
+ END DO
+ END DO
+!$omp end parallel do
+
+ p1=p1/(sx3*dx3)
+ p2=p2/(sx3*dx3)
+ p3=p3/(sx3*dx3)
+
+ END SUBROUTINE surfacetraction
+
+ !---------------------------------------------------------------------
+ !> subroutine SurfaceTractionCowling
+ !! computes the two-dimensional field of the resulting traction
+ !! expressed in the Fourier domain in the presence of gravity.
+ !!
+ !! The surface solution (x3=0) is obtained from the Fourier domain
+ !! array by integrating over the wavenumbers in 3-direction.
+ !!
+ !! The effective traction at x3=0 is
+ !!
+ !! t_1 = sigma_13
+ !! t_2 = sigma_23
+ !! t_3 = sigma_33 - r g u3
+ !! = sigma_33 - 2 mu alpha gamma u3
+ !!
+ !! \author sylvain barbot (07-07-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE surfacetractioncowling(lambda,mu,gamma,u1,u2,u3,dx1,dx2,dx3, &
+ p1,p2,p3)
+ REAL*4, INTENT(IN), DIMENSION(:,:,:) :: u1,u2,u3
+ REAL*8, INTENT(IN) :: lambda,mu,gamma,dx1,dx2,dx3
+ REAL*4, INTENT(OUT), DIMENSION(:,:) :: p1,p2,p3
+
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3
+ REAL*8 :: k1,k2,k3,modulus,alpha,grav
+ COMPLEX*8, PARAMETER :: i=CMPLX(0._8,pi2)
+ COMPLEX*8 :: sum1,sum2,sum3,c1,c2,c3
+
+ sx1=SIZE(u1,1)-2
+ sx2=SIZE(u1,2)
+ sx3=SIZE(u1,3)
+
+ modulus=lambda+2._8*mu
+ alpha=(lambda+mu)/(lambda+2._8*mu)
+ grav=2._8*mu*alpha*gamma
+
+ p1=0
+ p2=0
+ p3=0
+
+!$omp parallel do private(i1,i3,k1,k2,k3,c1,c2,c3,sum1,sum2,sum3)
+!!!$omp reduction(+:p1,p2,p3)
+ DO i2=1,sx2
+ DO i3=1,sx3
+ DO i1=1,sx1/2+1
+ CALL wavenumbers(i1,i2,i3,sx1,sx2,sx3,dx1,dx2,dx3,k1,k2,k3)
+
+ c1=CMPLX(u1(2*i1-1,i2,i3),u1(2*i1,i2,i3))
+ c2=CMPLX(u2(2*i1-1,i2,i3),u2(2*i1,i2,i3))
+ c3=CMPLX(u3(2*i1-1,i2,i3),u3(2*i1,i2,i3))
+
+ sum1=i*mu*(k3*c1+k1*c3)
+ sum2=i*mu*(k3*c2+k2*c3)
+ sum3=i*(modulus*k3*c3+lambda*(k1*c1+k2*c2))-grav*c3
+
+ p1(2*i1-1:2*i1,i2)=p1(2*i1-1:2*i1,i2)+(/REAL(sum1),AIMAG(sum1)/)
+ p2(2*i1-1:2*i1,i2)=p2(2*i1-1:2*i1,i2)+(/REAL(sum2),AIMAG(sum2)/)
+ p3(2*i1-1:2*i1,i2)=p3(2*i1-1:2*i1,i2)+(/REAL(sum3),AIMAG(sum3)/)
+ END DO
+ END DO
+ END DO
+!$omp end parallel do
+
+ p1=p1/(sx3*dx3)
+ p2=p2/(sx3*dx3)
+ p3=p3/(sx3*dx3)
+
+ END SUBROUTINE surfacetractioncowling
+
+ !---------------------------------------------------------------------
+ !> subroutine Cerruti3D
+ !! computes the deformation field in the 3-dimensional grid
+ !! due to an arbitrary surface traction.
+ !!
+ !! \author sylvain barbot (07/07/07) - original form
+ ! (02/01/09) - parallelized with MPI and OpenMP
+ ! (01/06/11) - remove parallelized version with MPI
+ !---------------------------------------------------------------------
+ SUBROUTINE cerruti3d(p1,p2,p3,lambda,mu,u1,u2,u3,dx1,dx2,dx3)
+ REAL*4, DIMENSION(:,:), INTENT(IN) :: p1,p2,p3
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: u1,u2,u3
+ REAL*8, INTENT(IN) :: lambda,mu,dx1,dx2,dx3
+
+ INTEGER :: i1,i2,i3,ib,sx1,sx2,sx3,iostatus,buffersize
+ REAL*8 :: k1,k2,k3,x3,alpha
+ COMPLEX(KIND=4) :: t1,t2,t3
+ INTEGER, PARAMETER :: stride=64
+ COMPLEX(KIND=4), ALLOCATABLE, DIMENSION(:,:) :: b1,b2,b3
+
+ sx1=SIZE(u1,1)-2
+ sx2=SIZE(u1,2)
+ sx3=SIZE(u1,3)
+
+ alpha=(lambda+mu)/(lambda+2*mu)
+
+ ! serial programmation implementation
+!$omp parallel private(b1,b2,b3,iostatus)
+
+ ALLOCATE(b1(sx3,stride),b2(sx3,stride),b3(sx3,stride),STAT=iostatus)
+ IF (0/=iostatus) STOP "could not allocate arrays for Cerruti3D"
+
+!$omp do private(i1,i3,ib,k1,k2,k3,t1,t2,t3,x3,buffersize)
+ DO i2=1,sx2
+ DO i1=1,sx1/2+1,stride
+
+ ! buffer results
+ IF (i1+stride-1 .GT. sx1/2+1) THEN
+ buffersize=sx1/2+1-i1+1
+ ELSE
+ buffersize=stride
+ END IF
+
+ DO ib=0,buffersize-1
+
+ CALL wavenumbers(i1+ib,i2,1,sx1,sx2,1,dx1,dx2,1._8,k1,k2,k3)
+ t1=CMPLX(p1(2*(i1+ib)-1,i2),p1(2*(i1+ib),i2),4)
+ t2=CMPLX(p2(2*(i1+ib)-1,i2),p2(2*(i1+ib),i2),4)
+ t3=CMPLX(p3(2*(i1+ib)-1,i2),p3(2*(i1+ib),i2),4)
+
+ DO i3=1,sx3
+ IF (i3<=sx3/2) THEN
+ x3=DBLE(i3-1)*dx3
+ ELSE
+ x3=ABS(DBLE(i3-sx3-1)*dx3)
+ END IF
+ CALL cerrutisolution(mu,t1,t2,t3,alpha,b1(i3,ib+1),b2(i3,ib+1),b3(i3,ib+1),k1,k2,x3)
+ END DO
+
+ ! transforms the Cerruti solution into a full 3-dimensional
+ ! Fourier transform by 1d transforming in the 3-direction
+ CALL fft1(b1(:,ib+1),sx3,dx3,FFT_FORWARD)
+ CALL fft1(b2(:,ib+1),sx3,dx3,FFT_FORWARD)
+ CALL fft1(b3(:,ib+1),sx3,dx3,FFT_FORWARD)
+
+ END DO
+
+ ! update solution displacement
+ DO i3=1,sx3
+ DO ib=0,buffersize-1
+ u1(2*(i1+ib)-1,i2,i3)=u1(2*(i1+ib)-1,i2,i3)+REAL( REAL(b1(i3,ib+1)))
+ u1(2*(i1+ib) ,i2,i3)=u1(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b1(i3,ib+1)))
+ u2(2*(i1+ib)-1,i2,i3)=u2(2*(i1+ib)-1,i2,i3)+REAL( REAL(b2(i3,ib+1)))
+ u2(2*(i1+ib) ,i2,i3)=u2(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b2(i3,ib+1)))
+ u3(2*(i1+ib)-1,i2,i3)=u3(2*(i1+ib)-1,i2,i3)+REAL( REAL(b3(i3,ib+1)))
+ u3(2*(i1+ib) ,i2,i3)=u3(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b3(i3,ib+1)))
+ END DO
+ END DO
+
+ END DO
+ END DO
+
+ DEALLOCATE(b1,b2,b3)
+!$omp end parallel
+
+ CONTAINS
+ !-----------------------------------------------------------------
+ !> subroutine CerrutiSolution
+ !! computes the general solution for the deformation field in an
+ !! elastic half-space due to an arbitrary surface traction.
+ !! the 3 components u1, u2, u3 of the deformation field are
+ !! expressed in the horizontal Fourier at depth x3.
+ !! this combines the solution to the Boussinesq's and the Cerruti's
+ !! problem in a half-space.
+ !!
+ !! \author sylvain barbot (07-07-07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE cerrutisolution(mu,p1,p2,p3,alpha,u1,u2,u3,k1,k2,x3)
+ COMPLEX(KIND=4), INTENT(INOUT) :: u1,u2,u3
+ REAL*8, INTENT(IN) :: mu,alpha,k1,k2,x3
+ COMPLEX(KIND=4), INTENT(IN) :: p1,p2,p3
+
+ REAL*8 :: beta, depthdecay
+ COMPLEX(KIND=8), PARAMETER :: i=CMPLX(0._8,pi2,8)
+ REAL*8 :: temp
+ COMPLEX(KIND=8) :: b1,b2,b3,tmp,v1,v2,v3
+
+ beta=pi2*sqrt(k1**2+k2**2)
+ depthdecay=exp(-beta*abs(x3))
+
+ IF (0==k1 .AND. 0==k2) THEN
+ u1=CMPLX(0._4,0._4,4)
+ u2=CMPLX(0._4,0._4,4)
+ u3=CMPLX(0._4,0._4,4)
+ ELSE
+ temp=1._8/(2._8*mu*beta**3)*depthdecay
+ b1=temp*p1
+ b2=temp*p2
+ b3=temp*p3
+
+ ! b3 contribution
+ tmp=i*b3*(beta*(1._8-1._8/alpha+beta*x3))
+ v1=tmp*k1
+ v2=tmp*k2
+ v3=-beta**2*b3*(1._8/alpha+beta*x3)
+
+ ! b1 contribution
+ temp=pi2**2*(2._8-1._8/alpha+beta*x3)
+ v1=v1+b1*(-2._8*beta**2+k1**2*temp)
+ v2=v2+b1*k1*k2*temp
+ v3=v3+b1*i*k1*beta*(1._8/alpha-1._8+beta*x3)
+
+ ! b2 contribution & switch to single-precision
+ u1=v1+b2*k1*k2*temp
+ u2=v2+b2*(-2._8*beta**2+k2**2*temp)
+ u3=v3+b2*i*k2*beta*(1._8/alpha-1._8+beta*x3)
+ END IF
+
+ END SUBROUTINE cerrutisolution
+ END SUBROUTINE cerruti3d
+
+ !---------------------------------------------------------------------
+ !> subroutine CerrutiCowling
+ !! computes the deformation field in the 3-dimensional grid
+ !! due to an arbitrary surface traction.
+ !!
+ !! \author sylvain barbot - (07/07/07) - original form
+ !! (21/11/08) - gravity effect
+ !! (02/01/09) - parallelized with MPI and OpenMP
+ !! (01/06/11) - remove parallelized version with MPI
+ !---------------------------------------------------------------------
+ SUBROUTINE cerruticowling(p1,p2,p3,lambda,mu,gamma,u1,u2,u3,dx1,dx2,dx3)
+ REAL*4, DIMENSION(:,:), INTENT(IN) :: p1,p2,p3
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: u1,u2,u3
+ REAL*8, INTENT(IN) :: lambda,mu,gamma,dx1,dx2,dx3
+
+ INTEGER :: i1,i2,i3,ib,sx1,sx2,sx3,iostatus,buffersize
+ REAL*8 :: k1,k2,k3,x3,alpha
+ COMPLEX(KIND=4) :: t1,t2,t3
+ INTEGER, PARAMETER :: stride=64
+ COMPLEX(KIND=4), ALLOCATABLE, DIMENSION(:,:) :: b1,b2,b3
+
+ sx1=SIZE(u1,1)-2
+ sx2=SIZE(u1,2)
+ sx3=SIZE(u1,3)
+
+ alpha=(lambda+mu)/(lambda+2*mu)
+
+ ! serial programmation implementation
+!$omp parallel private(b1,b2,b3,iostatus)
+
+ ALLOCATE(b1(sx3,stride),b2(sx3,stride),b3(sx3,stride),STAT=iostatus)
+ IF (0/=iostatus) STOP "could not allocate arrays for Cerruti3D"
+
+!$omp do private(i1,i3,ib,k1,k2,k3,t1,t2,t3,x3,buffersize)
+ DO i2=1,sx2
+ DO i1=1,sx1/2+1,stride
+
+ ! buffer results
+ IF (i1+stride-1 .GT. sx1/2+1) THEN
+ buffersize=sx1/2+1-i1+1
+ ELSE
+ buffersize=stride
+ END IF
+
+ DO ib=0,buffersize-1
+
+ CALL wavenumbers(i1+ib,i2,1,sx1,sx2,1,dx1,dx2,1._8,k1,k2,k3)
+ t1=CMPLX(p1(2*(i1+ib)-1,i2),p1(2*(i1+ib),i2),4)
+ t2=CMPLX(p2(2*(i1+ib)-1,i2),p2(2*(i1+ib),i2),4)
+ t3=CMPLX(p3(2*(i1+ib)-1,i2),p3(2*(i1+ib),i2),4)
+
+ DO i3=1,sx3
+ IF (i3<=sx3/2) THEN
+ x3=DBLE(i3-1)*dx3
+ ELSE
+ x3=ABS(DBLE(i3-sx3-1)*dx3)
+ END IF
+ CALL cerrutisolcowling(mu,t1,t2,t3,alpha,gamma, &
+ b1(i3,ib+1),b2(i3,ib+1),b3(i3,ib+1),k1,k2,x3,DBLE(sx3/2)*dx3)
+ END DO
+
+ ! transforms the Cerruti solution into a full 3-dimensional
+ ! Fourier transform by 1d transforming in the 3-direction
+ CALL fft1(b1(:,ib+1),sx3,dx3,FFT_FORWARD)
+ CALL fft1(b2(:,ib+1),sx3,dx3,FFT_FORWARD)
+ CALL fft1(b3(:,ib+1),sx3,dx3,FFT_FORWARD)
+
+ END DO
+
+ ! update solution displacement
+ DO i3=1,sx3
+ DO ib=0,buffersize-1
+ u1(2*(i1+ib)-1,i2,i3)=u1(2*(i1+ib)-1,i2,i3)+REAL( REAL(b1(i3,ib+1)))
+ u1(2*(i1+ib) ,i2,i3)=u1(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b1(i3,ib+1)))
+ u2(2*(i1+ib)-1,i2,i3)=u2(2*(i1+ib)-1,i2,i3)+REAL( REAL(b2(i3,ib+1)))
+ u2(2*(i1+ib) ,i2,i3)=u2(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b2(i3,ib+1)))
+ u3(2*(i1+ib)-1,i2,i3)=u3(2*(i1+ib)-1,i2,i3)+REAL( REAL(b3(i3,ib+1)))
+ u3(2*(i1+ib) ,i2,i3)=u3(2*(i1+ib) ,i2,i3)+REAL(AIMAG(b3(i3,ib+1)))
+ END DO
+ END DO
+
+ END DO
+ END DO
+
+ DEALLOCATE(b1,b2,b3)
+!$omp end parallel
+
+ CONTAINS
+
+ !-----------------------------------------------------------------
+ !> subroutine CerrutiSolCowling
+ !! computes the general solution for the deformation field in an
+ !! elastic half-space due to an arbitrary surface traction in the
+ !! presence of gravity.
+ !!
+ !! The 3 components u1, u2 and u3 of the deformation field are
+ !! expressed in the horizontal Fourier at depth x3.
+ !!
+ !! Combines the solution to the Boussinesq's and the Cerruti's
+ !! problem in a half-space with buoyancy boundary conditions.
+ !
+ ! sylvain barbot (07-07-07) - original form
+ ! (08-30-10) - account for net surface traction
+ !-----------------------------------------------------------------
+ SUBROUTINE cerrutisolcowling(mu,p1,p2,p3,alpha,gamma,u1,u2,u3,k1,k2,x3,L)
+ COMPLEX(KIND=4), INTENT(INOUT) :: u1,u2,u3
+ REAL*8, INTENT(IN) :: mu,alpha,gamma,k1,k2,x3,L
+ COMPLEX(KIND=4), INTENT(IN) :: p1,p2,p3
+
+ REAL*8 :: beta, depthdecay, h
+ COMPLEX(KIND=8), PARAMETER :: i=CMPLX(0._8,pi2)
+ REAL*8 :: temp
+ COMPLEX(KIND=8) :: b1,b2,b3,tmp,v1,v2,v3
+
+ beta=pi2*sqrt(k1**2+k2**2)
+ depthdecay=exp(-beta*abs(x3))
+ h=gamma/beta
+
+ IF (0==k1 .AND. 0==k2) THEN
+ ! the 1/3 ratio is ad hoc
+ u1=CMPLX(REAL(+p1/mu*(x3-L)/3.d0),0._4)
+ u2=CMPLX(REAL(+p2/mu*(x3-L)/3.d0),0._4)
+ u3=CMPLX(REAL(+p3/mu*(x3-L)*(alpha-1.d0)/(1.d0+2.d0*L*alpha*gamma*(1.d0-alpha))/3.d0),0._4)
+ !u1=CMPLX(0._4,0._4)
+ !u2=CMPLX(0._4,0._4)
+ !u3=CMPLX(0._4,0._4)
+ ELSE
+ temp=1._8/(2._8*mu*beta**3)*depthdecay
+ b1=temp*p1
+ b2=temp*p2
+ b3=temp*p3/(1+h)
+
+ ! b3 contribution
+ tmp=i*b3*(beta*(1._8-1._8/alpha+beta*x3))
+ v1=tmp*k1
+ v2=tmp*k2
+ v3=-beta**2*b3*(1._8/alpha+beta*x3)
+
+ ! b1 contribution
+ temp=pi2**2*(2._8-1._8/alpha+beta*x3)/(1+h)
+ v1=v1+b1*(-2._8*beta**2+k1**2*temp)
+ v2=v2+b1*k1*k2*temp
+ v3=v3+b1*i*k1*beta*(1._8/alpha-1._8+beta*x3)/(1+h)
+
+ ! b2 contribution & switch to single-precision
+ u1=v1+b2*k1*k2*temp
+ u2=v2+b2*(-2._8*beta**2+k2**2*temp)
+ u3=v3+b2*i*k2*beta*(1._8/alpha-1._8+beta*x3)/(1+h)
+ END IF
+
+ END SUBROUTINE cerrutisolcowling
+
+ END SUBROUTINE cerruticowling
+
+ !---------------------------------------------------------------------
+ !> subroutine CerrutiCowlingSerial
+ !! computes the deformation field in the 3-dimensional grid
+ !! due to an arbitrary surface traction. No parallel version.
+ !
+ ! sylvain barbot - 07/07/07 - original form
+ ! 21/11/08 - gravity effect
+ !---------------------------------------------------------------------
+ SUBROUTINE cerruticowlingserial(p1,p2,p3,lambda,mu,gamma,u1,u2,u3,dx1,dx2,dx3)
+ REAL*4, DIMENSION(:,:), INTENT(IN) :: p1,p2,p3
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: u1,u2,u3
+ REAL*8, INTENT(IN) :: lambda,mu,gamma,dx1,dx2,dx3
+
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3,status
+ REAL*8 :: k1,k2,k3,x3,alpha
+ COMPLEX(KIND=4), ALLOCATABLE, DIMENSION(:) :: b1,b2,b3
+ COMPLEX(KIND=4) :: t1,t2,t3
+
+ sx1=SIZE(u1,1)-2
+ sx2=SIZE(u1,2)
+ sx3=SIZE(u1,3)
+
+ ALLOCATE(b1(sx3),b2(sx3),b3(sx3),STAT=status)
+ IF (0/=status) STOP "could not allocate arrays for Cerruti3D"
+
+ alpha=(lambda+mu)/(lambda+2*mu)
+
+ DO i2=1,sx2
+ DO i1=1,sx1/2+1
+ CALL wavenumbers(i1,i2,1,sx1,sx2,1,dx1,dx2,1._8,k1,k2,k3)
+ t1=CMPLX(p1(2*i1-1,i2),p1(2*i1,i2))
+ t2=CMPLX(p2(2*i1-1,i2),p2(2*i1,i2))
+ t3=CMPLX(p3(2*i1-1,i2),p3(2*i1,i2))
+ DO i3=1,sx3
+ IF (i3<=sx3/2) THEN
+ x3=DBLE(i3-1)*dx3
+ ELSE
+ x3=ABS(DBLE(i3-sx3-1)*dx3)
+ END IF
+ CALL cerrutisolcowling(t1,t2,t3,alpha,gamma, &
+ b1(i3),b2(i3),b3(i3),k1,k2,x3)
+ END DO
+
+ ! transforms the Cerruti solution into a full 3-dimensional
+ ! Fourier transform by 1d transforming in the 3-direction
+ CALL fft1(b1,sx3,dx3,FFT_FORWARD)
+ CALL fft1(b2,sx3,dx3,FFT_FORWARD)
+ CALL fft1(b3,sx3,dx3,FFT_FORWARD)
+
+ ! add the Cerruti's contribution to the deformation field
+ DO i3=1,sx3
+ u1(2*i1-1,i2,i3)=u1(2*i1-1,i2,i3)+REAL( REAL(b1(i3)))
+ u1(2*i1 ,i2,i3)=u1(2*i1 ,i2,i3)+REAL(AIMAG(b1(i3)))
+ u2(2*i1-1,i2,i3)=u2(2*i1-1,i2,i3)+REAL( REAL(b2(i3)))
+ u2(2*i1 ,i2,i3)=u2(2*i1 ,i2,i3)+REAL(AIMAG(b2(i3)))
+ u3(2*i1-1,i2,i3)=u3(2*i1-1,i2,i3)+REAL( REAL(b3(i3)))
+ u3(2*i1 ,i2,i3)=u3(2*i1 ,i2,i3)+REAL(AIMAG(b3(i3)))
+ END DO
+ END DO
+ END DO
+
+ CONTAINS
+ !-----------------------------------------------------------------
+ !> subroutine CerrutiSolCowling
+ !! computes the general solution for the deformation field in an
+ !! elastic half-space due to an arbitrary surface traction in the
+ !! presence of gravity.
+ !!
+ !! The 3 components u1, u2 and u3 of the deformation field are
+ !! expressed in the horizontal Fourier at depth x3.
+ !!
+ !! Combines the solution to the Boussinesq's and the Cerruti's
+ !! problem in a half-space with buoyancy boundary conditions.
+ !
+ ! sylvain barbot (07-07-07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE cerrutisolcowling(p1,p2,p3,alpha,gamma,u1,u2,u3,k1,k2,x3)
+ COMPLEX(KIND=4), INTENT(INOUT) :: u1,u2,u3
+ REAL*8, INTENT(IN) :: alpha,gamma,k1,k2,x3
+ COMPLEX(KIND=4), INTENT(IN) :: p1,p2,p3
+
+ REAL*8 :: beta, depthdecay, h
+ COMPLEX(KIND=8), PARAMETER :: i=CMPLX(0._8,pi2)
+ REAL*8 :: temp
+ COMPLEX(KIND=8) :: b1,b2,b3,tmp,v1,v2,v3
+
+ beta=pi2*sqrt(k1**2+k2**2)
+ depthdecay=exp(-beta*abs(x3))
+ h=gamma/beta
+
+ IF (0==k1 .AND. 0==k2) THEN
+ u1=CMPLX(0._4,0._4)
+ u2=CMPLX(0._4,0._4)
+ u3=CMPLX(0._4,0._4)
+ ELSE
+ temp=1._8/(2._8*mu*beta**3)*depthdecay
+ b1=temp*p1
+ b2=temp*p2
+ b3=temp*p3/(1+h)
+
+ ! b3 contribution
+ tmp=i*b3*(beta*(1._8-1._8/alpha+beta*x3))
+ v1=tmp*k1
+ v2=tmp*k2
+ v3=-beta**2*b3*(1._8/alpha+beta*x3)
+
+ ! b1 contribution
+ temp=pi2**2*(2._8-1._8/alpha+beta*x3)/(1+h)
+ v1=v1+b1*(-2._8*beta**2+k1**2*temp)
+ v2=v2+b1*k1*k2*temp
+ v3=v3+b1*i*k1*beta*(1._8/alpha-1._8+beta*x3)/(1+h)
+
+ ! b2 contribution & switch to single-precision
+ u1=v1+b2*k1*k2*temp
+ u2=v2+b2*(-2._8*beta**2+k2**2*temp)
+ u3=v3+b2*i*k2*beta*(1._8/alpha-1._8+beta*x3)/(1+h)
+ END IF
+
+ END SUBROUTINE cerrutisolcowling
+
+ END SUBROUTINE cerruticowlingserial
+
+ !------------------------------------------------------------------
+ !> subroutine GreenFunction
+ !! computes (inplace) the displacement components due to a set of
+ !! 3-D body-forces by application of the semi-analytic Green's
+ !! function. The solution satisfies quasi-static Navier's equation
+ !! including vanishing of normal traction at the surface.
+ !!
+ !! The surface traction can be made to vanish by application of
+ !! 1) method of images + boussinesq problem (grn_method=GRN_IMAGE)
+ !! 2) boussinesq's and cerruti's problems (grn_method=GRN_HS)
+ !! in the first case, the body-forces are supposed by have been
+ !! imaged appropriately.
+ !
+ ! sylvain barbot (07/07/07) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE greenfunction(c1,c2,c3,t1,t2,t3,dx1,dx2,dx3,lambda,mu,grn_method)
+ REAL*4, INTENT(INOUT), DIMENSION(:,:,:) :: c1,c2,c3
+ REAL*4, INTENT(INOUT), DIMENSION(:,:) :: t1,t2,t3
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ REAL*8, INTENT(IN) :: lambda,mu
+ INTEGER, INTENT(IN) :: grn_method
+
+ INTEGER :: sx1,sx2,sx3,status
+
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: p1,p2,p3
+
+ sx1=SIZE(c1,1)-2
+ sx2=SIZE(c1,2)
+ sx3=SIZE(c1,3)
+
+ ALLOCATE(p1(sx1+2,sx2),p2(sx1+2,sx2),p3(sx1+2,sx2),STAT=status)
+ IF (status > 0) THEN
+ WRITE_DEBUG_INFO
+ WRITE(0,'("could not allocate memory for green function")')
+ STOP 1
+ ELSE
+ p1=0;p2=0;p3=0;
+ END IF
+
+ ! forward Fourier transform equivalent body-force
+ CALL fft3(c1,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
+ CALL fft3(c2,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
+ CALL fft3(c3,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
+ CALL fft2(t1,sx1,sx2,dx1,dx2,FFT_FORWARD)
+ CALL fft2(t2,sx1,sx2,dx1,dx2,FFT_FORWARD)
+ CALL fft2(t3,sx1,sx2,dx1,dx2,FFT_FORWARD)
+
+ ! solve for displacement field
+ CALL elasticresponse(lambda,mu,c1,c2,c3,dx1,dx2,dx3)
+ IF (GRN_IMAGE .eq. grn_method) THEN
+ CALL surfacenormaltraction(lambda,mu,c1,c2,c3,dx1,dx2,dx3,p3)
+ p3=t3-p3
+ CALL boussinesq3d(p3,lambda,mu,c1,c2,c3,dx1,dx2,dx3)
+ ELSE
+ CALL surfacetraction(lambda,mu,c1,c2,c3,dx1,dx2,dx3,p1,p2,p3)
+ p1=t1-p1
+ p2=t2-p2
+ p3=t3-p3
+ CALL cerruti3d(p1,p2,p3,lambda,mu,c1,c2,c3,dx1,dx2,dx3)
+ END IF
+
+ ! inverse Fourier transform solution displacement components
+ CALL fft3(c1,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
+ CALL fft3(c2,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
+ CALL fft3(c3,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
+ CALL fft2(t1,sx1,sx2,dx1,dx2,FFT_INVERSE)
+ CALL fft2(t2,sx1,sx2,dx1,dx2,FFT_INVERSE)
+ CALL fft2(t3,sx1,sx2,dx1,dx2,FFT_INVERSE)
+
+ DEALLOCATE(p1,p2,p3)
+
+ END SUBROUTINE greenfunction
+
+ !------------------------------------------------------------------
+ !> subroutine GreensFunctionCowling
+ !! computes (inplace) the displacement components due to a set of
+ !! 3-D body-forces by application of the semi-analytic Green's
+ !! function. The solution satisfies quasi-static Navier's equation
+ !! with buoyancy boundary condition to simulate the effect of
+ !! gravity (the Cowling approximation).
+ !!
+ !! the importance of gravity depends upon the density contrast rho
+ !! at the surface, the acceleration of gravity g and the value of
+ !! shear modulus mu in the crust. effect on the displacement field
+ !! is governed by the gradient
+ !!
+ !! gamma = (1 - nu) rho g / mu
+ !! = rho g / (2 mu alpha)
+ !!
+ !! where nu is the Poisson's ratio. For a Poisson's solid with
+ !! nu = 1/4, with a density contrast rho = 3200 kg/m^3 and a shear
+ !! modulus mu = 30 GPa, we have gamma = 0.8e-6 /m.
+ !!
+ !! INPUT:
+ !! @param c1,c2,c3 is a set of body forces
+ !! @param dx1,dx2,dx3 are the sampling size
+ !! @param lambda,mu are the Lame elastic parameters
+ !! @param gamma is the gravity coefficient
+ !
+ ! sylvain barbot (07/07/07) - original function greenfunction
+ ! (11/21/08) - effect of gravity
+ !------------------------------------------------------------------
+ SUBROUTINE greenfunctioncowling(c1,c2,c3,t1,t2,t3,dx1,dx2,dx3, &
+ lambda,mu,gamma)
+ REAL*4, INTENT(INOUT), DIMENSION(:,:,:) :: c1,c2,c3
+ REAL*4, INTENT(INOUT), DIMENSION(:,:) :: t1,t2,t3
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3
+ REAL*8, INTENT(IN) :: lambda,mu,gamma
+
+ INTEGER :: sx1,sx2,sx3,status
+
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: p1,p2,p3
+
+ sx1=SIZE(c1,1)-2
+ sx2=SIZE(c1,2)
+ sx3=SIZE(c1,3)
+
+ ALLOCATE(p1(sx1+2,sx2),p2(sx1+2,sx2),p3(sx1+2,sx2),STAT=status)
+ IF (status > 0) THEN
+ WRITE_DEBUG_INFO
+ WRITE(0,'("could not allocate memory for green function")')
+ STOP 1
+ ELSE
+ p1=0;p2=0;p3=0;
+ END IF
+
+ ! forward Fourier transform equivalent body-force
+ CALL fft3(c1,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
+ CALL fft3(c2,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
+ CALL fft3(c3,sx1,sx2,sx3,dx1,dx2,dx3,FFT_FORWARD)
+ CALL fft2(t1,sx1,sx2,dx1,dx2,FFT_FORWARD)
+ CALL fft2(t2,sx1,sx2,dx1,dx2,FFT_FORWARD)
+ CALL fft2(t3,sx1,sx2,dx1,dx2,FFT_FORWARD)
+
+ ! solve for displacement field
+ CALL elasticresponse(lambda,mu,c1,c2,c3,dx1,dx2,dx3)
+
+ CALL surfacetractioncowling(lambda,mu,gamma, &
+ c1,c2,c3,dx1,dx2,dx3,p1,p2,p3)
+ p1=t1-p1
+ p2=t2-p2
+ p3=t3-p3
+ CALL cerruticowling(p1,p2,p3,lambda,mu,gamma, &
+ c1,c2,c3,dx1,dx2,dx3)
+
+ ! inverse Fourier transform solution displacement components
+ CALL fft3(c1,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
+ CALL fft3(c2,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
+ CALL fft3(c3,sx1,sx2,sx3,dx1,dx2,dx3,FFT_INVERSE)
+ CALL fft2(t1,sx1,sx2,dx1,dx2,FFT_INVERSE)
+ CALL fft2(t2,sx1,sx2,dx1,dx2,FFT_INVERSE)
+ CALL fft2(t3,sx1,sx2,dx1,dx2,FFT_INVERSE)
+
+ DEALLOCATE(p1,p2,p3)
+
+ END SUBROUTINE greenfunctioncowling
+
+END MODULE green
diff -r 405d8f4fa05f -r e7295294f654 src/include.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/include.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,59 @@
+#include "config.h"
+
+! implement SGI Fast Fourier Transforms library
+!#define SGI_FFT 1
+
+! export data to GMT XYZ text format
+!#define XYZ 1
+
+! export data to GMT GRD binary format
+#define GRD 1
+
+! export equivalent body forces in GRD format
+!#define GRD_EQBF 1
+
+! export amplitude of scalar fields
+! along a plane in GRD binary format
+#define GRD_EXPORTEIGENSTRAIN 1
+
+! export creep velocity along a frictional
+! plane in GRD binary format
+#define GRD_EXPORTCREEP 1
+
+! export data to the TXT format
+!#define TXT 1
+
+! export data to longitude/latitude format
+#define PROJ 1
+
+! export amplitude of scalar fields along
+! an observation plane in text format
+#define TXT_EXPORTEIGENSTRAIN 1
+
+! export creep velocity along a frictional
+! plane in text format
+!#define TXT_EXPORTCREEP 1
+
+! export data to VTK format (for visualization in Paraview)
+#define VTK 1
+!#define VTK_EQBF 1
+
+#define WRITE_DEBUG_INFO WRITE (0,'("error at line ",I5.5," of source file ",a)') __LINE__,__FILE__
+
+
+#ifdef IMKL_FFT
+#define WRITE_MKL_DEBUG_INFO(i) IF(i.NE.0)THEN;IF(.NOT.DftiErrorClass(i,DFTI_NO_ERROR))THEN;WRITE_DEBUG_INFO;WRITE (0,*) DftiErrorMessage(i);STOP 1;END IF;END IF
+#endif
+
+! adjust data alignment for the Fourier transform
+#ifdef FFTW3
+#define ALIGN_DATA 1
+#else
+#ifdef SGI_FFT
+#define ALIGN_DATA 1
+#else
+#ifdef IMKL_FFT
+#define ALIGN_DATA 1
+#endif
+#endif
+#endif
diff -r 405d8f4fa05f -r e7295294f654 src/input.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/input.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,1374 @@
+!-----------------------------------------------------------------------
+! Copyright 2007, 2008, 2009 Sylvain Barbot
+!
+! This file is part of RELAX
+!
+! RELAX 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 3 of the License, or
+! (at your option) any later version.
+!
+! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
+!-----------------------------------------------------------------------
+
+#include "include.f90"
+
+MODULE input
+
+ IMPLICIT NONE
+
+ REAL*8, PARAMETER :: DEG2RAD = 0.01745329251994329547437168059786927_8
+
+CONTAINS
+
+ !---------------------------------------------------------------------
+ !> subroutine init
+ !! reads simulation parameters from the standard input and initialize
+ !! model parameters.
+ !!
+ !! INPUT:
+ !! @param unit - the unit number used to read input data
+ !!
+ !! OUTPUT:
+ !! @param in
+ !---------------------------------------------------------------------
+ SUBROUTINE init(in,unit)
+ USE types
+ USE export
+ USE getopt_m
+
+ TYPE(SIMULATION_STRUC), INTENT(OUT) :: in
+ INTEGER, OPTIONAL, INTENT(INOUT) :: unit
+
+ CHARACTER :: ch
+ CHARACTER(180) :: dataline
+ CHARACTER(80) :: rffilename,filename
+#ifdef VTK
+ CHARACTER(3) :: digit
+ CHARACTER(4) :: digit4
+#endif
+ INTEGER :: iunit
+!$ INTEGER :: omp_get_num_procs,omp_get_max_threads
+ REAL*8 :: dummy,dum1,dum2
+ REAL*8 :: minlength,minwidth
+ TYPE(OPTION_S) :: opts(12)
+
+ INTEGER :: k,iostatus,i,e
+
+ ! default is standard input
+ IF (.NOT. PRESENT(unit)) THEN
+ iunit=5
+ ELSE
+ iunit=unit
+ END IF
+
+ ! parse the command line for options
+ opts( 1)=OPTION_S("no-proj-output",.FALSE.,CHAR(20))
+ opts( 2)=OPTION_S("no-relax-output",.FALSE.,CHAR(21))
+ opts( 3)=OPTION_S("no-txt-output",.FALSE.,CHAR(22))
+ opts( 4)=OPTION_S("no-vtk-output",.FALSE.,CHAR(23))
+ opts( 5)=OPTION_S("no-grd-output",.FALSE.,CHAR(24))
+ opts( 6)=OPTION_S("no-xyz-output",.FALSE.,CHAR(25))
+ opts( 7)=OPTION_S("no-stress-output",.FALSE.,CHAR(26))
+ opts( 8)=OPTION_S("with-stress-output",.FALSE.,CHAR(27))
+ opts( 9)=OPTION_S("with-vtk-output",.FALSE.,CHAR(28))
+ opts(10)=OPTION_S("with-vtk-relax-output",.FALSE.,CHAR(29))
+ opts(11)=OPTION_S("dry-run",.FALSE.,CHAR(30))
+ opts(12)=OPTION_S("help",.FALSE.,'h')
+
+ DO
+ ch=getopt("h",opts)
+ SELECT CASE(ch)
+ CASE(CHAR(0))
+ EXIT
+ CASE(CHAR(20))
+ ! option no-proj-output
+ in%isoutputproj=.FALSE.
+ CASE(CHAR(21))
+ ! option no-relax-output
+ in%isoutputrelax=.FALSE.
+ CASE(CHAR(22))
+ ! option no-txt-output
+ in%isoutputtxt=.FALSE.
+ CASE(CHAR(23))
+ ! option no-vtk-output
+ in%isoutputvtk=.FALSE.
+ CASE(CHAR(24))
+ ! option no-grd-output
+ in%isoutputgrd=.FALSE.
+ CASE(CHAR(25))
+ ! option no-xyz-output
+ in%isoutputxyz=.FALSE.
+ CASE(CHAR(26))
+ ! option stress output
+ in%isoutputstress=.FALSE.
+ CASE(CHAR(27))
+ ! option dry-run
+ in%isoutputstress=.TRUE.
+ CASE(CHAR(28))
+ ! option with-output-vtk
+ in%isoutputvtk=.TRUE.
+ CASE(CHAR(29))
+ ! option with-output-vtk-relax
+ in%isoutputvtkrelax=.TRUE.
+ CASE(CHAR(30))
+ ! option dry-run
+ in%isdryrun=.TRUE.
+ CASE('h')
+ ! option help
+ in%ishelp=.TRUE.
+ CASE('?')
+ WRITE_DEBUG_INFO
+ in%ishelp=.TRUE.
+ EXIT
+ CASE DEFAULT
+ WRITE (0,'("unhandled option ", a, " (this is a bug")') optopt
+ WRITE_DEBUG_INFO
+ STOP 3
+ END SELECT
+ END DO
+
+ IF (in%ishelp) THEN
+ PRINT '("usage:")'
+ PRINT '("relax [-h] [--dry-run] [--help] [--no-grd-output] [--no-proj-output]")'
+ PRINT '(" [--no-relax-output] [--no-stress-output] [--no-txt-output]")'
+ PRINT '(" [--no-vtk-output] [--no-xyz-output]")'
+ PRINT '("")'
+ PRINT '("options:")'
+ PRINT '(" -h prints this message and aborts calculation")'
+ PRINT '(" --dry-run abort calculation, only output geometry")'
+ PRINT '(" --help prints this message and aborts calculation")'
+ PRINT '(" --no-grd-output cancel output in GMT grd binary format")'
+ PRINT '(" --no-proj-output cancel output in geographic projection")'
+ PRINT '(" --no-relax-output cancel output of the postseismic contribution")'
+ PRINT '(" --no-stress-output cancel output of stress tensor in any format")'
+ PRINT '(" --no-txt-output cancel output in text format")'
+ PRINT '(" --no-vtk-output cancel output in Paraview VTK format")'
+ PRINT '(" --no-xyz-output cancel output in GMT xyz format")'
+ PRINT '(" --with-stress-output export stress tensor")'
+ PRINT '(" --with-vtk-output export output in Paraview VTK format")'
+ PRINT '(" --with-vtk-relax-output export relaxation to VTK format")'
+ PRINT '("")'
+ PRINT '("description:")'
+ PRINT '(" Evaluates the deformation due to fault slip, surface loading")'
+ PRINT '(" or inflation and the time series of postseismic relaxation")'
+ PRINT '(" that follows due to fault creep or viscoelastic flow.")'
+ RETURN
+ END IF
+ PRINT 2000
+ PRINT '(" RELAX: nonlinear postseismic relaxation with Fourier-domain Green''s function")'
+#ifdef FFTW3
+#ifdef FFTW3_THREADS
+ PRINT '(" * FFTW3 (multi-threaded) implementation of the FFT")'
+#else
+ PRINT '(" * FFTW3 implementation of the FFT")'
+#endif
+#else
+#ifdef SGI_FFT
+ PRINT '(" * SGI_FFT implementation of the FFT")'
+#else
+#ifdef IMKL_FFT
+ PRINT '(" * Intel MKL implementation of the FFT")'
+#else
+ PRINT '(" * fourt implementation of the FFT")'
+#endif
+#endif
+#endif
+!$ PRINT '(" * parallel OpenMP implementation with ",I3.3,"/",I3.3," threads")', &
+!$ omp_get_max_threads(),omp_get_num_procs()
+#ifdef PROJ
+ IF (in%isoutputproj) THEN
+ PRINT '(" * export to longitude/latitude text format")'
+ ELSE
+ PRINT '(" * export to longitude/latitude text format cancelled (--",a,")")', trim(opts(1)%name)
+ END IF
+#endif
+#ifdef TXT
+ IF (in%isoutputtxt) THEN
+ PRINT '(" * export to TXT format")'
+ ELSE
+ PRINT '(" * export to TXT format cancelled (--",a,")")', trim(opts(3)%name)
+ END IF
+#ifdef GRD
+ IF (in%isoutputgrd) THEN
+ PRINT '(" * export to GRD format")'
+ ELSE
+ PRINT '(" * export to GRD format cancelled (--",a,")")', trim(opts(5)%name)
+ END IF
+#endif
+#ifdef XYZ
+ IF (in%isoutputxyz) THEN
+ PRINT '(" * export to XYZ format")'
+ ELSE
+ PRINT '(" * export to XYZ format cancelled (--",a,")")', trim(opts(6)%name)
+ END IF
+#endif
+#endif
+#ifdef VTK
+ IF (in%isoutputvtk) THEN
+ PRINT '(" * export to VTK format")'
+ ELSE
+ PRINT '(" * export to VTK format cancelled (--",a,")")', trim(opts(4)%name)
+ END IF
+ IF (in%isoutputvtkrelax) THEN
+ PRINT '(" * export relaxation component to VTK format (--",a,")")', trim(opts(10)%name)
+ END IF
+#endif
+ PRINT 2000
+
+ PRINT '(a)', "grid dimension (sx1,sx2,sx3)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%sx1,in%sx2,in%sx3
+ PRINT '(3I5)', in%sx1,in%sx2,in%sx3
+
+ PRINT '(a)', "sampling (dx1,dx2,dx3), smoothing (beta, nyquist)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%dx1,in%dx2,in%dx3,in%beta,in%nyquist
+ PRINT '(5ES9.2E1)', in%dx1,in%dx2,in%dx3,in%beta,in%nyquist
+
+ PRINT '(a)', "origin position (x0,y0) and rotation"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%x0,in%y0,in%rot
+ PRINT '(3ES9.2E1)', in%x0,in%y0,in%rot
+
+#ifdef PROJ
+ IF (in%isoutputproj) THEN
+ PRINT '(a)', "geographic origin (longitude, latitude, UTM zone, unit)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%lon0,in%lat0,in%zone,in%umult
+ PRINT '(2ES9.2E1,I3.2,ES9.2E1)',in%lon0,in%lat0,in%zone,in%umult
+ IF (in%zone.GT.60 .OR. in%zone.LT.1) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid UTM zone ",I3," (1<=zone<=60. exiting.)")') in%zone
+ STOP 1
+ END IF
+ END IF
+#endif
+
+ PRINT '(a)', "observation depth (displacement and stress)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%oz,in%ozs
+ PRINT '(2ES9.2E1)', in%oz,in%ozs
+
+ PRINT '(a)', "output directory"
+ CALL getdata(iunit,dataline)
+ READ (dataline,'(a)') in%wdir
+
+ in%reporttimefilename=trim(in%wdir)//"/time.txt"
+ in%reportfilename=trim(in%wdir)//"/report.txt"
+#ifdef TXT
+ PRINT '(" ",a," (report: ",a,")")', trim(in%wdir),trim(in%reportfilename)
+#else
+ PRINT '(" ",a," (time report: ",a,")")', trim(in%wdir),trim(in%reporttimefilename)
+#endif
+
+ ! test write permissions on output directory
+ OPEN (UNIT=14,FILE=in%reportfilename,POSITION="APPEND",&
+ IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("unable to access ",a)') trim(in%reporttimefilename)
+ STOP 1
+ END IF
+ CLOSE(14)
+ ! end test
+
+#ifdef VTK
+ filename=trim(in%wdir)//"/cgrid.vtp"
+ CALL exportvtk_grid(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3,filename)
+#endif
+
+ PRINT '(a)', "lambda, mu, gamma (gamma = (1 - nu) rho g / mu)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%lambda,in%mu,in%gam
+ PRINT '(3ES10.2E2)',in%lambda,in%mu,in%gam
+
+ PRINT '(a)', "time interval, (positive time step) or (negative skip, scaling)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%interval, in%odt
+
+ IF (in%odt .LT. 0.) THEN
+ READ (dataline,*) dum1, dum2, in%tscale
+ in%skip=ceiling(-in%odt)
+ PRINT '(ES9.2E1," (output every ",I3.3," steps, dt scaled by ",ES7.2E1,")")', &
+ in%interval,in%skip,in%tscale
+ ELSE
+ PRINT '(ES9.2E1," (output every ",ES9.2E1," time unit)")', in%interval,in%odt
+ END IF
+
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! O B S E R V A T I O N P L A N E S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of observation planes"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%nop
+ PRINT '(I5)', in%nop
+ IF (in%nop .gt. 0) THEN
+ ALLOCATE(in%op(in%nop),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the observation plane list"
+ PRINT 2000
+ PRINT 2100
+ PRINT 2000
+ DO k=1,in%nop
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,in%op(k)%x,in%op(k)%y,in%op(k)%z,&
+ in%op(k)%length,in%op(k)%width,in%op(k)%strike,in%op(k)%dip
+
+ PRINT '(I3.3," ",5ES9.2E1,2f7.1)', &
+ k,in%op(k)%x,in%op(k)%y,in%op(k)%z, &
+ in%op(k)%length,in%op(k)%width,in%op(k)%strike,in%op(k)%dip
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,*) "error in input file: plane index misfit", k,"<>",i
+ STOP 1
+ END IF
+
+ ! comply to Wang's convention
+ CALL wangconvention(dummy,in%op(k)%x,in%op(k)%y,in%op(k)%z,&
+ in%op(k)%length,in%op(k)%width,in%op(k)%strike,in%op(k)%dip, &
+ dummy,in%x0,in%y0,in%rot)
+
+ END DO
+ END IF
+
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! O B S E R V A T I O N P O I N T S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of observation points"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%npts
+ PRINT '(I5)', in%npts
+ IF (in%npts .gt. 0) THEN
+ ALLOCATE(in%opts(in%npts),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the observation point list"
+ ALLOCATE(in%ptsname(in%npts),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the list of point name"
+
+ PRINT 2000
+ PRINT 2300
+ PRINT 2000
+ DO k=1,in%npts
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,in%ptsname(k),in%opts(k)%v1,in%opts(k)%v2,in%opts(k)%v3
+
+ PRINT '(I3.3," ",A4,3ES9.2E1)', i,in%ptsname(k), &
+ in%opts(k)%v1,in%opts(k)%v2,in%opts(k)%v3
+
+ ! shift and rotate coordinates
+ in%opts(k)%v1=in%opts(k)%v1-in%x0
+ in%opts(k)%v2=in%opts(k)%v2-in%y0
+ CALL rotation(in%opts(k)%v1,in%opts(k)%v2,in%rot)
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: points index misfit")')
+ STOP 1
+ END IF
+ END DO
+
+ ! export the lits of observation points for display
+ filename=trim(in%wdir)//"/opts.dat"
+ CALL exportoptsdat(in%npts,in%opts,in%ptsname,filename)
+
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! C O U L O M B O B S E R V A T I O N S E G M E N T S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of stress observation segments"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%nsop
+ PRINT '(I5)', in%nsop
+ IF (in%nsop .gt. 0) THEN
+ ALLOCATE(in%sop(in%nsop),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the segment list"
+ PRINT 2000
+ PRINT '(a)',"no. xs ys zs length width strike dip friction"
+ PRINT 2000
+ DO k=1,in%nsop
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i, &
+ in%sop(k)%x,in%sop(k)%y,in%sop(k)%z, &
+ in%sop(k)%length,in%sop(k)%width, &
+ in%sop(k)%strike,in%sop(k)%dip,in%sop(k)%friction
+ in%sop(k)%sig0=TENSOR(0.d0,0.d0,0.d0,0.d0,0.d0,0.d0)
+
+ PRINT '(I4.4,3ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1)',i, &
+ in%sop(k)%x,in%sop(k)%y,in%sop(k)%z, &
+ in%sop(k)%length,in%sop(k)%width, &
+ in%sop(k)%strike,in%sop(k)%dip, &
+ in%sop(k)%friction
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid segment definition ")')
+ WRITE (0,'("error in input file: source index misfit")')
+ STOP 1
+ END IF
+ IF (MAX(in%sop(k)%length,in%sop(k)%width) .LE. 0._8) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: length and width must be positive.")')
+ STOP 1
+ END IF
+
+ ! comply to Wang's convention
+ CALL wangconvention(dummy, &
+ in%sop(k)%x,in%sop(k)%y,in%sop(k)%z, &
+ in%sop(k)%length,in%sop(k)%width, &
+ in%sop(k)%strike,in%sop(k)%dip, &
+ dummy, &
+ in%x0,in%y0,in%rot)
+ END DO
+
+ ! export patches to vtk/vtp
+ filename=trim(in%wdir)//"/rfaults-dsigma-0000.vtp"
+ CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,filename,convention=1)
+
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! P R E S T R E S S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of prestress interfaces"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%nps
+ PRINT '(I5)', in%nps
+
+ IF (in%nps .GT. 0) THEN
+ ALLOCATE(in%stresslayer(in%nps),in%stressstruc(in%sx3/2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the stress layer structure"
+
+ PRINT 2000
+ PRINT '(a)', "no. depth sigma11 sigma12 sigma13 sigma22 sigma23 sigma33"
+ PRINT 2000
+ DO k=1,in%nps
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,in%stresslayer(k)%z, &
+ in%stresslayer(k)%t%s11, in%stresslayer(k)%t%s12, &
+ in%stresslayer(k)%t%s13, in%stresslayer(k)%t%s22, &
+ in%stresslayer(k)%t%s23, in%stresslayer(k)%t%s33
+
+ PRINT '(I3.3,7ES9.2E1)', i, &
+ in%stresslayer(k)%z, &
+ in%stresslayer(k)%t%s11, in%stresslayer(k)%t%s12, &
+ in%stresslayer(k)%t%s13, in%stresslayer(k)%t%s22, &
+ in%stresslayer(k)%t%s23, in%stresslayer(k)%t%s33
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: index misfit")')
+ STOP 1
+ END IF
+ END DO
+ END IF
+
+
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! L I N E A R V I S C O U S I N T E R F A C E
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of linear viscous interfaces"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%nv
+ PRINT '(I5)', in%nv
+
+ IF (in%nv .GT. 0) THEN
+ ALLOCATE(in%linearlayer(in%nv),in%linearstruc(in%sx3/2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the layer structure"
+
+ PRINT 2000
+ PRINT '(a)', "no. depth gamma0 cohesion"
+ PRINT 2000
+ DO k=1,in%nv
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,in%linearlayer(k)%z, &
+ in%linearlayer(k)%gammadot0, in%linearlayer(k)%cohesion
+
+ in%linearlayer(k)%stressexponent=1
+
+ PRINT '(I3.3,3ES10.2E2)', i, &
+ in%linearlayer(k)%z, &
+ in%linearlayer(k)%gammadot0, &
+ in%linearlayer(k)%cohesion
+
+ ! check positive strain rates
+ IF (in%linearlayer(k)%gammadot0 .LT. 0) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: strain rates must be positive")')
+ STOP 1
+ END IF
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: index misfit")')
+ STOP 1
+ END IF
+#ifdef VTK
+ ! export the viscous layer in VTK format
+ WRITE (digit,'(I3.3)') k
+
+ rffilename=trim(in%wdir)//"/linearlayer-"//digit//".vtp"
+ CALL exportvtk_rectangle(0.d0,0.d0,in%linearlayer(k)%z, &
+ DBLE(in%sx1)*in%dx1,DBLE(in%sx2)*in%dx2, &
+ 0._8,1.5708d0,rffilename)
+#endif
+ END DO
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! L I N E A R W E A K Z O N E S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of linear weak zones"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%nlwz
+ PRINT '(I5)', in%nlwz
+ IF (in%nlwz .GT. 0) THEN
+ ALLOCATE(in%linearweakzone(in%nlwz),in%linearweakzonec(in%nlwz),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the linear weak zones"
+ PRINT 2000
+ PRINT '(a)', "no. dgammadot0 x1 x2 x3 length width thickn. strike dip"
+ PRINT 2000
+ DO k=1,in%nlwz
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i, &
+ in%linearweakzone(k)%dgammadot0, &
+ in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z,&
+ in%linearweakzone(k)%length,in%linearweakzone(k)%width,in%linearweakzone(k)%thickness, &
+ in%linearweakzone(k)%strike,in%linearweakzone(k)%dip
+
+ in%linearweakzonec(k)=in%linearweakzone(k)
+
+ PRINT '(I3.3,4ES9.2E1,3ES8.2E1,f7.1,f6.1)',k,&
+ in%linearweakzone(k)%dgammadot0, &
+ in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z, &
+ in%linearweakzone(k)%length,in%linearweakzone(k)%width, &
+ in%linearweakzone(k)%thickness, &
+ in%linearweakzone(k)%strike,in%linearweakzone(k)%dip
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: source index misfit")')
+ STOP 1
+ END IF
+ ! comply to Wang's convention
+ CALL wangconvention( &
+ dummy, &
+ in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z, &
+ in%linearweakzone(k)%length,in%linearweakzone(k)%width, &
+ in%linearweakzone(k)%strike,in%linearweakzone(k)%dip, &
+ dummy,in%x0,in%y0,in%rot)
+
+ WRITE (digit,'(I3.3)') k
+
+#ifdef VTK
+ ! export the ductile zone in VTK format
+ rffilename=trim(in%wdir)//"/weakzone-"//digit//".vtp"
+ CALL exportvtk_brick(in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z, &
+ in%linearweakzone(k)%length,in%linearweakzone(k)%width,in%linearweakzone(k)%thickness, &
+ in%linearweakzone(k)%strike,in%linearweakzone(k)%dip,rffilename)
+#endif
+ ! export the ductile zone in GMT .xy format
+ rffilename=trim(in%wdir)//"/weakzone-"//digit//".xy"
+ CALL exportxy_brick(in%linearweakzone(k)%x,in%linearweakzone(k)%y,in%linearweakzone(k)%z, &
+ in%linearweakzone(k)%length,in%linearweakzone(k)%width,in%linearweakzone(k)%thickness, &
+ in%linearweakzone(k)%strike,in%linearweakzone(k)%dip,rffilename)
+ END DO
+ END IF
+ END IF ! end linear viscous
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! N O N L I N E A R V I S C O U S I N T E R F A C E
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of nonlinear viscous interfaces"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%npl
+ PRINT '(I5)', in%npl
+
+ IF (in%npl .GT. 0) THEN
+ ALLOCATE(in%nonlinearlayer(in%npl),in%nonlinearstruc(in%sx3/2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the layer structure"
+
+ PRINT 2000
+ PRINT '(a)', "no. depth gamma0 power cohesion"
+ PRINT 2000
+ DO k=1,in%npl
+ CALL getdata(iunit,dataline)
+
+ READ (dataline,*) i,in%nonlinearlayer(k)%z, &
+ in%nonlinearlayer(k)%gammadot0, &
+ in%nonlinearlayer(k)%stressexponent, &
+ in%nonlinearlayer(k)%cohesion
+
+ PRINT '(I3.3,4ES10.2E2)', i, &
+ in%nonlinearlayer(k)%z, &
+ in%nonlinearlayer(k)%gammadot0, &
+ in%nonlinearlayer(k)%stressexponent, &
+ in%nonlinearlayer(k)%cohesion
+
+ ! check positive strain rates
+ IF (in%nonlinearlayer(k)%gammadot0 .LT. 0) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: strain rates must be positive")')
+ STOP 1
+ END IF
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: index misfit")')
+ STOP 1
+ END IF
+
+#ifdef VTK
+ WRITE (digit,'(I3.3)') k
+
+ ! export the viscous layer in VTK format
+ rffilename=trim(in%wdir)//"/nonlinearlayer-"//digit//".vtp"
+ CALL exportvtk_rectangle(0.d0,0.d0,in%nonlinearlayer(k)%z, &
+ DBLE(in%sx1)*in%dx1,DBLE(in%sx2)*in%dx2, &
+ 0._8,1.57d0,rffilename)
+#endif
+ END DO
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! N O N L I N E A R W E A K Z O N E S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of nonlinear weak zones"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%nnlwz
+ PRINT '(I5)', in%nnlwz
+ IF (in%nnlwz .GT. 0) THEN
+ ALLOCATE(in%nonlinearweakzone(in%nnlwz),in%nonlinearweakzonec(in%nnlwz),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the nonlinear weak zones"
+ PRINT 2000
+ PRINT '(a)', "no. dgammadot0 x1 x2 x3 length width thickn. strike dip"
+ PRINT 2000
+ DO k=1,in%nnlwz
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i, &
+ in%nonlinearweakzone(k)%dgammadot0, &
+ in%nonlinearweakzone(k)%x,in%nonlinearweakzone(k)%y,in%nonlinearweakzone(k)%z,&
+ in%nonlinearweakzone(k)%length,in%nonlinearweakzone(k)%width,in%nonlinearweakzone(k)%thickness, &
+ in%nonlinearweakzone(k)%strike,in%nonlinearweakzone(k)%dip
+
+ in%nonlinearweakzonec(k)=in%nonlinearweakzone(k)
+
+ PRINT '(I3.3,4ES9.2E1,3ES8.2E1,f7.1,f6.1)',k,&
+ in%nonlinearweakzone(k)%dgammadot0, &
+ in%nonlinearweakzone(k)%x,in%nonlinearweakzone(k)%y,in%nonlinearweakzone(k)%z, &
+ in%nonlinearweakzone(k)%length,in%nonlinearweakzone(k)%width, &
+ in%nonlinearweakzone(k)%thickness, &
+ in%nonlinearweakzone(k)%strike,in%nonlinearweakzone(k)%dip
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: source index misfit")')
+ STOP 1
+ END IF
+ ! comply to Wang's convention
+ CALL wangconvention( &
+ dummy, &
+ in%nonlinearweakzone(k)%x,in%nonlinearweakzone(k)%y,in%nonlinearweakzone(k)%z, &
+ in%nonlinearweakzone(k)%length,in%nonlinearweakzone(k)%width, &
+ in%nonlinearweakzone(k)%strike,in%nonlinearweakzone(k)%dip, &
+ dummy,in%x0,in%y0,in%rot)
+
+ WRITE (digit,'(I3.3)') k
+
+#ifdef VTK
+ ! export the ductile zone in VTK format
+ rffilename=trim(in%wdir)//"/weakzone-nl-"//digit//".vtp"
+ CALL exportvtk_brick(in%nonlinearweakzone(k)%x, &
+ in%nonlinearweakzone(k)%y, &
+ in%nonlinearweakzone(k)%z, &
+ in%nonlinearweakzone(k)%length, &
+ in%nonlinearweakzone(k)%width, &
+ in%nonlinearweakzone(k)%thickness, &
+ in%nonlinearweakzone(k)%strike, &
+ in%nonlinearweakzone(k)%dip,rffilename)
+#endif
+ ! export the ductile zone in GMT .xy format
+ rffilename=trim(in%wdir)//"/weakzone-nl-"//digit//".xy"
+ CALL exportxy_brick(in%nonlinearweakzone(k)%x, &
+ in%nonlinearweakzone(k)%y, &
+ in%nonlinearweakzone(k)%z, &
+ in%nonlinearweakzone(k)%length, &
+ in%nonlinearweakzone(k)%width, &
+ in%nonlinearweakzone(k)%thickness, &
+ in%nonlinearweakzone(k)%strike, &
+ in%nonlinearweakzone(k)%dip,rffilename)
+ END DO
+ END IF
+ END IF ! end nonlinear viscous
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! F A U L T C R E E P
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of fault creep interfaces"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%nfc
+ PRINT '(I5)', in%nfc
+
+ IF (in%nfc .GT. 0) THEN
+ ALLOCATE(in%faultcreeplayer(in%nfc),in%faultcreepstruc(in%sx3/2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the layer structure"
+
+ PRINT 2000
+ PRINT '(a)', "no. depth gamma0 (a-b)sig friction cohesion"
+ PRINT 2000
+ DO k=1,in%nfc
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,in%faultcreeplayer(k)%z, &
+ in%faultcreeplayer(k)%gammadot0, &
+ in%faultcreeplayer(k)%stressexponent, &
+ in%faultcreeplayer(k)%friction, &
+ in%faultcreeplayer(k)%cohesion
+
+ PRINT '(I3.3,5ES9.2E1)', i, &
+ in%faultcreeplayer(k)%z, &
+ in%faultcreeplayer(k)%gammadot0, &
+ in%faultcreeplayer(k)%stressexponent, &
+ in%faultcreeplayer(k)%friction, &
+ in%faultcreeplayer(k)%cohesion
+
+ ! check positive strain rates
+ IF (in%faultcreeplayer(k)%gammadot0 .LT. 0) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: slip rates must be positive")')
+ STOP 1
+ END IF
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: index misfit")')
+ STOP 1
+ END IF
+
+ END DO
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! A F T E R S L I P P L A N E S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of afterslip planes"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%np
+ PRINT '(I5)', in%np
+
+ IF (in%np .gt. 0) THEN
+ ALLOCATE(in%n(in%np),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the plane list"
+
+ PRINT 2000
+ PRINT 2500
+ PRINT 2000
+
+ DO k=1,in%np
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i, &
+ in%n(k)%x,in%n(k)%y,in%n(k)%z,&
+ in%n(k)%length,in%n(k)%width, &
+ in%n(k)%strike,in%n(k)%dip,in%n(k)%rake
+
+ PRINT '(I3.3," ",5ES9.2E1,3f7.1)',i, &
+ in%n(k)%x,in%n(k)%y,in%n(k)%z, &
+ in%n(k)%length,in%n(k)%width, &
+ in%n(k)%strike,in%n(k)%dip,in%n(k)%rake
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: plane index misfit")')
+ STOP 1
+ END IF
+
+ ! modify rake for consistency with slip model
+ IF (in%n(k)%rake .GE. 0.d0) THEN
+ in%n(k)%rake=in%n(k)%rake-180.d0
+ ELSE
+ in%n(k)%rake=in%n(k)%rake+180.d0
+ END IF
+
+ ! comply to Wang's convention
+ CALL wangconvention(dummy,in%n(k)%x,in%n(k)%y,in%n(k)%z,&
+ in%n(k)%length,in%n(k)%width, &
+ in%n(k)%strike,in%n(k)%dip,in%n(k)%rake, &
+ in%x0,in%y0,in%rot)
+
+ ! number of patches in each direction
+ in%n(k)%px2=FIX(in%n(k)%length/in%dx2)
+ in%n(k)%px3=FIX(in%n(k)%width/in%dx3)
+
+ ALLOCATE(in%n(k)%patch(in%n(k)%px2,in%n(k)%px3),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the fault patches"
+
+#ifdef VTK
+ ! export the afterslip segment in VTK format
+ WRITE (digit4,'(I4.4)') k
+
+ rffilename=trim(in%wdir)//"/aplane-"//digit4//".vtp"
+ CALL exportvtk_rectangle(in%n(k)%x,in%n(k)%y,in%n(k)%z, &
+ in%n(k)%length,in%n(k)%width, &
+ in%n(k)%strike,in%n(k)%dip,rffilename)
+#endif
+
+ END DO
+ END IF
+
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! I N T E R - S E I S M I C L O A D I N G
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ minlength=in%sx1*in%dx1+in%sx2*in%dx2
+ minwidth=in%sx3*in%dx3
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! S H E A R S O U R C E S R A T E
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of inter-seismic strike-slip segments"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%inter%ns
+ PRINT '(I5)', in%inter%ns
+ IF (in%inter%ns .GT. 0) THEN
+ ALLOCATE(in%inter%s(in%inter%ns),in%inter%sc(in%inter%ns),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the source list"
+ PRINT 2000
+ PRINT '(a)',"no. slip/time xs ys zs length width strike dip rake"
+ PRINT 2000
+ DO k=1,in%inter%ns
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,in%inter%s(k)%slip, &
+ in%inter%s(k)%x,in%inter%s(k)%y,in%inter%s(k)%z, &
+ in%inter%s(k)%length,in%inter%s(k)%width, &
+ in%inter%s(k)%strike,in%inter%s(k)%dip,in%inter%s(k)%rake
+
+ ! copy the input format for display
+ in%inter%sc(k)=in%inter%s(k)
+
+ PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1)',i, &
+ in%inter%sc(k)%slip,&
+ in%inter%sc(k)%x,in%inter%sc(k)%y,in%inter%sc(k)%z, &
+ in%inter%sc(k)%length,in%inter%sc(k)%width, &
+ in%inter%sc(k)%strike,in%inter%sc(k)%dip, &
+ in%inter%sc(k)%rake
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: source index misfit")')
+ STOP 1
+ END IF
+ IF (MAX(in%inter%s(k)%length,in%inter%s(k)%width) .LE. 0._8) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: lengths must be positive.")')
+ STOP 1
+ END IF
+ IF (in%inter%s(k)%length .lt. minlength) THEN
+ minlength=in%inter%s(k)%length
+ END IF
+ IF (in%inter%s(k)%width .lt. minwidth ) THEN
+ minwidth =in%inter%s(k)%width
+ END IF
+
+ ! smooth out the slip distribution
+ CALL antialiasingfilter(in%inter%s(k)%slip, &
+ in%inter%s(k)%length,in%inter%s(k)%width, &
+ in%dx1,in%dx2,in%dx3,in%nyquist)
+
+ ! comply to Wang's convention
+ CALL wangconvention(in%inter%s(k)%slip, &
+ in%inter%s(k)%x,in%inter%s(k)%y,in%inter%s(k)%z, &
+ in%inter%s(k)%length,in%inter%s(k)%width, &
+ in%inter%s(k)%strike,in%inter%s(k)%dip, &
+ in%inter%s(k)%rake, &
+ in%x0,in%y0,in%rot)
+
+ END DO
+ PRINT 2000
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! T E N S I L E S O U R C E S R A T E
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of inter-seismic tensile segments"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%inter%nt
+ PRINT '(I5)', in%inter%nt
+ IF (in%inter%nt .GT. 0) THEN
+ ALLOCATE(in%inter%ts(in%inter%nt),in%inter%tsc(in%inter%nt),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the tensile source list"
+ PRINT 2000
+ PRINT '(a)',"no. opening xs ys ", &
+ "zs length width strike dip"
+ PRINT 2000
+ DO k=1,in%inter%nt
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,in%inter%ts(k)%slip, &
+ in%inter%ts(k)%x,in%inter%ts(k)%y,in%inter%ts(k)%z, &
+ in%inter%ts(k)%length,in%inter%ts(k)%width, &
+ in%inter%ts(k)%strike,in%inter%ts(k)%dip
+ ! copy the input format for display
+ in%inter%tsc(k)=in%inter%ts(k)
+
+ PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1)', i, &
+ in%inter%tsc(k)%slip,&
+ in%inter%tsc(k)%x,in%inter%tsc(k)%y,in%inter%tsc(k)%z, &
+ in%inter%tsc(k)%length,in%inter%tsc(k)%width, &
+ in%inter%tsc(k)%strike,in%inter%tsc(k)%dip
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: tensile source index misfit")')
+ STOP 1
+ END IF
+ IF (MAX(in%inter%ts(k)%length,in%inter%ts(k)%width) .LE. 0._8) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: lengths must be positive.")')
+ STOP 1
+ END IF
+ IF (in%inter%ts(k)%length .lt. minlength) THEN
+ minlength=in%inter%ts(k)%length
+ END IF
+ IF (in%inter%ts(k)%width .lt. minwidth) THEN
+ minwidth =in%inter%ts(k)%width
+ END IF
+
+ ! smooth out the slip distribution
+ CALL antialiasingfilter(in%inter%ts(k)%slip, &
+ in%inter%ts(k)%length,in%inter%ts(k)%width, &
+ in%dx1,in%dx2,in%dx3,in%nyquist)
+
+ ! comply to Wang's convention
+ CALL wangconvention(in%inter%ts(k)%slip, &
+ in%inter%ts(k)%x,in%inter%ts(k)%y,in%inter%ts(k)%z, &
+ in%inter%ts(k)%length,in%inter%ts(k)%width, &
+ in%inter%ts(k)%strike,in%inter%ts(k)%dip,dummy, &
+ in%x0,in%y0,in%rot)
+
+ END DO
+ PRINT 2000
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! C 0 - S E I S M I C E V E N T S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of events"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%ne
+ PRINT '(I5)', in%ne
+ IF (in%ne .GT. 0) ALLOCATE(in%events(in%ne),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the event list"
+
+ DO e=1,in%ne
+ IF (1 .NE. e) THEN
+ PRINT '("time of next coseismic event")'
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%events(e)%time
+
+ IF (0 .EQ. in%skip) THEN
+ ! change event time to multiples of output time step
+ in%events(e)%time=int(in%events(e)%time/in%odt)*in%odt
+ END IF
+
+ PRINT '(ES9.2E1," (multiple of ",ES9.2E1,")")', &
+ in%events(e)%time,in%odt
+
+ IF (in%events(e)%time .LE. in%events(e-1)%time) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'(a,a)') "input file error. ", &
+ "coseismic source time must increase. interrupting."
+ STOP 1
+ END IF
+ ELSE
+ in%events(1)%time=0._8
+ in%events(1)%i=0
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! S H E A R S O U R C E S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of coseismic strike-slip segments"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%events(e)%ns
+ PRINT '(I5)', in%events(e)%ns
+ IF (in%events(e)%ns .GT. 0) THEN
+ ALLOCATE(in%events(e)%s(in%events(e)%ns),in%events(e)%sc(in%events(e)%ns), &
+ STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the source list"
+ PRINT 2000
+ PRINT '(a)',"no. slip xs ys zs length width strike dip rake"
+ PRINT 2000
+ DO k=1,in%events(e)%ns
+ CALL getdata(iunit,dataline)
+ READ (dataline,*,IOSTAT=iostatus) i,in%events(e)%s(k)%slip, &
+ in%events(e)%s(k)%x,in%events(e)%s(k)%y,in%events(e)%s(k)%z, &
+ in%events(e)%s(k)%length,in%events(e)%s(k)%width, &
+ in%events(e)%s(k)%strike,in%events(e)%s(k)%dip,in%events(e)%s(k)%rake, &
+ in%events(e)%s(k)%beta
+
+ SELECT CASE(iostatus)
+ CASE (1:)
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid shear source definition at line")')
+ WRITE (0,'(a)') dataline
+ STOP 1
+ CASE (0)
+ IF (in%events(e)%s(k)%beta.GT.0.5d8) STOP "invalid smoothing parameter (beta)."
+ CASE (:-1)
+ ! use default value for smoothing
+ in%events(e)%s(k)%beta=in%beta
+ END SELECT
+
+ ! copy the input format for display
+ in%events(e)%sc(k)=in%events(e)%s(k)
+
+ IF (iostatus.NE.0) THEN
+ PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1)',i, &
+ in%events(e)%sc(k)%slip,&
+ in%events(e)%sc(k)%x,in%events(e)%sc(k)%y,in%events(e)%sc(k)%z, &
+ in%events(e)%sc(k)%length,in%events(e)%sc(k)%width, &
+ in%events(e)%sc(k)%strike,in%events(e)%sc(k)%dip, &
+ in%events(e)%sc(k)%rake
+ ELSE
+ ! print the smoothing value for this patch
+ PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1,f6.1)',i, &
+ in%events(e)%sc(k)%slip,&
+ in%events(e)%sc(k)%x,in%events(e)%sc(k)%y,in%events(e)%sc(k)%z, &
+ in%events(e)%sc(k)%length,in%events(e)%sc(k)%width, &
+ in%events(e)%sc(k)%strike,in%events(e)%sc(k)%dip, &
+ in%events(e)%sc(k)%rake,in%events(e)%sc(k)%beta
+ END IF
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid shear source definition ")')
+ WRITE (0,'("error in input file: source index misfit")')
+ STOP 1
+ END IF
+ IF (MAX(in%events(e)%s(k)%length,in%events(e)%s(k)%width) .LE. 0._8) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: lengths must be positive.")')
+ STOP 1
+ END IF
+ IF (in%events(e)%s(k)%length .lt. minlength) THEN
+ minlength=in%events(e)%s(k)%length
+ END IF
+ IF (in%events(e)%s(k)%width .lt. minwidth ) THEN
+ minwidth =in%events(e)%s(k)%width
+ END IF
+
+ ! smooth out the slip distribution
+ CALL antialiasingfilter(in%events(e)%s(k)%slip, &
+ in%events(e)%s(k)%length,in%events(e)%s(k)%width, &
+ in%dx1,in%dx2,in%dx3,in%nyquist)
+
+ ! comply to Wang's convention
+ CALL wangconvention(in%events(e)%s(k)%slip, &
+ in%events(e)%s(k)%x,in%events(e)%s(k)%y,in%events(e)%s(k)%z, &
+ in%events(e)%s(k)%length,in%events(e)%s(k)%width, &
+ in%events(e)%s(k)%strike,in%events(e)%s(k)%dip, &
+ in%events(e)%s(k)%rake, &
+ in%x0,in%y0,in%rot)
+
+ END DO
+
+#ifdef VTK
+ ! export the fault segments in VTK format for the current event
+ WRITE (digit,'(I3.3)') e
+
+ rffilename=trim(in%wdir)//"/rfaults-"//digit//".vtp"
+ CALL exportvtk_rfaults(in%events(e),rffilename)
+#endif
+ rffilename=trim(in%wdir)//"/rfaults-"//digit//".xy"
+ CALL exportxy_rfaults(in%events(e),in%x0,in%y0,rffilename)
+
+ PRINT 2000
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! T E N S I L E S O U R C E S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of coseismic tensile segments"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%events(e)%nt
+ PRINT '(I5)', in%events(e)%nt
+ IF (in%events(e)%nt .GT. 0) THEN
+ ALLOCATE(in%events(e)%ts(in%events(e)%nt),in%events(e)%tsc(in%events(e)%nt), &
+ STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the tensile source list"
+ PRINT 2000
+ PRINT '(a)',"no. opening xs ys zs length width strike dip"
+ PRINT 2000
+ DO k=1,in%events(e)%nt
+
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,in%events(e)%ts(k)%slip, &
+ in%events(e)%ts(k)%x,in%events(e)%ts(k)%y,in%events(e)%ts(k)%z, &
+ in%events(e)%ts(k)%length,in%events(e)%ts(k)%width, &
+ in%events(e)%ts(k)%strike,in%events(e)%ts(k)%dip
+ ! copy the input format for display
+ in%events(e)%tsc(k)=in%events(e)%ts(k)
+
+ PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1)',k, &
+ in%events(e)%tsc(k)%slip,&
+ in%events(e)%tsc(k)%x,in%events(e)%tsc(k)%y,in%events(e)%tsc(k)%z, &
+ in%events(e)%tsc(k)%length,in%events(e)%tsc(k)%width, &
+ in%events(e)%tsc(k)%strike,in%events(e)%tsc(k)%dip
+
+ IF (i .ne. k) THEN
+ PRINT *, "error in input file: source index misfit"
+ STOP 1
+ END IF
+ IF (in%events(e)%ts(k)%length .lt. minlength) THEN
+ minlength=in%events(e)%ts(k)%length
+ END IF
+ IF (in%events(e)%ts(k)%width .lt. minwidth) THEN
+ minwidth =in%events(e)%ts(k)%width
+ END IF
+
+ ! smooth out the slip distribution
+ CALL antialiasingfilter(in%events(e)%ts(k)%slip, &
+ in%events(e)%ts(k)%length,in%events(e)%ts(k)%width, &
+ in%dx1,in%dx2,in%dx3,in%nyquist)
+
+ ! comply to Wang's convention
+ CALL wangconvention(in%events(e)%ts(k)%slip, &
+ in%events(e)%ts(k)%x,in%events(e)%ts(k)%y,in%events(e)%ts(k)%z, &
+ in%events(e)%ts(k)%length,in%events(e)%ts(k)%width, &
+ in%events(e)%ts(k)%strike,in%events(e)%ts(k)%dip,dummy, &
+ in%x0,in%y0,in%rot)
+
+ END DO
+ PRINT 2000
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! M O G I S O U R C E S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of coseismic dilatation point sources"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%events(e)%nm
+ PRINT '(I5)', in%events(e)%nm
+ IF (in%events(e)%nm .GT. 0) THEN
+ ALLOCATE(in%events(e)%m(in%events(e)%nm),in%events(e)%mc(in%events(e)%nm), &
+ STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the tensile source list"
+ PRINT 2000
+ PRINT '(a)',"no. strain (positive for extension) xs ys zs"
+ PRINT 2000
+ DO k=1,in%events(e)%nm
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,in%events(e)%m(k)%slip, &
+ in%events(e)%m(k)%x,in%events(e)%m(k)%y,in%events(e)%m(k)%z
+ ! copy the input format for display
+ in%events(e)%mc(k)=in%events(e)%m(k)
+
+ PRINT '(I3.3,4ES9.2E1)',k, &
+ in%events(e)%mc(k)%slip,&
+ in%events(e)%mc(k)%x,in%events(e)%mc(k)%y,in%events(e)%mc(k)%z
+
+ IF (i .ne. k) THEN
+ PRINT *, "error in input file: source index misfit"
+ STOP 1
+ END IF
+
+ ! rotate the source in the computational reference frame
+ CALL rotation(in%events(e)%m(k)%x,in%events(e)%m(k)%y,in%rot)
+ END DO
+ PRINT 2000
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! S U R F A C E L O A D S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of surface loads"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) in%events(e)%nl
+ PRINT '(I5)', in%events(e)%nl
+ IF (in%events(e)%nl .GT. 0) THEN
+ ALLOCATE(in%events(e)%l(in%events(e)%nl),in%events(e)%lc(in%events(e)%nl), &
+ STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the load list"
+ PRINT 2000
+ PRINT '(a)',"t3 in units of force/surface/rigidity, positive down"
+ PRINT '(a)',"T>0 for t3 sin(2pi/T+phi), T<=0 for t3 H(t)"
+ PRINT '(a)',"no. xs ys length width t3 T phi"
+ PRINT 2000
+ DO k=1,in%events(e)%nl
+ CALL getdata(iunit,dataline)
+ READ (dataline,*,IOSTAT=iostatus) i, &
+ in%events(e)%l(k)%x,in%events(e)%l(k)%y, &
+ in%events(e)%l(k)%length,in%events(e)%l(k)%width, &
+ in%events(e)%l(k)%slip, &
+ in%events(e)%l(k)%period,in%events(e)%l(k)%phase, &
+ in%events(e)%l(k)%beta
+
+ SELECT CASE(iostatus)
+ CASE (1:)
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid surface load definition at line")')
+ WRITE (0,'(a)') dataline
+ STOP 1
+ CASE (0)
+ IF (in%events(e)%l(k)%beta.GT.0.5d8) STOP "invalid smoothing parameter beta."
+ CASE (:-1)
+ ! use default value for smoothing
+ in%events(e)%l(k)%beta=in%beta
+ END SELECT
+
+ ! copy the input format for display
+ in%events(e)%lc(k)=in%events(e)%l(k)
+
+ IF (iostatus.EQ.0) THEN
+ PRINT '(I3.3,9ES9.2E1)',k, &
+ in%events(e)%lc(k)%x,in%events(e)%lc(k)%y, &
+ in%events(e)%lc(k)%length,in%events(e)%lc(k)%width, &
+ in%events(e)%lc(k)%slip, &
+ in%events(e)%lc(k)%period,in%events(e)%lc(k)%phase, &
+ in%events(e)%lc(k)%beta
+ ELSE
+ PRINT '(I3.3,8ES9.2E1)',k, &
+ in%events(e)%lc(k)%x,in%events(e)%lc(k)%y, &
+ in%events(e)%lc(k)%length,in%events(e)%lc(k)%width, &
+ in%events(e)%lc(k)%slip, &
+ in%events(e)%lc(k)%period,in%events(e)%lc(k)%phase
+ END IF
+
+ IF (i .NE. k) THEN
+ PRINT *, "error in input file: source index misfit"
+ STOP 1
+ END IF
+
+ ! rotate the source in the computational reference frame
+ CALL rotation(in%events(e)%l(k)%x,in%events(e)%l(k)%y,in%rot)
+ END DO
+ PRINT 2000
+ END IF
+
+ END DO
+
+ ! test the presence of dislocations for coseismic calculation
+ IF ((in%events(1)%nt .EQ. 0) .AND. &
+ (in%events(1)%ns .EQ. 0) .AND. &
+ (in%events(1)%nm .EQ. 0) .AND. &
+ (in%events(1)%nl .EQ. 0) .AND. &
+ (in%interval .LE. 0._8)) THEN
+
+ WRITE_DEBUG_INFO
+ WRITE (0,'("**** error **** ")')
+ WRITE (0,'("no input dislocations or dilatation point sources")')
+ WRITE (0,'("or surface tractions for first event . exiting.")')
+ STOP 1
+ END IF
+
+ ! maximum recommended sampling size
+ PRINT '(a,2ES8.2E1)', &
+ "max sampling size (hor.,vert.):", minlength/2.5_8,minwidth/2.5_8
+
+ PRINT 2000
+
+2000 FORMAT ("----------------------------------------------------------------------------")
+2100 FORMAT ("no. x1 x2 x3 length width strike dip")
+2200 FORMAT ("no. slip x1 x2 x3 length width strike dip rake")
+2300 FORMAT ("no. name x1 x2 x3 (name is a 4-character string)")
+2400 FORMAT ("no. strain x1 x2 x3 (positive for extension)")
+2500 FORMAT ("no. x1 x2 x3 length width strike dip rake")
+
+ END SUBROUTINE init
+
+ !------------------------------------------------------------------
+ !> subroutine WangConvention
+ !! converts a fault slip model from a geologic description including
+ !! fault length, width, strike, dip and rake into a description
+ !! compatible with internal convention of the program.
+ !!
+ !! Internal convention describes a fault patch by the location of
+ !! its center, instead of an upper corner and its orientation by
+ !! the deviation from the vertical, instead of the angle from the
+ !! horizontal and by the angle from the x2 axis (East-West)
+ !------------------------------------------------------------------
+ SUBROUTINE wangconvention(slip,x,y,z,length,width,strike,dip,rake,x0,y0,rot)
+ REAL*8, INTENT(OUT) :: slip, x,y,z,strike,dip,rake
+ REAL*8, INTENT(IN) :: length,width,x0,y0,rot
+
+ slip=-slip
+ strike=-90._8-strike
+ dip = 90._8-dip
+
+ strike=strike*DEG2RAD
+ dip=dip*DEG2RAD
+ rake=rake*DEG2RAD
+
+ x=x-x0-length/2._8*sin(strike)+width /2._8*sin(dip)*cos(strike)
+ y=y-y0-length/2._8*cos(strike)-width /2._8*sin(dip)*sin(strike)
+ z=z+width /2._8*cos(dip)
+
+ CALL rotation(x,y,rot)
+
+ strike=strike+rot*DEG2RAD
+
+ END SUBROUTINE wangconvention
+
+ !------------------------------------------------------------------
+ !> subroutine Rotation
+ !! rotates a point coordinate into the computational reference
+ !! system.
+ !!
+ !! \author sylvain barbot (04/16/09) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE rotation(x,y,rot)
+ REAL*8, INTENT(INOUT) :: x,y
+ REAL*8, INTENT(IN) :: rot
+
+ REAL*8 :: alpha,xx,yy
+
+ alpha=rot*DEG2RAD
+ xx=x
+ yy=y
+
+ x=+xx*cos(alpha)+yy*sin(alpha)
+ y=-xx*sin(alpha)+yy*cos(alpha)
+
+ END SUBROUTINE rotation
+
+ !-------------------------------------------------------------------
+ !> subroutine AntiAliasingFilter
+ !! smoothes a slip distribution model to avoid aliasing of
+ !! the source geometry. Aliasing occurs is a slip patch has
+ !! dimensions (width or length) smaller than the grid sampling.
+ !!
+ !! if a patch length is smaller than a critical size L=dx*nyquist, it
+ !! is increased to L and the slip (or opening) is scaled accordingly
+ !! so that the moment M = s*L*W is conserved.
+ !!
+ !! \author sylvain barbot (12/08/09) - original form
+ !-------------------------------------------------------------------
+ SUBROUTINE antialiasingfilter(slip,length,width,dx1,dx2,dx3,nyquist)
+ REAL*8, INTENT(INOUT) :: slip,length,width
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3,nyquist
+
+ REAL*8 :: dx
+
+ ! minimum slip patch dimension
+ dx=MIN(dx1,dx2,dx3)*nyquist
+
+ ! update length
+ IF (length .LT. dx) THEN
+ slip=slip*length/dx
+ length=dx
+ END IF
+ ! update width
+ IF (width .LT. dx) THEN
+ slip=slip*width/dx
+ width=dx
+ END IF
+
+ END SUBROUTINE antialiasingfilter
+
+END MODULE input
diff -r 405d8f4fa05f -r e7295294f654 src/kernel1.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/kernel1.inc Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,3 @@
+ ! centered finite difference scheme
+ REAL*8, PARAMETER, DIMENSION(1) :: &
+ fir1= (/ 5.000e-01 /) ! filter kernel
diff -r 405d8f4fa05f -r e7295294f654 src/kernel11.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/kernel11.inc Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,12 @@
+ REAL*8, PARAMETER, DIMENSION(11) :: &
+ fir11=(/ 9.137025467466382e-01, &
+ -3.444134215167435e-01, &
+ +1.372354550142238e-01, &
+ -4.472371911116056e-02, &
+ +9.983584006653466e-03, &
+ -4.203347378221815e-03, &
+ +8.867064453003781e-03, &
+ -1.331685333641829e-02, &
+ +1.339297753637801e-02, &
+ -9.762756789626834e-03, &
+ +3.560973264270618e-03 /)
diff -r 405d8f4fa05f -r e7295294f654 src/kernel14.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/kernel14.inc Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,15 @@
+ REAL*8, PARAMETER, DIMENSION(14) :: &
+ fir14=(/ 9.487587545326932e-01, &
+ -4.040368216139801e-01, &
+ 2.042931326579159e-01, &
+ -1.022548584863014e-01, &
+ 4.783260352969341e-02, &
+ -2.180739012077366e-02, &
+ 1.283800669716571e-02, &
+ -1.276100476817563e-02, &
+ 1.558222334928575e-02, &
+ -1.758387786545944e-02, &
+ 1.707389141666987e-02, &
+ -1.420560243259215e-02, &
+ 1.081740233347091e-02, &
+ -4.501057368601819e-03/)
diff -r 405d8f4fa05f -r e7295294f654 src/kernel14bis.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/kernel14bis.inc Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,16 @@
+
+ REAL*8, PARAMETER, DIMENSION(14) :: &
+ fir14=(/ 9.739464097198434e-01, &
+ -4.492955962260918e-01, &
+ 2.606661503992121e-01, &
+ -1.590778397098753e-01, &
+ 9.524605395168785e-02, &
+ -5.279001022321913e-02, &
+ 2.452656124714124e-02, &
+ -6.434920307760272e-03, &
+ -4.122947453390886e-03, &
+ 9.245789328795669e-03, &
+ -1.060146500976655e-02, &
+ 9.786847569837574e-03, &
+ -9.114943973080788e-03, &
+ 4.398360884720647e-03 /)
\ No newline at end of file
diff -r 405d8f4fa05f -r e7295294f654 src/kernel7.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/kernel7.inc Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,9 @@
+ REAL*8, PARAMETER, DIMENSION(7) :: &
+ fir7=(/ 8.77856e-01, &
+ -2.81913e-01, &
+ +6.22696e-02, &
+ +2.82441e-02, &
+ -5.09029e-02, &
+ +4.20471e-02, &
+ -1.59409e-02 /) ! filter kernel
+!0.97125_8*
\ No newline at end of file
diff -r 405d8f4fa05f -r e7295294f654 src/mkl_dfti.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/mkl_dfti.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,862 @@
+!*****************************************************************************
+! INTEL CONFIDENTIAL
+! Copyright(C) 2002-2010 Intel Corporation. All Rights Reserved.
+! The source code contained or described herein and all documents related to
+! the source code ("Material") are owned by Intel Corporation or its suppliers
+! or licensors. Title to the Material remains with Intel Corporation or its
+! suppliers and licensors. The Material contains trade secrets and proprietary
+! and confidential information of Intel or its suppliers and licensors. The
+! Material is protected by worldwide copyright and trade secret laws and
+! treaty provisions. No part of the Material may be used, copied, reproduced,
+! modified, published, uploaded, posted, transmitted, distributed or disclosed
+! in any way without Intel's prior express written permission.
+! No license under any patent, copyright, trade secret or other intellectual
+! property right is granted to or conferred upon you by disclosure or delivery
+! of the Materials, either expressly, by implication, inducement, estoppel or
+! otherwise. Any license under such intellectual property rights must be
+! express and approved by Intel in writing.
+!
+!*****************************************************************************
+! Content:
+! Intel(R) Math Kernel Library (MKL)
+! Discrete Fourier Transform Interface (DFTI)
+!*****************************************************************************
+
+MODULE MKL_DFT_TYPE
+
+ TYPE, PUBLIC :: DFTI_DESCRIPTOR
+ PRIVATE
+ INTEGER :: dontuse
+ ! Structure of this type is not used in Fortran code
+ ! the pointer to this type is used only
+ END TYPE DFTI_DESCRIPTOR
+
+ !======================================================================
+ ! These real type kind parameters are not for direct use
+ !======================================================================
+
+ INTEGER, PARAMETER :: DFTI_SPKP = SELECTED_REAL_KIND(6,37)
+ INTEGER, PARAMETER :: DFTI_DPKP = SELECTED_REAL_KIND(15,307)
+
+ !======================================================================
+ ! Descriptor configuration parameters [default values in brackets]
+ !======================================================================
+
+ ! Domain for forward transform. No default value
+ INTEGER, PARAMETER :: DFTI_FORWARD_DOMAIN = 0
+
+ ! Dimensionality, or rank. No default value
+ INTEGER, PARAMETER :: DFTI_DIMENSION = 1
+
+ ! Length(s) of transform. No default value
+ INTEGER, PARAMETER :: DFTI_LENGTHS = 2
+
+ ! Floating point precision. No default value
+ INTEGER, PARAMETER :: DFTI_PRECISION = 3
+
+ ! Scale factor for forward transform [1.0]
+ INTEGER, PARAMETER :: DFTI_FORWARD_SCALE = 4
+
+ ! Scale factor for backward transform [1.0]
+ INTEGER, PARAMETER :: DFTI_BACKWARD_SCALE = 5
+
+ ! Exponent sign for forward transform [DFTI_NEGATIVE]
+ ! INTEGER, PARAMETER :: DFTI_FORWARD_SIGN = 6 ! NOT IMPLEMENTED
+
+ ! Number of data sets to be transformed [1]
+ INTEGER, PARAMETER :: DFTI_NUMBER_OF_TRANSFORMS = 7
+
+ ! Storage of finite complex-valued sequences in complex domain
+ ! [DFTI_COMPLEX_COMPLEX]
+ INTEGER, PARAMETER :: DFTI_COMPLEX_STORAGE = 8
+
+ ! Storage of finite real-valued sequences in real domain
+ ! [DFTI_REAL_REAL]
+ INTEGER, PARAMETER :: DFTI_REAL_STORAGE = 9
+
+ ! Storage of finite complex-valued sequences in conjugate-even
+ ! domain [DFTI_COMPLEX_REAL]
+ INTEGER, PARAMETER :: DFTI_CONJUGATE_EVEN_STORAGE = 10
+
+ ! Placement of result [DFTI_INPLACE]
+ INTEGER, PARAMETER :: DFTI_PLACEMENT = 11
+
+ ! Generalized strides for input data layout
+ ! [tigth, col-major for Fortran]
+ INTEGER, PARAMETER :: DFTI_INPUT_STRIDES = 12
+
+ ! Generalized strides for output data layout
+ ! [tigth, col-major for Fortran]
+ INTEGER, PARAMETER :: DFTI_OUTPUT_STRIDES = 13
+
+ ! Distance between first input elements for multiple transforms [0]
+ INTEGER, PARAMETER :: DFTI_INPUT_DISTANCE = 14
+
+ ! Distance between first output elements for multiple transforms [0]
+ INTEGER, PARAMETER :: DFTI_OUTPUT_DISTANCE = 15
+
+ ! Effort spent in initialization [DFTI_MEDIUM]
+ ! INTEGER, PARAMETER :: DFTI_INITIALIZATION_EFFORT = 16 ! NOT IMPLEMENTED
+
+ ! Use of workspace during computation [DFTI_ALLOW]
+ ! INTEGER, PARAMETER :: DFTI_WORKSPACE = 17 ! NOT IMPLEMENTED
+
+ ! Ordering of the result [DFTI_ORDERED]
+ INTEGER, PARAMETER :: DFTI_ORDERING = 18
+
+ ! Possible transposition of result [DFTI_NONE]
+ INTEGER, PARAMETER :: DFTI_TRANSPOSE = 19
+
+ ! User-settable descriptor name [""]
+ INTEGER, PARAMETER :: DFTI_DESCRIPTOR_NAME = 20
+
+ ! Packing format for DFTI_COMPLEX_REAL storage of finite
+ ! conjugate-even sequences [DFTI_CCS_FORMAT]
+ INTEGER, PARAMETER :: DFTI_PACKED_FORMAT = 21
+
+ ! Commit status of the descriptor. Read-only parameter
+ INTEGER, PARAMETER :: DFTI_COMMIT_STATUS = 22
+
+ ! Version string for this DFTI implementation. Read-only parameter
+ INTEGER, PARAMETER :: DFTI_VERSION = 23
+
+ ! Ordering of the forward transform. Read-only parameter
+ ! INTEGER, PARAMETER :: DFTI_FORWARD_ORDERING = 24 ! NOT IMPLEMENTED
+
+ ! Ordering of the backward transform. Read-only parameter
+ ! INTEGER, PARAMETER :: DFTI_BACKWARD_ORDERING = 25 ! NOT IMPLEMENTED
+
+ ! Number of user threads that share the descriptor [1]
+ INTEGER, PARAMETER :: DFTI_NUMBER_OF_USER_THREADS = 26
+
+ !======================================================================
+ ! Values of the descriptor configuration parameters
+ !======================================================================
+
+ ! DFTI_COMMIT_STATUS
+ INTEGER, PARAMETER :: DFTI_COMMITTED = 30
+ INTEGER, PARAMETER :: DFTI_UNCOMMITTED = 31
+
+ ! DFTI_FORWARD_DOMAIN
+ INTEGER, PARAMETER :: DFTI_COMPLEX = 32
+ INTEGER, PARAMETER :: DFTI_REAL = 33
+ ! INTEGER, PARAMETER :: DFTI_CONJUGATE_EVEN = 34 ! NOT IMPLEMENTED
+
+ ! DFTI_PRECISION
+ INTEGER, PARAMETER :: DFTI_SINGLE = 35
+ INTEGER, PARAMETER :: DFTI_DOUBLE = 36
+
+ ! DFTI_PRECISION for reduced size of statically linked application.
+ ! Recommended use: modify statement 'USE MKL_DFTI' in your program,
+ ! so that it reads as either of:
+ ! USE MKL_DFTI, FORGET=>DFTI_SINGLE, DFTI_SINGLE=>DFTI_SINGLE_R
+ ! USE MKL_DFTI, FORGET=>DFTI_DOUBLE, DFTI_DOUBLE=>DFTI_DOUBLE_R
+ ! where word 'FORGET' can be any name not used in the program.
+ REAL(DFTI_SPKP), PARAMETER :: DFTI_SINGLE_R = 35
+ REAL(DFTI_DPKP), PARAMETER :: DFTI_DOUBLE_R = 36
+
+ ! DFTI_FORWARD_SIGN
+ ! INTEGER, PARAMETER :: DFTI_NEGATIVE = 37 ! NOT IMPLEMENTED
+ ! INTEGER, PARAMETER :: DFTI_POSITIVE = 38 ! NOT IMPLEMENTED
+
+ ! DFTI_COMPLEX_STORAGE and DFTI_CONJUGATE_EVEN_STORAGE
+ INTEGER, PARAMETER :: DFTI_COMPLEX_COMPLEX = 39
+ INTEGER, PARAMETER :: DFTI_COMPLEX_REAL = 40
+
+ ! DFTI_REAL_STORAGE
+ INTEGER, PARAMETER :: DFTI_REAL_COMPLEX = 41
+ INTEGER, PARAMETER :: DFTI_REAL_REAL = 42
+
+ ! DFTI_PLACEMENT
+ INTEGER, PARAMETER :: DFTI_INPLACE = 43 ! Result overwrites input
+ INTEGER, PARAMETER :: DFTI_NOT_INPLACE = 44 ! Have another place for result
+
+ ! DFTI_INITIALIZATION_EFFORT
+ ! INTEGER, PARAMETER :: DFTI_LOW = 45 ! NOT IMPLEMENTED
+ ! INTEGER, PARAMETER :: DFTI_MEDIUM = 46 ! NOT IMPLEMENTED
+ ! INTEGER, PARAMETER :: DFTI_HIGH = 47 ! NOT IMPLEMENTED
+
+ ! DFTI_ORDERING
+ INTEGER, PARAMETER :: DFTI_ORDERED = 48
+ INTEGER, PARAMETER :: DFTI_BACKWARD_SCRAMBLED = 49
+ ! INTEGER, PARAMETER :: DFTI_FORWARD_SCRAMBLED = 50 ! NOT IMPLEMENTED
+
+ ! Allow/avoid certain usages
+ INTEGER, PARAMETER :: DFTI_ALLOW = 51 ! Allow transposition or workspace
+ ! INTEGER, PARAMETER :: DFTI_AVOID = 52 ! NOT IMPLEMENTED
+ INTEGER, PARAMETER :: DFTI_NONE = 53
+
+ ! DFTI_PACKED_FORMAT
+ ! (for storing congugate-even finite sequence in real array)
+ INTEGER, PARAMETER :: DFTI_CCS_FORMAT = 54 ! Complex conjugate-symmetric
+ INTEGER, PARAMETER :: DFTI_PACK_FORMAT = 55 ! Pack format for real DFT
+ INTEGER, PARAMETER :: DFTI_PERM_FORMAT = 56 ! Perm format for real DFT
+ INTEGER, PARAMETER :: DFTI_CCE_FORMAT = 57 ! Complex conjugate-even
+
+ !======================================================================
+ ! Error classes
+ !======================================================================
+ INTEGER, PARAMETER :: DFTI_NO_ERROR = 0
+ INTEGER, PARAMETER :: DFTI_MEMORY_ERROR = 1
+ INTEGER, PARAMETER :: DFTI_INVALID_CONFIGURATION = 2
+ INTEGER, PARAMETER :: DFTI_INCONSISTENT_CONFIGURATION = 3
+ INTEGER, PARAMETER :: DFTI_MULTITHREADED_ERROR = 4
+ INTEGER, PARAMETER :: DFTI_BAD_DESCRIPTOR = 5
+ INTEGER, PARAMETER :: DFTI_UNIMPLEMENTED = 6
+ INTEGER, PARAMETER :: DFTI_MKL_INTERNAL_ERROR = 7
+ INTEGER, PARAMETER :: DFTI_NUMBER_OF_THREADS_ERROR = 8
+ INTEGER, PARAMETER :: DFTI_1D_LENGTH_EXCEEDS_INT32 = 9
+
+ ! Maximum length of error string
+ INTEGER, PARAMETER :: DFTI_MAX_MESSAGE_LENGTH = 80
+
+ ! Maximum length of user-settable descriptor name
+ INTEGER, PARAMETER :: DFTI_MAX_NAME_LENGTH = 10
+
+ ! Maximum length of MKL version string
+ INTEGER, PARAMETER :: DFTI_VERSION_LENGTH = 198
+
+ ! (deprecated parameter)
+ INTEGER, PARAMETER :: DFTI_ERROR_CLASS = 60
+
+END MODULE MKL_DFT_TYPE
+
+MODULE MKL_DFTI
+
+ USE MKL_DFT_TYPE
+
+ INTERFACE DftiCreateDescriptor
+
+ FUNCTION dfti_create_descriptor_1d(desc, precision, domain, dim, length)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_create_descriptor_1d
+ !MS$ATTRIBUTES REFERENCE :: precision
+ !MS$ATTRIBUTES REFERENCE :: domain
+ !MS$ATTRIBUTES REFERENCE :: dim
+ !MS$ATTRIBUTES REFERENCE :: length
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_create_descriptor_1d
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ INTEGER, INTENT(IN) :: precision
+ INTEGER, INTENT(IN) :: domain
+ INTEGER, INTENT(IN) :: dim, length
+ END FUNCTION dfti_create_descriptor_1d
+
+ FUNCTION dfti_create_descriptor_highd(desc, precision, domain, dim,length)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_create_descriptor_highd
+ !MS$ATTRIBUTES REFERENCE :: precision
+ !MS$ATTRIBUTES REFERENCE :: domain
+ !MS$ATTRIBUTES REFERENCE :: dim
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_create_descriptor_highd
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ INTEGER, INTENT(IN) :: precision
+ INTEGER, INTENT(IN) :: domain
+ INTEGER, INTENT(IN) :: dim
+ INTEGER, INTENT(IN), DIMENSION(*) :: length
+ END FUNCTION dfti_create_descriptor_highd
+
+ FUNCTION dfti_create_descriptor_s_1d(desc, s, dom, one, dim)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_create_descriptor_s_1d
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: s
+ !MS$ATTRIBUTES REFERENCE :: dom
+ !MS$ATTRIBUTES REFERENCE :: one
+ !MS$ATTRIBUTES REFERENCE :: dim
+ INTEGER dfti_create_descriptor_s_1d
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), INTENT(IN) :: s
+ INTEGER, INTENT(IN) :: dom
+ INTEGER, INTENT(IN) :: one
+ INTEGER, INTENT(IN) :: dim
+ END FUNCTION dfti_create_descriptor_s_1d
+
+ FUNCTION dfti_create_descriptor_s_md(desc, s, dom, many, dims)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_create_descriptor_s_md
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: s
+ !MS$ATTRIBUTES REFERENCE :: dom
+ !MS$ATTRIBUTES REFERENCE :: many
+ !MS$ATTRIBUTES REFERENCE :: dims
+ INTEGER dfti_create_descriptor_s_md
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), INTENT(IN) :: s
+ INTEGER, INTENT(IN) :: dom
+ INTEGER, INTENT(IN) :: many
+ INTEGER, INTENT(IN), DIMENSION(*) :: dims
+ END FUNCTION dfti_create_descriptor_s_md
+
+ FUNCTION dfti_create_descriptor_d_1d(desc, d, dom, one, dim)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_create_descriptor_d_1d
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: d
+ !MS$ATTRIBUTES REFERENCE :: dom
+ !MS$ATTRIBUTES REFERENCE :: one
+ !MS$ATTRIBUTES REFERENCE :: dim
+ INTEGER dfti_create_descriptor_d_1d
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), INTENT(IN) :: d
+ INTEGER, INTENT(IN) :: dom
+ INTEGER, INTENT(IN) :: one
+ INTEGER, INTENT(IN) :: dim
+ END FUNCTION dfti_create_descriptor_d_1d
+
+ FUNCTION dfti_create_descriptor_d_md(desc, d, dom, many, dims)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_create_descriptor_d_md
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: d
+ !MS$ATTRIBUTES REFERENCE :: dom
+ !MS$ATTRIBUTES REFERENCE :: many
+ !MS$ATTRIBUTES REFERENCE :: dims
+ INTEGER dfti_create_descriptor_d_md
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), INTENT(IN) :: d
+ INTEGER, INTENT(IN) :: dom
+ INTEGER, INTENT(IN) :: many
+ INTEGER, INTENT(IN), DIMENSION(*) :: dims
+ END FUNCTION dfti_create_descriptor_d_md
+
+ END INTERFACE
+
+ INTERFACE DftiCopyDescriptor
+
+ FUNCTION dfti_copy_descriptor_external(desc, new_desc)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_copy_descriptor_external
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: new_desc
+ INTEGER dfti_copy_descriptor_external
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ TYPE(DFTI_DESCRIPTOR), POINTER :: new_desc
+ END FUNCTION dfti_copy_descriptor_external
+
+ END INTERFACE
+
+ INTERFACE DftiCommitDescriptor
+
+ FUNCTION dfti_commit_descriptor_external(desc)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_commit_descriptor_external
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_commit_descriptor_external
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_commit_descriptor_external
+
+ END INTERFACE
+
+ INTERFACE DftiSetValue
+
+ FUNCTION dfti_set_value_intval(desc, OptName, IntVal)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_set_value_intval
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: IntVal
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_set_value_intval
+ INTEGER, INTENT(IN) :: OptName
+ INTEGER, INTENT(IN) :: IntVal
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_set_value_intval
+
+ FUNCTION dfti_set_value_sglval(desc, OptName, sglval)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_set_value_sglval
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: sglval
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_set_value_sglval
+ INTEGER, INTENT(IN) :: OptName
+ REAL(DFTI_SPKP), INTENT(IN) :: sglval
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_set_value_sglval
+
+ FUNCTION dfti_set_value_dblval(desc, OptName, DblVal)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_set_value_dblval
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: DblVal
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_set_value_dblval
+ INTEGER, INTENT(IN) :: OptName
+ REAL(DFTI_DPKP), INTENT(IN) :: DblVal
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_set_value_dblval
+
+ FUNCTION dfti_set_value_intvec(desc, OptName, IntVec)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_set_value_intvec
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: IntVec
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_set_value_intvec
+ INTEGER, INTENT(IN) :: OptName
+ INTEGER, INTENT(IN), DIMENSION(*) :: IntVec
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_set_value_intvec
+
+ FUNCTION dfti_set_value_chars(desc, OptName, Chars)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_set_value_chars
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: dfti_set_value_chars
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_set_value_chars
+ INTEGER, INTENT(IN) :: OptName
+ CHARACTER(*), INTENT(IN) :: Chars
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_set_value_chars
+
+ END INTERFACE
+
+ INTERFACE DftiGetValue
+
+ FUNCTION dfti_get_value_intval(desc, OptName, IntVal)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_get_value_intval
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: IntVal
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_get_value_intval
+ INTEGER, INTENT(IN) :: OptName
+ INTEGER, INTENT(OUT) :: IntVal
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_get_value_intval
+
+ FUNCTION dfti_get_value_sglval(desc, OptName, sglval)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_get_value_sglval
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: sglval
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_get_value_sglval
+ INTEGER, INTENT(IN) :: OptName
+ REAL(DFTI_SPKP), INTENT(OUT) :: sglval
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_get_value_sglval
+
+ FUNCTION dfti_get_value_dblval(desc, OptName, DblVal)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_get_value_dblval
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: DblVal
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_get_value_dblval
+ INTEGER, INTENT(IN) :: OptName
+ REAL(DFTI_DPKP), INTENT(OUT) :: DblVal
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_get_value_dblval
+
+ FUNCTION dfti_get_value_intvec(desc, OptName, IntVec)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_get_value_intvec
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: IntVec
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_get_value_intvec
+ INTEGER, INTENT(IN) :: OptName
+ INTEGER, INTENT(OUT), DIMENSION(*) :: IntVec
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_get_value_intvec
+
+ FUNCTION dfti_get_value_chars(desc, OptName, Chars)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_get_value_chars
+ !MS$ATTRIBUTES REFERENCE :: OptName
+ !MS$ATTRIBUTES REFERENCE :: dfti_get_value_chars
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_get_value_chars
+ INTEGER, INTENT(IN) :: OptName
+ CHARACTER(*), INTENT(OUT) :: Chars
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_get_value_chars
+
+ END INTERFACE
+
+ INTERFACE DftiComputeForward
+
+ FUNCTION dfti_compute_forward_s(desc,sSrcDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_s
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: sSrcDst
+ INTEGER dfti_compute_forward_s
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: sSrcDst
+ END FUNCTION dfti_compute_forward_s
+
+ FUNCTION dfti_compute_forward_c(desc,cSrcDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_c
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: cSrcDst
+ INTEGER dfti_compute_forward_c
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: cSrcDst
+ END FUNCTION dfti_compute_forward_c
+
+ FUNCTION dfti_compute_forward_ss(desc,sSrcDstRe,sSrcDstIm)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_ss
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: sSrcDstRe
+ !MS$ATTRIBUTES REFERENCE :: sSrcDstIm
+ INTEGER dfti_compute_forward_ss
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstRe
+ REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstIm
+ END FUNCTION dfti_compute_forward_ss
+
+ FUNCTION dfti_compute_forward_sc(desc,sSrc,cDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_sc
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: sSrc
+ !MS$ATTRIBUTES REFERENCE :: cDst
+ INTEGER dfti_compute_forward_sc
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrc
+ COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
+ END FUNCTION dfti_compute_forward_sc
+
+ FUNCTION dfti_compute_forward_cs(desc,cSrc,sDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_cs
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: cSrc
+ !MS$ATTRIBUTES REFERENCE :: sDst
+ INTEGER dfti_compute_forward_cs
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
+ REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDst
+ END FUNCTION dfti_compute_forward_cs
+
+ FUNCTION dfti_compute_forward_cc(desc,cSrc,cDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_cc
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: cSrc
+ !MS$ATTRIBUTES REFERENCE :: cDst
+ INTEGER dfti_compute_forward_cc
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
+ COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
+ END FUNCTION dfti_compute_forward_cc
+
+ FUNCTION dfti_compute_forward_ssss(desc,sSrcRe,sSrcIm,sDstRe,sDstIm)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_ssss
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: sSrcRe
+ !MS$ATTRIBUTES REFERENCE :: sSrcIm
+ !MS$ATTRIBUTES REFERENCE :: sDstRe
+ !MS$ATTRIBUTES REFERENCE :: sDstIm
+ INTEGER dfti_compute_forward_ssss
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcRe
+ REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcIm
+ REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstRe
+ REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstIm
+ END FUNCTION dfti_compute_forward_ssss
+
+ FUNCTION dfti_compute_forward_d(desc,dSrcDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_d
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: dSrcDst
+ INTEGER dfti_compute_forward_d
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: dSrcDst
+ END FUNCTION dfti_compute_forward_d
+
+ FUNCTION dfti_compute_forward_z(desc,zSrcDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_z
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: zSrcDst
+ INTEGER dfti_compute_forward_z
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: zSrcDst
+ END FUNCTION dfti_compute_forward_z
+
+ FUNCTION dfti_compute_forward_dd(desc,dSrcDstRe,dSrcDstIm)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_dd
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: dSrcDstRe
+ !MS$ATTRIBUTES REFERENCE :: dSrcDstIm
+ INTEGER dfti_compute_forward_dd
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstRe
+ REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstIm
+ END FUNCTION dfti_compute_forward_dd
+
+ FUNCTION dfti_compute_forward_dz(desc,dSrc,zDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_dz
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: dSrc
+ !MS$ATTRIBUTES REFERENCE :: zDst
+ INTEGER dfti_compute_forward_dz
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrc
+ COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
+ END FUNCTION dfti_compute_forward_dz
+
+ FUNCTION dfti_compute_forward_zd(desc,zSrc,dDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_zd
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: zSrc
+ !MS$ATTRIBUTES REFERENCE :: dDst
+ INTEGER dfti_compute_forward_zd
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
+ REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDst
+ END FUNCTION dfti_compute_forward_zd
+
+ FUNCTION dfti_compute_forward_zz(desc,zSrc,zDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_zz
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: zSrc
+ !MS$ATTRIBUTES REFERENCE :: zDst
+ INTEGER dfti_compute_forward_zz
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
+ COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
+ END FUNCTION dfti_compute_forward_zz
+
+ FUNCTION dfti_compute_forward_dddd(desc,dSrcRe,dSrcIm,dDstRe,dDstIm)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_forward_dddd
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: dSrcRe
+ !MS$ATTRIBUTES REFERENCE :: dSrcIm
+ !MS$ATTRIBUTES REFERENCE :: dDstRe
+ !MS$ATTRIBUTES REFERENCE :: dDstIm
+ INTEGER dfti_compute_forward_dddd
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcRe
+ REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcIm
+ REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstRe
+ REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstIm
+ END FUNCTION dfti_compute_forward_dddd
+
+ END INTERFACE DftiComputeForward
+
+ INTERFACE DftiComputeBackward
+
+ FUNCTION dfti_compute_backward_s(desc,sSrcDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_s
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: sSrcDst
+ INTEGER dfti_compute_backward_s
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: sSrcDst
+ END FUNCTION dfti_compute_backward_s
+
+ FUNCTION dfti_compute_backward_c(desc,cSrcDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_c
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: cSrcDst
+ INTEGER dfti_compute_backward_c
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_SPKP), INTENT(INOUT), DIMENSION(*) :: cSrcDst
+ END FUNCTION dfti_compute_backward_c
+
+ FUNCTION dfti_compute_backward_ss(desc,sSrcDstRe,sSrcDstIm)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_ss
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: sSrcDstRe
+ !MS$ATTRIBUTES REFERENCE :: sSrcDstIm
+ INTEGER dfti_compute_backward_ss
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstRe
+ REAL(DFTI_SPKP), DIMENSION(*) :: sSrcDstIm
+ END FUNCTION dfti_compute_backward_ss
+
+ FUNCTION dfti_compute_backward_sc(desc,sSrc,cDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_sc
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: sSrc
+ !MS$ATTRIBUTES REFERENCE :: cDst
+ INTEGER dfti_compute_backward_sc
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrc
+ COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
+ END FUNCTION dfti_compute_backward_sc
+
+ FUNCTION dfti_compute_backward_cs(desc,cSrc,sDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_cs
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: cSrc
+ !MS$ATTRIBUTES REFERENCE :: sDst
+ INTEGER dfti_compute_backward_cs
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
+ REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDst
+ END FUNCTION dfti_compute_backward_cs
+
+ FUNCTION dfti_compute_backward_cc(desc,cSrc,cDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_cc
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: cSrc
+ !MS$ATTRIBUTES REFERENCE :: cDst
+ INTEGER dfti_compute_backward_cc
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: cSrc
+ COMPLEX(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: cDst
+ END FUNCTION dfti_compute_backward_cc
+
+ FUNCTION dfti_compute_backward_ssss(desc,sSrcRe,sSrcIm,sDstRe,sDstIm)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_ssss
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: sSrcRe
+ !MS$ATTRIBUTES REFERENCE :: sSrcIm
+ !MS$ATTRIBUTES REFERENCE :: sDstRe
+ !MS$ATTRIBUTES REFERENCE :: sDstIm
+ INTEGER dfti_compute_backward_ssss
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcRe
+ REAL(DFTI_SPKP), INTENT(IN), DIMENSION(*) :: sSrcIm
+ REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstRe
+ REAL(DFTI_SPKP), INTENT(OUT), DIMENSION(*) :: sDstIm
+ END FUNCTION dfti_compute_backward_ssss
+
+ FUNCTION dfti_compute_backward_d(desc,dSrcDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_d
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: dSrcDst
+ INTEGER dfti_compute_backward_d
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: dSrcDst
+ END FUNCTION dfti_compute_backward_d
+
+ FUNCTION dfti_compute_backward_z(desc,zSrcDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_z
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: zSrcDst
+ INTEGER dfti_compute_backward_z
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_DPKP), INTENT(INOUT), DIMENSION(*) :: zSrcDst
+ END FUNCTION dfti_compute_backward_z
+
+ FUNCTION dfti_compute_backward_dd(desc,dSrcDstRe,dSrcDstIm)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_dd
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: dSrcDstRe
+ !MS$ATTRIBUTES REFERENCE :: dSrcDstIm
+ INTEGER dfti_compute_backward_dd
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstRe
+ REAL(DFTI_DPKP), DIMENSION(*) :: dSrcDstIm
+ END FUNCTION dfti_compute_backward_dd
+
+ FUNCTION dfti_compute_backward_dz(desc,dSrc,zDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_dz
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: dSrc
+ !MS$ATTRIBUTES REFERENCE :: zDst
+ INTEGER dfti_compute_backward_dz
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrc
+ COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
+ END FUNCTION dfti_compute_backward_dz
+
+ FUNCTION dfti_compute_backward_zd(desc,zSrc,dDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_zd
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: zSrc
+ !MS$ATTRIBUTES REFERENCE :: dDst
+ INTEGER dfti_compute_backward_zd
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
+ REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDst
+ END FUNCTION dfti_compute_backward_zd
+
+ FUNCTION dfti_compute_backward_zz(desc,zSrc,zDst)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_zz
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: zSrc
+ !MS$ATTRIBUTES REFERENCE :: zDst
+ INTEGER dfti_compute_backward_zz
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ COMPLEX(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: zSrc
+ COMPLEX(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: zDst
+ END FUNCTION dfti_compute_backward_zz
+
+ FUNCTION dfti_compute_backward_dddd(desc,dSrcRe,dSrcIm,dDstRe,dDstIm)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_compute_backward_dddd
+ !MS$ATTRIBUTES REFERENCE :: desc
+ !MS$ATTRIBUTES REFERENCE :: dSrcRe
+ !MS$ATTRIBUTES REFERENCE :: dSrcIm
+ !MS$ATTRIBUTES REFERENCE :: dDstRe
+ !MS$ATTRIBUTES REFERENCE :: dDstIm
+ INTEGER dfti_compute_backward_dddd
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcRe
+ REAL(DFTI_DPKP), INTENT(IN), DIMENSION(*) :: dSrcIm
+ REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstRe
+ REAL(DFTI_DPKP), INTENT(OUT), DIMENSION(*) :: dDstIm
+ END FUNCTION dfti_compute_backward_dddd
+
+ END INTERFACE DftiComputeBackward
+
+ INTERFACE DftiFreeDescriptor
+
+ FUNCTION dfti_free_descriptor_external(desc)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_free_descriptor_external
+ !MS$ATTRIBUTES REFERENCE :: desc
+ INTEGER dfti_free_descriptor_external
+ TYPE(DFTI_DESCRIPTOR), POINTER :: desc
+ END FUNCTION dfti_free_descriptor_external
+
+ END INTERFACE
+
+ INTERFACE DftiErrorClass
+
+ FUNCTION dfti_error_class_external(Status, ErrorClass)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_error_class_external
+ !MS$ATTRIBUTES REFERENCE :: Status
+ !MS$ATTRIBUTES REFERENCE :: ErrorClass
+ LOGICAL dfti_error_class_external
+ INTEGER, INTENT(IN) :: Status
+ INTEGER, INTENT(IN) :: ErrorClass
+ END FUNCTION dfti_error_class_external
+
+ END INTERFACE
+
+ INTERFACE DftiErrorMessage
+
+ FUNCTION dfti_error_message_external(Status)
+ USE MKL_DFT_TYPE
+ !DEC$ATTRIBUTES C :: dfti_error_message_external
+ !MS$ATTRIBUTES REFERENCE :: Status
+ CHARACTER(LEN=DFTI_MAX_MESSAGE_LENGTH) :: dfti_error_message_external
+ INTEGER, INTENT(IN) :: Status
+ END FUNCTION dfti_error_message_external
+
+ END INTERFACE
+
+END MODULE MKL_DFTI
diff -r 405d8f4fa05f -r e7295294f654 src/proj.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/proj.c Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,64 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <proj_api.h>
+#include <string.h>
+
+/*
+ * proj routine to convert arrays of UTM coordinates
+ * to longitude/latitude using the PROJ.4 library
+ *
+ * to do: check the output in the south hemisphere
+ *
+ * sylvain barbot (22/05/10) - original form
+ */
+
+void proj_(double *x, double *y, int * n,
+ double * lon0, double * lat0, int * zone) {
+
+ projPJ pj_utm, pj_latlong;
+ int p, i;
+ char zonestr[3];
+ char cmd_utm[100], cmd_latlong[100];
+ char * to;
+
+ // convert integer zone to string zone
+ i=sprintf(zonestr, "%d", (*zone));
+
+ // construct conversion command (+proj=utm +zone=11)
+ to = stpcpy(cmd_utm,"+proj=utm +zone=");
+ to = stpcpy(to,zonestr);
+ //printf("%s\n",cmd_utm);
+
+ // construct conversion command (+proj=latlong +zone=11)
+ to = stpcpy(cmd_latlong,"+proj=latlong +zone=");
+ to = stpcpy(to,zonestr);
+ //printf("%s\n",cmd_latlong);
+
+ if (!(pj_utm = pj_init_plus(cmd_utm)) ){
+ printf("error initializing input projection driver. exiting.");
+ exit(1);
+ }
+ if (!(pj_latlong = pj_init_plus(cmd_latlong)) ){
+ printf("error initializing output projection driver. exiting.");
+ exit(1);
+ }
+
+ // convert to radians
+ (*lon0)*=DEG_TO_RAD;
+ (*lat0)*=DEG_TO_RAD;
+
+ p = pj_transform(pj_latlong, pj_utm, 1, 1, lon0, lat0, NULL);
+
+ // add UTM coordinates of the origin
+ for (i=0;i<(*n);i++){
+ x[i]+=(*lon0);
+ y[i]+=(*lat0);
+ }
+ p = pj_transform(pj_utm, pj_latlong, (*n), 1, x, y, NULL);
+
+ // convert longitude and latitude to degrees
+ for (i=0;i<(*n);i++){
+ x[i]*=RAD_TO_DEG;
+ y[i]*=RAD_TO_DEG;
+ }
+}
diff -r 405d8f4fa05f -r e7295294f654 src/relax.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/relax.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,1121 @@
+!-----------------------------------------------------------------------
+! Copyright 2007-2012, Sylvain Barbot
+!
+! This file is part of RELAX
+!
+! RELAX 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 3 of the License, or
+! (at your option) any later version.
+!
+! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
+!-----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ !> \mainpage
+ !! program relax
+ !! <hr>
+ !! PURPOSE:
+ !! The program RELAX computes nonlinear time-dependent viscoelastic
+ !! deformation with powerlaw rheology and rate-strengthening friction
+ !! in a cubic, periodic grid due to coseismic stress changes, initial
+ !! stress, surface loads, and/or moving faults.
+ !!
+ !! ONLINE DOCUMENTATION:
+ !! generate html documentation from the source directory with the
+ !! doxygen (http://www.stack.nl/~dimitri/doxygen/index.html)
+ !! program with command:
+ !!
+ !! doxygen .doxygen
+ !!
+ !! DESCRIPTION:
+ !! Computation is done semi-analytically inside a cartesian grid.
+ !! The grid is defined by its size sx1*sx2*sx3 and the sampling
+ !! intervals dx1, dx2 and dx3. rule of thumb is to allow for at least
+ !! five samples per fault length or width, and to have the tip of any
+ !! fault at least 10 fault widths away from any edge of the
+ !! computational grid.
+ !!
+ !! Coseismic stress changes and initial coseismic deformation results
+ !! from the presence of dislocations in the brittle layer. Fault
+ !! geometry is prescribed following Okada or Wang's convention, with the
+ !! usual slip, strike, dip and rake and is converted to a double-couple
+ !! equivalent body-force analytically. Current implementation allows
+ !! shear fault (strike slip and dip slip), dykes, Mogi source, and
+ !! surface traction. Faults and dykes can be of arbitrary orientation
+ !! in the half space.
+ !!
+ !! <hr>
+ !!
+ !! METHOD:
+ !! The current implementation is organized to integrate stress/strain-
+ !! rate constitutive laws (rheologies) of the form
+ !! \f[
+ !! \dot{\epsilon} = f(\sigma)
+ !! \f]
+ !! as opposed to epsilon^dot = f(sigma,epsilon) wich would include work-
+ !! hardening (or weakening). The time-stepping implements a second-order
+ !! Runge-Kutta numerical integration scheme with a variable time-step.
+ !! The Runge-Kutta method integrating the ODE y'=f(x,y) can be summarized
+ !! as follows:
+ !! \f[
+ !! y_(n+1) = y_n + k_2
+ !! k_1 = h * f(x_n, y_n)
+ !! k_2 = h * f(x_n + h, y_n + k_1)
+ !! \f]
+ !! where h is the time-step and n is the time-index. The elastic response
+ !! in the computational grid is obtained using elastic Greens functions.
+ !! The Greens functions are applied in the Fourier domain. Strain,
+ !! stress and body-forces are obtained by application of a finite impulse
+ !! response (FIR) differentiator filter in the space domain.
+ !!
+ !! <hr>
+ !!
+ !! INPUT:
+ !! Static dislocation sources are discretized into a series of planar
+ !! segments. Slip patches are defined in terms of position, orientation,
+ !! and slip, as illustrated in the following figure:
+ !!\verbatim
+ !! N (x1)
+ !! /
+ !! /| Strike
+ !! x1,x2,x3 ->@------------------------ (x2)
+ !! |\ p . \ W
+ !! :-\ i . \ i
+ !! | \ l . \ d
+ !! :90 \ S . \ t
+ !! |-Dip\ . \ h
+ !! : \. | Rake \
+ !! | -------------------------
+ !! : L e n g t h
+ !! Z (x3)
+ !!\endverbatim
+ !! Dislocations are converted to double-couple equivalent body-force
+ !! analytically. Solution displacement is obtained by application of
+ !! the Greens functions in the Fourier domain.
+ !!
+ !! For friction faults where slip rates are evaluated from stress and
+ !! a constitutive law, the rake corresponds to the orientation of slip.
+ !! That is, if r_i is the rake vector and v_i is the instantaneous
+ !! velocity vector, then r_j v_j >= 0.
+ !!
+ !! <hr>
+ !!
+ !! OUTPUT:
+ !! The vector-valued deformation is computed everywhere in a cartesian
+ !! grid. The vector field is sampled 1) along a horizontal surface at a
+ !! specified depth and 2) at specific points. Format is always North (x1),
+ !! East (x2) and Down (x3) components, following the right-handed reference
+ !! system convention. North corresponds to x1-direction, East to the
+ !! x2-direction and down to the x3-direction. The Generic Mapping Tool
+ !! output files are labeled explicitely ???-north.grd, ???-east.grd and
+ !! ???-up.grd (or say, ???-geo-up.grd for outputs in geographic
+ !! coordinates), where ??? stands for an output index: 001, 002, ...
+ !!
+ !! The amplitude of the inelastic (irreversible) deformation is also
+ !! tracked and can be output along a plane of arbitrary orientation.
+ !! The inelastic deformation includes the initial, constrained, slip on
+ !! fault surfaces, the time-dependent slip on frictional surfaces and
+ !! the cumulative amplitude of bulk strain in viscoelastic regions.
+ !! Slip is provided as a function of local coordinates along strike and
+ !! dip as well as a function of the Cartesian coordinates for three-
+ !! dimensional display.
+ !!
+ !! Time integration uses adaptive time steps to ensure accuracy but
+ !! results can be output either 1) at specified uniform time intervals
+ !! or 2) at the same intervals as computed. In the later case, output
+ !! intervals is chosen internally depending on instantaneous relaxation
+ !! rates.
+ !!
+ !! <hr>
+ !!
+ !! TECHNICAL ASPECTS:
+ !! Most of the computational burden comes from 1) applying the elastic
+ !! Green function and 2) computing the current strain from a displacement
+ !! field. The convolution of body forces with the Green function is
+ !! performed in the Fourier domain and the efficiency of the computation
+ !! depends essentially upon a choice of the discrete Fourier transform.
+ !! Current implementation is compatible with the Couley-Tuckey, the
+ !! Fast Fourier transform of the West (FFTW), the SGI FFT and the intel
+ !! FFT from the intel MKL library. Among these choices, the MKL FFT is
+ !! the most efficient. The FFTW, SGI FFT and MKL FFT can all be ran
+ !! in parallel on shared-memory computers.
+ !!
+ !! Strain is computed using a Finite Impulse Response differentiator
+ !! filter in the space domain. Use of FIR filter give rise to very
+ !! accurate derivatives but is computationally expensive. The filter
+ !! kernels are provided in the kernel???.inc files. Use of a compact
+ !! kernel may accelerate computation significantly.
+ !!
+ !! Compilation options are defined in the include.f90 file and specify
+ !! for instance the choice of DFT and the kind of output provided.
+ !!
+ !! MODIFICATIONS:
+ !! \author Sylvain Barbot
+ !! (07-06-07) - original form <br>
+ !! (08-28-08) - FFTW/SGI_FFT support, FIR derivatives,
+ !! Runge-Kutta integration, tensile cracks,
+ !! GMT output, comments in input file <br>
+ !! (10-24-08) - interseismic loading, postseismic signal
+ !! output in separate files <br>
+ !! (12-08-09) - slip distribution smoothing <br>
+ !! (05-05-10) - lateral variations in viscous properties
+ !! Intel MKL implementation of the FFT <br>
+ !! (06-04-10) - output in geographic coordinates
+ !! and output components of stress tensor <br>
+ !! (07-19-10) - includes surface tractions initial condition
+ !! output geometry in VTK format for Paraview <br>
+ !! (02-28-11) - add constraints on the broad direction of
+ !! afterslip, export faults to GMT xy format
+ !! and allow scaling of computed time steps. <br>
+ !! (04-26-11) - include command-line arguments
+ !! (11-04-11) - compatible with gfortran <br>
+ !!
+ !! \todo
+ !! - homogenize VTK output so that geometry of events match event index
+ !! - evaluate Green's function, stress and body forces in GPU
+ !! - write the code for MPI multi-thread
+ !! - fix the vtk export to grid for anisotropic sampling
+ !! - export position of observation points to long/lat in opts-geo.dat
+ !! - check the projected output on the south hemisphere
+ !! - check the fully-relaxed afterslip for uniform stress change
+ !! - include topography of parameter interface
+ !! - export afterslip output in VTK
+ !------------------------------------------------------------------------
+PROGRAM relax
+
+ USE types
+ USE input
+ USE green
+ USE elastic3d
+ USE viscoelastic3d
+ USE friction3d
+ USE export
+
+#include "include.f90"
+
+ IMPLICIT NONE
+
+ INTEGER, PARAMETER :: ITERATION_MAX = 9900
+ REAL*8, PARAMETER :: STEP_MAX = 1e7
+
+ INTEGER :: i,k,e,oi,iostatus,mech(3)
+#ifdef FFTW3_THREADS
+ INTEGER :: iret
+!$ INTEGER :: omp_get_max_threads
+#endif
+ REAL*8 :: maxwell(3)
+ TYPE(SIMULATION_STRUC) :: in
+#ifdef VTK
+ CHARACTER(80) :: filename,title,name
+ CHARACTER(3) :: digit
+#endif
+ CHARACTER(4) :: digit4
+ REAL*8 :: t,Dt,tm
+
+ ! arrays
+ REAL*4, DIMENSION(:,:,:), ALLOCATABLE :: v1,v2,v3,u1,u2,u3,gamma
+ REAL*4, DIMENSION(:,:,:), ALLOCATABLE :: u1r,u2r,u3r
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: t1,t2,t3
+ REAL*4, DIMENSION(:,:,:), ALLOCATABLE :: inter1,inter2,inter3
+ TYPE(TENSOR), DIMENSION(:,:,:), ALLOCATABLE :: tau,sig,moment
+
+#ifdef FFTW3_THREADS
+ CALL sfftw_init_threads(iret)
+#ifdef _OPENMP
+ CALL sfftw_plan_with_nthreads(omp_get_max_threads())
+#else
+ CALL sfftw_plan_with_nthreads(4)
+#endif
+#endif
+
+ ! read input parameters
+ CALL init(in)
+
+ ! abort calculation after help message
+ ! or for dry runs
+ IF (in%isdryrun) THEN
+ PRINT '("dry run: abort calculation")'
+ END IF
+ IF (in%isdryrun .OR. in%ishelp) THEN
+ ! exit program
+ GOTO 100
+ END IF
+
+ ! allocate memory
+ ALLOCATE (v1(in%sx1+2,in%sx2,in%sx3),v2(in%sx1+2,in%sx2,in%sx3),v3(in%sx1+2,in%sx2,in%sx3), &
+ u1(in%sx1+2,in%sx2,in%sx3/2),u2(in%sx1+2,in%sx2,in%sx3/2),u3(in%sx1+2,in%sx2,in%sx3/2), &
+ tau(in%sx1,in%sx2,in%sx3/2),sig(in%sx1,in%sx2,in%sx3/2),gamma(in%sx1+2,in%sx2,in%sx3/2), &
+ t1(in%sx1+2,in%sx2),t2(in%sx1+2,in%sx2),t3(in%sx1+2,in%sx2), &
+ STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory"
+#ifdef VTK
+ IF (in%isoutputvtkrelax) THEN
+ ALLOCATE(u1r(in%sx1+2,in%sx2,in%sx3/2),u2r(in%sx1+2,in%sx2,in%sx3/2), &
+ u3r(in%sx1+2,in%sx2,in%sx3/2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory for VTK relax output"
+ u1r=0
+ u2r=0
+ u3r=0
+ END IF
+#endif
+
+ IF (in%isoutputrelax) THEN
+ ALLOCATE(inter1(in%sx1+2,in%sx2,2),inter2(in%sx1+2,in%sx2,2),inter3(in%sx1+2,in%sx2,2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory for postseismic displacement"
+ END IF
+
+ v1=0;v2=0;v3=0;u1=0;u2=0;u3=0;gamma=0;t1=0;t2=0;t3=0
+ CALL tensorfieldadd(tau,tau,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=0._4)
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - construct pre-stress structure
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (ALLOCATED(in%stresslayer)) THEN
+ CALL tensorstructure(in%stressstruc,in%stresslayer,in%dx3)
+ DEALLOCATE(in%stresslayer)
+
+ DO k=1,in%sx3/2
+ tau(:,:,k)=(-1._4) .times. in%stressstruc(k)%t
+ END DO
+ DEALLOCATE(in%stressstruc)
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - construct linear viscoelastic structure
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (ALLOCATED(in%linearlayer)) THEN
+ CALL viscoelasticstructure(in%linearstruc,in%linearlayer,in%dx3)
+ DEALLOCATE(in%linearlayer)
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - construct nonlinear viscoelastic structure
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (ALLOCATED(in%nonlinearlayer)) THEN
+ CALL viscoelasticstructure(in%nonlinearstruc,in%nonlinearlayer,in%dx3)
+ DEALLOCATE(in%nonlinearlayer)
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - construct nonlinear fault creep structure (rate-strenghtening)
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (ALLOCATED(in%faultcreeplayer)) THEN
+ CALL viscoelasticstructure(in%faultcreepstruc,in%faultcreeplayer,in%dx3)
+ DEALLOCATE(in%faultcreeplayer)
+ END IF
+
+ ! first event
+ e=1
+ ! first output
+ oi=1;
+ ! initial condition
+ t=0
+
+ ! sources
+ CALL dislocations(in%events(e),in%lambda,in%mu,in%beta,in%sx1,in%sx2,in%sx3, &
+ in%dx1,in%dx2,in%dx3,v1,v2,v3,t1,t2,t3,tau)
+ CALL traction(in%mu,in%events(e),in%sx1,in%sx2,in%dx1,in%dx2,t,0.d0,t3)
+
+ PRINT '("coseismic event ",I3.3)', e
+ PRINT 0990
+
+ ! export the amplitude of eigenstrain
+ CALL exporteigenstrain(gamma,in%nop,in%op,in%x0,in%y0, &
+ in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,in%wdir,0)
+
+ ! export equivalent body forces
+ IF (isoutput(in%skip,t,i,in%odt,oi,in%events(e)%time)) THEN
+#ifdef GRD_EQBF
+ IF (in%isoutputgrd) THEN
+ CALL exportgrd(v1,v2,v3,in%sx1,in%sx2,in%sx3/2, &
+ in%dx1,in%dx2,in%dx3,0.7_8,in%x0,in%y0,in%wdir,0,convention=3)
+ END IF
+#endif
+ END IF
+
+ ! test the presence of dislocations for coseismic calculation
+ IF ((in%events(e)%nt .NE. 0) .OR. &
+ (in%events(e)%ns .NE. 0) .OR. &
+ (in%events(e)%nm .NE. 0) .OR. &
+ (in%events(e)%nl .NE. 0)) THEN
+
+ ! apply the 3d elastic transfer function
+ CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3, &
+ in%dx1,in%dx2,in%dx3,in%lambda,in%mu,in%gam)
+ END IF
+
+ ! transfer solution
+ CALL fieldrep(u1,v1,in%sx1+2,in%sx2,in%sx3/2)
+ CALL fieldrep(u2,v2,in%sx1+2,in%sx2,in%sx3/2)
+ CALL fieldrep(u3,v3,in%sx1+2,in%sx2,in%sx3/2)
+
+ ! evaluate stress
+ CALL tensorfieldadd(sig,tau,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=-1._4)
+ CALL stressupdate(u1,u2,u3,in%lambda,in%mu, &
+ in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,sig)
+
+ ! export displacements
+#ifdef TXT
+ IF (in%isoutputtxt) THEN
+ CALL exporttxt(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%oz,in%dx3,0,0._8,in%wdir,in%reportfilename)
+ END IF
+#endif
+#ifdef XYZ
+ IF (in%isoutputxyz) THEN
+ CALL exportxyz(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%oz,in%dx1,in%dx2,in%dx3,0,in%wdir)
+ END IF
+#endif
+#ifdef GRD
+ IF (in%isoutputgrd) THEN
+ CALL exportgrd(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,in%x0,in%y0,in%wdir,0)
+ IF (in%isoutputrelax) THEN
+ CALL exportgrd(inter1,inter2,inter3,in%sx1,in%sx2,in%sx3/2, &
+ in%dx1,in%dx2,in%dx3,0._8,in%x0,in%y0,in%wdir,0,convention=2)
+ END IF
+ END IF
+#endif
+#ifdef PROJ
+ IF (in%isoutputproj) THEN
+ CALL exportproj(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz, &
+ in%x0,in%y0,in%lon0,in%lat0,in%zone,in%umult,in%wdir,0)
+ END IF
+#endif
+#ifdef VTK
+ IF (in%isoutputvtk) THEN
+ !filename=trim(in%wdir)//"/disp-000.vtr"
+ !CALL exportvtk_vectors(u1,u2,u3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3,8,8,8,filename)
+ filename=trim(in%wdir)//"/disp-000.vtk"//char(0)
+ title="coseismic displacement vector field"//char(0)
+ name="displacement"//char(0)
+ CALL exportvtk_vectors_legacy(u1,u2,u3,in%sx1,in%sx2,in%sx3/8,in%dx1,in%dx2,in%dx3, &
+ 4,4,8,filename,title,name)
+ !CALL exportvtk_vectors_slice(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,8,8,filename)
+ END IF
+ IF (in%isoutputvtkrelax) THEN
+ filename=trim(in%wdir)//"/disp-relax-000.vtk"//char(0)
+ title="postseismic displacement vector field"//char(0)
+ name="displacement"//char(0)
+ CALL exportvtk_vectors_legacy(u1r,u2r,u3r,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3, &
+ 4,4,8,filename,title,name)
+ END IF
+#endif
+ IF (ALLOCATED(in%ptsname)) THEN
+ CALL exportpoints(u1,u2,u3,sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ in%opts,in%ptsname,0._8,in%wdir,.true.,in%x0,in%y0,in%rot)
+ END IF
+
+ ! export initial stress
+#ifdef GRD
+ CALL exportplanestress(sig,in%nop,in%op,in%x0,in%y0,in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,in%wdir,oi)
+ IF (in%isoutputgrd .AND. in%isoutputstress) THEN
+ CALL exportstressgrd(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ in%ozs,in%x0,in%y0,in%wdir,0)
+ END IF
+#endif
+#ifdef PROJ
+ IF (in%isoutputproj .AND. in%isoutputstress) THEN
+ CALL exportstressproj(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%ozs, &
+ in%x0,in%y0,in%lon0,in%lat0,in%zone,in%umult,in%wdir,0)
+ END IF
+#endif
+ ! initialize stress conditions
+ CALL export_rfaults_stress_init(sig,in%sx1,in%sx2,in%sx3, &
+ in%dx1,in%dx2,in%dx3,in%nsop,in%sop)
+ WRITE (digit4,'(I4.4)') 0
+#ifdef VTK
+ IF (in%isoutputvtk .AND. in%isoutputstress) THEN
+ filename=trim(in%wdir)//"/sigma-"//digit4//".vtk"//char(0)
+ title="stress tensor field"//char(0)
+ name="stress"//char(0)
+ CALL exportvtk_tensors_legacy(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ 4,4,8,filename,title,name)
+ END IF
+ ! coseismic stress change on predefined planes for 3-D visualization w/ Paraview
+ filename=trim(in%wdir)//"/rfaults-sigma-"//digit4//".vtp"
+ CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,filename,sig=sig)
+ ! postseismic stress change on predefined planes (zero by definition)
+ filename=trim(in%wdir)//"/rfaults-dsigma-"//digit4//".vtp"
+ CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,filename)
+#endif
+ ! coseismic stress change on predefined planes for gmt
+ filename=trim(in%wdir)//"/rfaults-sigma-"//digit4//".xy"
+ CALL exportgmt_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,filename,sig=sig)
+ ! postseismic stress change on predefined planes for gmt (zero by definition)
+ filename=trim(in%wdir)//"/rfaults-dsigma-"//digit4//".xy"
+ CALL exportgmt_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,filename)
+ ! time series of stress in ASCII format
+ CALL exportcoulombstress(sig,in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,0._8,in%wdir,.TRUE.)
+ CALL reporttime(0,0._8,in%reporttimefilename)
+
+ PRINT 1101,0,0._8,0._8,0._8,0._8,0._8,in%interval,0._8,tensoramplitude(tau,in%dx1,in%dx2,in%dx3)
+ IF (in%interval .LE. 0) THEN
+ GOTO 100 ! no time integration
+ END IF
+
+ ALLOCATE(moment(in%sx1,in%sx2,in%sx3/2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the mechanical structure"
+
+ !CALL tensorfieldadd(sig,sig,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=0._4)
+ CALL tensorfieldadd(moment,moment,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=0._4)
+
+ DO i=1,ITERATION_MAX
+ IF (t .GE. in%interval) GOTO 100 ! proper exit
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! predictor
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ ! initialize large time step
+ tm=STEP_MAX;
+ maxwell(:)=STEP_MAX;
+
+ ! active mechanism flag
+ mech(:)=0
+
+ ! initialize no forcing term in tensor space
+ CALL tensorfieldadd(moment,moment,in%sx1,in%sx2,in%sx3/2,0._4,0._4)
+
+ ! power density from three mechanisms (linear and power-law viscosity
+ ! and fault creep)
+ ! 1- linear viscosity
+ IF (ALLOCATED(in%linearstruc)) THEN
+ CALL viscouseigenstress(in%mu,in%linearstruc,in%linearweakzone,in%nlwz, &
+ sig,in%sx1,in%sx2,in%sx3/2, &
+ in%dx1,in%dx2,in%dx3,moment,0.01_8,MAXWELLTIME=maxwell(1))
+ mech(1)=1
+ END IF
+
+ ! 2- powerlaw viscosity
+ IF (ALLOCATED(in%nonlinearstruc)) THEN
+ CALL viscouseigenstress(in%mu,in%nonlinearstruc,in%nonlinearweakzone,in%nnlwz, &
+ sig,in%sx1,in%sx2,in%sx3/2, &
+ in%dx1,in%dx2,in%dx3,moment,0.01_8,MAXWELLTIME=maxwell(2))
+ mech(2)=1
+ END IF
+
+ ! 3- nonlinear fault creep with rate-strengthening friction
+ IF (ALLOCATED(in%faultcreepstruc)) THEN
+ DO k=1,in%np
+ CALL frictioneigenstress(in%n(k)%x,in%n(k)%y,in%n(k)%z, &
+ in%n(k)%width,in%n(k)%length, &
+ in%n(k)%strike,in%n(k)%dip,in%n(k)%rake,in%beta, &
+ sig,in%mu,in%faultcreepstruc, &
+ in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ moment,maxwelltime=maxwell(3))
+ END DO
+ mech(3)=1
+ END IF
+
+#ifdef VTK
+ IF (in%isoutputvtk .AND. in%isoutputstress) THEN
+ WRITE (digit,'(I3.3)') oi-1
+ filename=trim(in%wdir)//"/power-"//digit//".vtk"//char(0)
+ title="stress rate tensor field"//char(0)
+ name="power"//char(0)
+ CALL exportvtk_tensors_legacy(moment,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ 4,4,8,filename,title,name)
+ END IF
+#endif
+
+ ! identify the required time step
+ tm=1._8/(REAL(mech(1))/maxwell(1)+ &
+ REAL(mech(2))/maxwell(2)+ &
+ REAL(mech(3))/maxwell(3))
+ ! force finite time step
+ tm=MIN(tm,STEP_MAX)
+
+ ! modify
+ IF ((in%inter%ns .GT. 0) .OR. (in%inter%nt .GT. 0)) THEN
+ IF (tm .EQ. STEP_MAX) THEN
+ ! no relaxation occurs, pick a small integration time
+ tm=in%interval/20._8
+ END IF
+ END IF
+
+ ! choose an integration time step
+ CALL integrationstep(tm,Dt,t,oi,in%odt,in%skip,in%tscale,in%events,e,in%ne)
+
+ CALL tensorfieldadd(sig,moment,in%sx1,in%sx2,in%sx3/2,c1=0.0_4,c2=1._4)
+
+ v1=0;v2=0;v3=0;t1=0;t2=0;t3=0;
+ CALL equivalentbodyforce(sig,in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,v1,v2,v3,t1,t2,t3)
+
+ ! add time-dependent surface loads
+ CALL traction(in%mu,in%events(e),in%sx1,in%sx2,in%dx1,in%dx2,t,Dt/2.d8,t3,rate=.TRUE.)
+
+ CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3,in%dx1,in%dx2,in%dx3,in%lambda,in%mu,in%gam)
+
+ ! v1,v2,v3 contain the predictor displacement
+ CALL fieldadd(v1,u1,in%sx1+2,in%sx2,in%sx3/2,c1=REAL(Dt/2))
+ CALL fieldadd(v2,u2,in%sx1+2,in%sx2,in%sx3/2,c1=REAL(Dt/2))
+ CALL fieldadd(v3,u3,in%sx1+2,in%sx2,in%sx3/2,c1=REAL(Dt/2))
+ CALL tensorfieldadd(sig,tau,in%sx1,in%sx2,in%sx3/2,c1=-REAL(Dt/2),c2=-1._4)
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! corrector
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ CALL stressupdate(v1,v2,v3,in%lambda,in%mu, &
+ in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,sig)
+
+ ! reinitialize moment density tensor
+ CALL tensorfieldadd(moment,moment,in%sx1,in%sx2,in%sx3/2,0._4,0._4)
+
+ IF (ALLOCATED(in%linearstruc)) THEN
+ ! linear viscosity
+ v1=0
+ CALL viscouseigenstress(in%mu,in%linearstruc,in%linearweakzone,in%nlwz,sig, &
+ in%sx1,in%sx2,in%sx3/2, &
+ in%dx1,in%dx2,in%dx3,moment,0.01_8,GAMMA=v1)
+
+ ! update slip history
+ CALL fieldadd(gamma,v1,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
+ END IF
+
+ IF (ALLOCATED(in%nonlinearstruc)) THEN
+ ! powerlaw viscosity
+ v1=0
+ CALL viscouseigenstress(in%mu,in%nonlinearstruc,in%nonlinearweakzone,in%nnlwz,sig, &
+ in%sx1,in%sx2,in%sx3/2, &
+ in%dx1,in%dx2,in%dx3,moment,0.01_8,GAMMA=v1)
+
+ ! update slip history
+ CALL fieldadd(gamma,v1,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
+ END IF
+
+ ! nonlinear fault creep with rate-strengthening friction
+ IF (ALLOCATED(in%faultcreepstruc)) THEN
+
+ ! use v1 as placeholders for the afterslip planes
+ DO k=1,in%np
+ ! one may use optional arguments ...,VEL=v1) to convert
+ ! fault slip to eigenstrain (scalar)
+ CALL frictioneigenstress(in%n(k)%x,in%n(k)%y,in%n(k)%z, &
+ in%n(k)%width,in%n(k)%length, &
+ in%n(k)%strike,in%n(k)%dip,in%n(k)%rake,in%beta, &
+ sig,in%mu,in%faultcreepstruc,in%sx1,in%sx2,in%sx3/2, &
+ in%dx1,in%dx2,in%dx3,moment)
+ END DO
+
+ ! export strike and dip creep velocity
+ IF (isoutput(in%skip,t,i,in%odt,oi,in%events(e)%time)) THEN
+ CALL exportcreep(in%np,in%n,in%beta,sig,in%faultcreepstruc, &
+ in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%x0,in%y0,in%wdir,oi)
+ END IF
+
+ END IF
+
+ ! interseismic loading
+ IF ((in%inter%ns .GT. 0) .OR. (in%inter%nt .GT. 0)) THEN
+ ! vectors v1,v2,v3 are not affected.
+ CALL dislocations(in%inter,in%lambda,in%mu,in%beta,in%sx1,in%sx2,in%sx3, &
+ in%dx1,in%dx2,in%dx3,v1,v2,v3,t1,t2,t3,tau,eigenstress=moment)
+ END IF
+
+ v1=0;v2=0;v3=0;t1=0;t2=0;t3=0;
+ CALL equivalentbodyforce(moment,in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,v1,v2,v3,t1,t2,t3)
+
+ ! add time-dependent surface loads
+ CALL traction(in%mu,in%events(e),in%sx1,in%sx2,in%dx1,in%dx2,t,Dt,t3,rate=.true.)
+
+ ! export equivalent body forces
+ IF (isoutput(in%skip,t,i,in%odt,oi,in%events(e)%time)) THEN
+#ifdef VTK_EQBF
+ IF (in%isoutputvtk) THEN
+ WRITE (digit,'(I3.3)') oi
+ !filename=trim(in%wdir)//"/eqbf-"//digit//".vtr"
+ !CALL exportvtk_vectors(v1,v2,v3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3,8,8,8,filename)
+ filename=trim(in%wdir)//"/eqbf-"//digit//".vtk"//char(0)
+ title="instantaneous equivalent body-force rate vector field"//char(0)
+ name="body-force-rate"//char(0)
+ CALL exportvtk_vectors_legacy(v1,v2,v3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3, &
+ 4,4,8,filename,title,name)
+ END IF
+#endif
+#ifdef GRD_EQBF
+ IF (in%isoutputgrd) THEN
+ CALL exportgrd(v1,v2,v3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ in%oz,in%x0,in%y0,in%wdir,oi,convention=3)
+ END IF
+#endif
+ END IF
+
+ CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3,in%dx1,in%dx2,in%dx3,in%lambda,in%mu,in%gam)
+
+ ! update deformation field
+ CALL fieldadd(u1,v1,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
+ CALL fieldadd(u2,v2,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
+ CALL fieldadd(u3,v3,in%sx1+2,in%sx2,in%sx3/2,c2=REAL(Dt))
+ CALL tensorfieldadd(tau,moment,in%sx1,in%sx2,in%sx3/2,c2=REAL(Dt))
+
+ ! keep track of the viscoelastic contribution alone
+ IF (in%isoutputrelax) THEN
+ CALL sliceadd(inter1(:,:,1),v1,in%sx1+2,in%sx2,in%sx3,int(in%oz/in%dx3)+1,c2=REAL(Dt))
+ CALL sliceadd(inter2(:,:,1),v2,in%sx1+2,in%sx2,in%sx3,int(in%oz/in%dx3)+1,c2=REAL(Dt))
+ CALL sliceadd(inter3(:,:,1),v3,in%sx1+2,in%sx2,in%sx3,int(in%oz/in%dx3)+1,c2=REAL(Dt))
+ END IF
+
+#ifdef VTK
+ IF (in%isoutputvtkrelax) THEN
+ u1r=u1r+Dt*v1
+ u2r=u2r+Dt*v2
+ u3r=u3r+Dt*v3
+ END IF
+#endif
+
+ ! time increment
+ t=t+Dt
+
+ ! next event
+ IF (e .LT. in%ne) THEN
+ IF (abs(t-in%events(e+1)%time) .LT. 1e-6) THEN
+ e=e+1
+ in%events(e)%i=i
+
+ PRINT '("coseismic event ",I3.3)', e
+ PRINT 0990
+
+ v1=0;v2=0;v3=0;t1=0;t2=0;t3=0;
+ CALL dislocations(in%events(e),in%lambda,in%mu, &
+ in%beta,in%sx1,in%sx2,in%sx3, &
+ in%dx1,in%dx2,in%dx3,v1,v2,v3,t1,t2,t3,tau)
+ CALL traction(in%mu,in%events(e),in%sx1,in%sx2,in%dx1,in%dx2,t,0.d0,t3)
+
+ ! apply the 3d elastic transfert function
+ CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3, &
+ in%dx1,in%dx2,in%dx3,in%lambda,in%mu,in%gam)
+
+ ! transfer solution
+ CALL fieldadd(u1,v1,in%sx1+2,in%sx2,in%sx3/2)
+ CALL fieldadd(u2,v2,in%sx1+2,in%sx2,in%sx3/2)
+ CALL fieldadd(u3,v3,in%sx1+2,in%sx2,in%sx3/2)
+
+ END IF
+ END IF
+
+ CALL tensorfieldadd(sig,tau,in%sx1,in%sx2,in%sx3/2,c1=0._4,c2=-1._4)
+ CALL stressupdate(u1,u2,u3,in%lambda,in%mu, &
+ in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,sig)
+
+ ! points are exported at all time steps
+ IF (ALLOCATED(in%ptsname)) THEN
+ CALL exportpoints(u1,u2,u3,sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ in%opts,in%ptsname,t,in%wdir,.FALSE.,in%x0,in%y0,in%rot)
+ END IF
+
+ ! output only at discrete intervals (skip=0, odt>0),
+ ! or every "skip" computational steps (skip>0, odt<0),
+ ! or anytime a coseismic event occurs
+ IF (isoutput(in%skip,t,i,in%odt,oi,in%events(e)%time)) THEN
+
+ CALL reporttime(1,t,in%reporttimefilename)
+
+ ! export
+#ifdef TXT
+ IF (in%isoutputtxt) THEN
+ CALL exporttxt(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%oz,in%dx3,oi,t,in%wdir,in%reportfilename)
+ END IF
+#endif
+#ifdef XYZ
+ IF (in%isoutputxyz) THEN
+ CALL exportxyz(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%oz,in%dx1,in%dx2,in%dx3,i,in%wdir)
+ IF (in%isoutputrelax) THEN
+ !CALL exportxyz(inter1,inter2,inter3,in%sx1,in%sx2,in%sx3/2,0.0_8,in%dx1,in%dx2,in%dx3,i,in%wdir)
+ END IF
+ END IF
+#endif
+ CALL exporteigenstrain(gamma,in%nop,in%op,in%x0,in%y0,in%dx1,in%dx2,in%dx3,in%sx1,in%sx2,in%sx3/2,in%wdir,oi)
+#ifdef GRD
+ IF (in%isoutputgrd) THEN
+ IF (in%isoutputrelax) THEN
+ CALL exportgrd(inter1,inter2,inter3,in%sx1,in%sx2,in%sx3/2, &
+ in%dx1,in%dx2,in%dx3,0._8,in%x0,in%y0,in%wdir,oi,convention=2)
+ END IF
+ CALL exportgrd(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,in%x0,in%y0,in%wdir,oi)
+ END IF
+#endif
+#ifdef PROJ
+ IF (in%isoutputproj) THEN
+ IF (in%isoutputrelax) THEN
+ CALL exportproj(inter1,inter2,inter3,in%sx1,in%sx2,in%sx3/2, &
+ in%dx1,in%dx2,in%dx3,in%oz,in%x0,in%y0, &
+ in%lon0,in%lat0,in%zone,in%umult,in%wdir,oi,convention=2)
+ END IF
+ CALL exportproj(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,in%x0,in%y0, &
+ in%lon0,in%lat0,in%zone,in%umult,in%wdir,oi)
+ END IF
+#endif
+#ifdef VTK
+ IF (in%isoutputvtk) THEN
+ WRITE (digit,'(I3.3)') oi
+ ! export total displacement in VTK XML format
+ !filename=trim(in%wdir)//"/disp-"//digit//".vtr"
+ !CALL exportvtk_vectors(u1,u2,u3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3,8,8,8,filename)
+ filename=trim(in%wdir)//"/disp-"//digit//".vtk"//char(0)
+ title="cumulative displacement vector field"//char(0)
+ name="displacement"//char(0)
+ CALL exportvtk_vectors_legacy(u1,u2,u3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3, &
+ 4,4,8,filename,title,name)
+ !CALL exportvtk_vectors_slice(u1,u2,u3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,8,8,filename)
+
+ ! export instantaneous velocity in VTK XML format
+ !filename=trim(in%wdir)//"/vel-"//digit//".vtr"
+ !CALL exportvtk_vectors(v1,v2,v3,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3,8,8,8,filename)
+ filename=trim(in%wdir)//"/vel-"//digit//".vtk"//char(0)
+ title="instantaneous velocity vector field"//char(0)
+ name="velocity"//char(0)
+ CALL exportvtk_vectors_legacy(v1,v2,v3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ 8,8,16,filename,title,name)
+ !CALL exportvtk_vectors_slice(v1,v2,v3,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%oz,8,8,filename)
+ END IF
+ IF (in%isoutputvtkrelax) THEN
+ WRITE (digit,'(I3.3)') oi
+ filename=trim(in%wdir)//"/disp-relax-"//digit//".vtk"//char(0)
+ title="postseismic displacement vector field"//char(0)
+ name="displacement"//char(0)
+ CALL exportvtk_vectors_legacy(u1r,u2r,u3r,in%sx1,in%sx2,in%sx3/4,in%dx1,in%dx2,in%dx3, &
+ 4,4,8,filename,title,name)
+ END IF
+#endif
+
+ ! export stress
+#ifdef GRD
+ IF (in%isoutputgrd .AND. in%isoutputstress) THEN
+ CALL exportstressgrd(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ in%ozs,in%x0,in%y0,in%wdir,oi)
+ END IF
+#endif
+#ifdef PROJ
+ IF (in%isoutputproj .AND. in%isoutputstress) THEN
+ CALL exportstressproj(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3,in%ozs, &
+ in%x0,in%y0,in%lon0,in%lat0,in%zone,in%umult,in%wdir,oi)
+ END IF
+#endif
+ WRITE (digit4,'(I4.4)') oi
+#ifdef VTK
+ IF (in%isoutputvtk .AND. in%isoutputstress) THEN
+ filename=trim(in%wdir)//"/sigma-"//digit4//".vtk"//char(0)
+ title="stress tensor field"//char(0)
+ name="stress"//char(0)
+ CALL exportvtk_tensors_legacy(sig,in%sx1,in%sx2,in%sx3/2,in%dx1,in%dx2,in%dx3, &
+ 4,4,8,filename,title,name)
+ END IF
+ filename=trim(in%wdir)//"/rfaults-sigma-"//digit4//".vtp"
+ CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,filename,sig=sig)
+ filename=trim(in%wdir)//"/rfaults-dsigma-"//digit4//".vtp"
+ CALL exportvtk_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,filename,convention=1,sig=sig)
+#endif
+ ! total stress on predefined planes for gmt
+ filename=trim(in%wdir)//"/rfaults-sigma-"//digit4//".xy"
+ CALL exportgmt_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,filename,sig=sig)
+ ! postseismic stress change on predefined planes for gm
+ filename=trim(in%wdir)//"/rfaults-dsigma-"//digit4//".xy"
+ CALL exportgmt_rfaults_stress(in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,filename,convention=1,sig=sig)
+ ! time series of stress in ASCII format
+ CALL exportcoulombstress(sig,in%sx1,in%sx2,in%sx3,in%dx1,in%dx2,in%dx3, &
+ in%nsop,in%sop,t,in%wdir,.FALSE.)
+
+ PRINT 1101,i,Dt,maxwell,t,in%interval, &
+ tensoramplitude(moment,in%dx1,in%dx2,in%dx3), &
+ tensoramplitude(tau,in%dx1,in%dx2,in%dx3)
+
+ ! update output counter
+ oi=oi+1
+ ELSE
+ PRINT 1100,i,Dt,maxwell,t,in%interval, &
+ tensoramplitude(moment,in%dx1,in%dx2,in%dx3), &
+ tensoramplitude(tau,in%dx1,in%dx2,in%dx3)
+ END IF
+
+ END DO
+
+100 CONTINUE
+
+ DO i=1,in%ne
+ IF (ALLOCATED(in%events(i)%s)) DEALLOCATE(in%events(i)%s,in%events(i)%sc)
+ IF (ALLOCATED(in%events(i)%ts)) DEALLOCATE(in%events(i)%ts,in%events(i)%tsc)
+ END DO
+ IF (ALLOCATED(in%events)) DEALLOCATE(in%events)
+
+ ! free memory
+ IF (ALLOCATED(gamma)) DEALLOCATE(gamma)
+ IF (ALLOCATED(in%opts)) DEALLOCATE(in%opts)
+ IF (ALLOCATED(in%ptsname)) DEALLOCATE(in%ptsname)
+ IF (ALLOCATED(in%op)) DEALLOCATE(in%op)
+ IF (ALLOCATED(in%sop)) DEALLOCATE(in%sop)
+ IF (ALLOCATED(in%n)) DEALLOCATE(in%n)
+ IF (ALLOCATED(in%stressstruc)) DEALLOCATE(in%stressstruc)
+ IF (ALLOCATED(in%stresslayer)) DEALLOCATE(in%stresslayer)
+ IF (ALLOCATED(in%linearstruc)) DEALLOCATE(in%linearstruc)
+ IF (ALLOCATED(in%linearlayer)) DEALLOCATE(in%linearlayer)
+ IF (ALLOCATED(in%linearweakzone)) DEALLOCATE(in%linearweakzone)
+ IF (ALLOCATED(in%nonlinearstruc)) DEALLOCATE(in%nonlinearstruc)
+ IF (ALLOCATED(in%nonlinearlayer)) DEALLOCATE(in%nonlinearlayer)
+ IF (ALLOCATED(in%nonlinearweakzone)) DEALLOCATE(in%nonlinearweakzone)
+ IF (ALLOCATED(in%faultcreepstruc)) DEALLOCATE(in%faultcreepstruc)
+ IF (ALLOCATED(in%faultcreeplayer)) DEALLOCATE(in%faultcreeplayer)
+ IF (ALLOCATED(sig)) DEALLOCATE(sig)
+ IF (ALLOCATED(tau)) DEALLOCATE(tau)
+ IF (ALLOCATED(moment)) DEALLOCATE(moment)
+ IF (ALLOCATED(in%stresslayer)) DEALLOCATE(in%stresslayer)
+ IF (ALLOCATED(in%linearlayer)) DEALLOCATE(in%linearlayer)
+ IF (ALLOCATED(in%nonlinearlayer)) DEALLOCATE(in%nonlinearlayer)
+ IF (ALLOCATED(in%faultcreeplayer)) DEALLOCATE(in%faultcreeplayer)
+ IF (ALLOCATED(v1)) DEALLOCATE(v1,v2,v3,t1,t2,t3)
+ IF (ALLOCATED(u1)) DEALLOCATE(u1,u2,u3)
+ IF (ALLOCATED(inter1)) DEALLOCATE(inter1,inter2,inter3)
+
+
+#ifdef FFTW3_THREADS
+ CALL sfftw_cleanup_threads()
+#endif
+
+0990 FORMAT (" I | Dt | tm(ve) | tm(pl) | tm(as) | t/tmax | power | C:E^i | ")
+1000 FORMAT (I3.3,"*",ES9.2E2," ",ES9.2E2,"/",ES7.2E1)
+1100 FORMAT (I3.3," ",ES9.2E2,3ES9.2E2,ES9.2E2,"/",ES7.2E1,2ES9.2E2)
+1101 FORMAT (I3.3,"*",ES9.2E2,3ES9.2E2,ES9.2E2,"/",ES7.2E1,2ES9.2E2)
+1200 FORMAT ("----------------------------------------------------------------------------")
+
+CONTAINS
+
+ !--------------------------------------------------------------------
+ !> subroutine dislocations
+ !! assigns equivalent body forces or moment density to simulate
+ !! shear dislocations and fault opening. add the corresponding moment
+ !! density in the cumulative relaxed moment so that fault slip does
+ !! not reverse in the postseismic time.
+ !--------------------------------------------------------------------
+ SUBROUTINE dislocations(event,lambda,mu,beta,sx1,sx2,sx3,dx1,dx2,dx3, &
+ v1,v2,v3,t1,t2,t3,tau,factor,eigenstress)
+ TYPE(EVENT_STRUC), INTENT(IN) :: event
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: lambda,mu,beta,dx1,dx2,dx3
+ REAL*4, DIMENSION(:,:,:), INTENT(INOUT) :: v1,v2,v3
+ REAL*4, DIMENSION(:,:), INTENT(INOUT) :: t1,t2,t3
+ TYPE(TENSOR), DIMENSION(:,:,:), INTENT(INOUT) :: tau
+ REAL*8, INTENT(IN), OPTIONAL :: factor
+ TYPE(TENSOR), DIMENSION(:,:,:), INTENT(INOUT), OPTIONAL :: eigenstress
+
+ INTEGER :: i
+ REAL*8 :: slip_factor
+
+ IF (PRESENT(factor)) THEN
+ slip_factor=factor
+ ELSE
+ slip_factor=1._8
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - load shear dislocations
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (.NOT. (PRESENT(eigenstress))) THEN
+ ! forcing term in equivalent body force
+ DO i=1,event%ns
+ ! adding sources in the space domain
+ CALL source(mu,slip_factor*event%s(i)%slip, &
+ event%s(i)%x,event%s(i)%y,event%s(i)%z, &
+ event%s(i)%width,event%s(i)%length, &
+ event%s(i)%strike,event%s(i)%dip,event%s(i)%rake, &
+ event%s(i)%beta,sx1,sx2,sx3,dx1,dx2,dx3,v1,v2,v3,t1,t2,t3)
+ END DO
+ ELSE
+ ! forcing term in moment density
+ DO i=1,event%ns
+ CALL momentdensityshear(mu,slip_factor*event%s(i)%slip, &
+ event%s(i)%x,event%s(i)%y,event%s(i)%z, &
+ event%s(i)%width,event%s(i)%length, &
+ event%s(i)%strike,event%s(i)%dip,event%s(i)%rake, &
+ event%s(i)%beta,sx1,sx2,sx3/2,dx1,dx2,dx3,eigenstress)
+ END DO
+ END IF
+
+ DO i=1,event%ns
+ ! remove corresponding eigenmoment
+ CALL momentdensityshear(mu,slip_factor*event%s(i)%slip, &
+ event%s(i)%x,event%s(i)%y,event%s(i)%z, &
+ event%s(i)%width,event%s(i)%length, &
+ event%s(i)%strike,event%s(i)%dip,event%s(i)%rake, &
+ event%s(i)%beta,sx1,sx2,sx3/2,dx1,dx2,dx3,tau)
+ END DO
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - load tensile cracks
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (.NOT. (PRESENT(eigenstress))) THEN
+ ! forcing term in equivalent body force
+ DO i=1,event%nt
+ ! adding sources in the space domain
+ CALL tensilesource(lambda,mu,slip_factor*event%ts(i)%slip, &
+ event%ts(i)%x,event%ts(i)%y,event%ts(i)%z, &
+ event%ts(i)%width,event%ts(i)%length, &
+ event%ts(i)%strike,event%ts(i)%dip, &
+ beta,sx1,sx2,sx3,dx1,dx2,dx3,v1,v2,v3)
+ END DO
+ ELSE
+ ! forcing term in moment density
+ DO i=1,event%nt
+ CALL momentdensitytensile(lambda,mu,slip_factor*event%ts(i)%slip, &
+ event%ts(i)%x,event%ts(i)%y,event%ts(i)%z,&
+ event%ts(i)%width,event%ts(i)%length, &
+ event%ts(i)%strike,event%ts(i)%dip,event%ts(i)%rake, &
+ beta,sx1,sx2,sx3/2,dx1,dx2,dx3,eigenstress)
+ END DO
+ END IF
+
+ DO i=1,event%nt
+ ! removing corresponding eigenmoment
+ CALL momentdensitytensile(lambda,mu,slip_factor*event%ts(i)%slip, &
+ event%ts(i)%x,event%ts(i)%y,event%ts(i)%z,&
+ event%ts(i)%width,event%ts(i)%length, &
+ event%ts(i)%strike,event%ts(i)%dip,event%ts(i)%rake, &
+ beta,sx1,sx2,sx3/2,dx1,dx2,dx3,tau)
+ END DO
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - load point dilatation sources
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (.NOT. (PRESENT(eigenstress))) THEN
+ ! forcing term in equivalent body force
+ DO i=1,event%nm
+ ! adding sources in the space domain
+ CALL mogisource(lambda,mu,slip_factor*event%m(i)%slip, &
+ event%m(i)%x,event%m(i)%y,event%m(i)%z, &
+ sx1,sx2,sx3,dx1,dx2,dx3,v1,v2,v3)
+ END DO
+ ELSE
+ ! forcing term in moment density
+ DO i=1,event%nm
+ CALL momentdensitymogi(lambda,mu,slip_factor*event%m(i)%slip, &
+ event%m(i)%x,event%m(i)%y,event%m(i)%z, &
+ sx1,sx2,sx3/2,dx1,dx2,dx3,eigenstress)
+ END DO
+ END IF
+
+ DO i=1,event%nm
+ ! remove corresponding eigenmoment
+ CALL momentdensitymogi(lambda,mu,slip_factor*event%m(i)%slip, &
+ event%m(i)%x,event%m(i)%y,event%m(i)%z, &
+ sx1,sx2,sx3/2,dx1,dx2,dx3,tau)
+ END DO
+
+ END SUBROUTINE dislocations
+
+ !--------------------------------------------------------------------
+ !> function IsOutput
+ !! checks if output should be written based on user choices: if output
+ !! time interval (odt) is positive, output is written only if time
+ !! is an integer of odt. If odt is negative output is written at times
+ !! corresponding to internally chosen time steps.
+ !!
+ !! @return IsOutput is true only at discrete intervals (skip=0,odt>0),
+ !! or at every "skip" computational steps (skip>0,odt<0),
+ !! or anytime a coseismic event occurs
+ !
+ ! Sylvain Barbot (07/06/09) - original form
+ !--------------------------------------------------------------------
+ LOGICAL FUNCTION isoutput(skip,t,i,odt,oi,etime)
+ INTEGER, INTENT(IN) :: skip,i,oi
+ REAL*8, INTENT(IN) :: t,odt,etime
+
+ IF (((0 .EQ. skip) .AND. (abs(t-oi*odt) .LT. 1e-6*odt)) .OR. &
+ ((0 .LT. skip) .AND. (MOD(i-1,skip) .EQ. 0)) .OR. &
+ (abs(t-etime) .LT. 1e-6)) THEN
+ isoutput=.TRUE.
+ ELSE
+ isoutput=.FALSE.
+ END IF
+
+ END FUNCTION isoutput
+
+ !--------------------------------------------------------------------
+ !> subroutine IntegrationStep
+ !! find the time-integration forward step for the predictor-corrector
+ !! scheme.
+ !!
+ !! input file line
+ !!
+ !! time interval, (positive dt step) or (negative skip and scaling)
+ !!
+ !! can be filled by either 1)
+ !!
+ !! T, dt
+ !!
+ !! where T is the time interval of the simulation and dt is the
+ !! output time step, or 2)
+ !!
+ !! T, -n, t_s
+ !!
+ !! where n indicates the number of computational steps before
+ !! outputing results, t_s is a scaling applied to internally
+ !! computed time step.
+ !!
+ !! for case 1), an optimal time step is evaluated internally to
+ !! ensure stability (t_m/10) of time integration. The actual
+ !! time step Dt is chosen as
+ !!
+ !! Dt = min( t_m/10, ((t%odt)+1)*odt-t )
+ !!
+ !! where t is the current time in the simulation. regardless of
+ !! time step Dt, results are output if t is a multiple of dt.
+ !!
+ !! for case 2), the time step is chosen internally based on an
+ !! estimate of the relaxation time (t_m/10). Results are output
+ !! every n steps. The actual time step is chosen as
+ !!
+ !! Dt = min( t_m/10*t_s, t(next event)-t )
+ !!
+ !! where index is the number of computational steps after a coseismic
+ !! event and t(next event) is the time of the next coseismic event.
+ !!
+ !! \author sylvain barbot (01/01/08) - original form
+ !--------------------------------------------------------------------
+ SUBROUTINE integrationstep(tm,Dt,t,oi,odt,skip,tscale,events,e,ne)
+ REAL*8, INTENT(INOUT) :: tm,Dt,odt
+ REAL*8, INTENT(IN) :: t,tscale
+ INTEGER, INTENT(IN) :: oi,e,ne,skip
+ TYPE(EVENT_STRUC), INTENT(IN), DIMENSION(:) :: events
+
+ ! output at optimal computational intervals
+ Dt=tm/10._8
+
+ ! reduce time in case something happens in [ t, t+Dt ]
+ IF (0 .EQ. skip) THEN
+ ! reduce time step so that t+Dt is time at next
+ ! user-required output time
+ IF ((t+Dt) .GE. (dble(oi)*odt)-Dt*0.04d0) THEN
+ ! pick a smaller time step to reach :
+ ! integers of odt
+ Dt=dble(oi)*odt-t
+ END IF
+ ELSE
+ ! scale the estimate of optimal time step
+ Dt=Dt*tscale
+
+ ! reduce time step so that t+Dt is time to next event
+ IF (e .LT. ne) THEN
+ IF ((t+Dt-events(e+1)%time) .GE. 0._8) THEN
+ ! pick a smaller time step to reach
+ ! next event time
+ Dt=events(e+1)%time-t
+ END IF
+ END IF
+ END IF
+
+ END SUBROUTINE integrationstep
+
+END PROGRAM relax
diff -r 405d8f4fa05f -r e7295294f654 src/types.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/types.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,217 @@
+!-----------------------------------------------------------------------
+! Copyright 2007, 2008, 2009 Sylvain Barbot
+!
+! This file is part of RELAX
+!
+! RELAX 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 3 of the License, or
+! (at your option) any later version.
+!
+! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
+!-----------------------------------------------------------------------
+
+#include "include.f90"
+
+MODULE types
+
+ TYPE SOURCE_STRUCT
+ SEQUENCE
+ REAL*8 :: slip,x,y,z,width,length,strike,dip,rake,period,phase,beta
+ END TYPE SOURCE_STRUCT
+
+ TYPE LAYER_STRUCT
+ SEQUENCE
+ REAL*8 :: z,gammadot0,stressexponent,cohesion,friction
+ END TYPE LAYER_STRUCT
+
+ TYPE WEAK_STRUCT
+ SEQUENCE
+ REAL*8 :: dgammadot0,x,y,z,width,length,thickness,strike,dip
+ END TYPE WEAK_STRUCT
+
+ TYPE VECTOR_STRUCT
+ SEQUENCE
+ REAL*8 :: v1,v2,v3
+ END TYPE VECTOR_STRUCT
+
+ TYPE TENSOR
+ SEQUENCE
+ REAL*4 :: s11,s12,s13,s22,s23,s33
+ END TYPE TENSOR
+
+ TYPE TENSOR_LAYER_STRUCT
+ SEQUENCE
+ REAL*4 :: z,dum
+ TYPE(TENSOR) :: t
+ END TYPE TENSOR_LAYER_STRUCT
+
+ TYPE SEGMENT_STRUCT
+ SEQUENCE
+ REAL*8 :: x,y,z,width,length,strike,dip,friction
+ TYPE(TENSOR) :: sig0
+ END TYPE SEGMENT_STRUCT
+
+ TYPE SLIPPATCH_STRUCT
+ SEQUENCE
+ ! absolute position
+ REAL*8 :: x1,x2,x3
+ ! relative position (strike and dip directions)
+ REAL*8 :: lx,lz
+ ! cumulative slip (total, strike and dip slip)
+ REAL*8 :: slip,ss,ds
+ ! instantaneous velocity
+ REAL*8 :: v,vss,vds
+ ! shear stress
+ REAL*8 :: taus
+ ! stress tensor
+ TYPE(TENSOR) :: sig
+ END TYPE SLIPPATCH_STRUCT
+
+ TYPE PLANE_STRUCT
+ SEQUENCE
+ REAL*8 :: x,y,z,width,length,strike,dip,rake
+ INTEGER :: px2,px3
+ TYPE(SLIPPATCH_STRUCT), DIMENSION(:,:), ALLOCATABLE :: patch
+ END TYPE PLANE_STRUCT
+
+ TYPE EVENT_STRUC
+ REAL*8 :: time
+ INTEGER*4 :: i,ns,nt,nm,nl
+ TYPE(SOURCE_STRUCT), DIMENSION(:), ALLOCATABLE :: s,sc,ts,tsc,m,mc,l,lc
+ END TYPE EVENT_STRUC
+
+ TYPE, PUBLIC :: SIMULATION_STRUC
+ ! grid dimension
+ INTEGER :: sx1,sx2,sx3
+
+ ! sampling
+ REAL*8 :: dx1,dx2,dx3
+
+ ! smoothing factor
+ REAL*8 :: beta
+
+ ! filter parameter for slip models
+ REAL*8 :: nyquist
+
+ ! center coordinates and rotation
+ REAL*8 :: x0,y0,rot
+
+#ifdef PROJ
+ ! geographic coordinates of center, UTM zone, length unit
+ REAL*8 :: lon0,lat0,umult
+ INTEGER :: zone
+#endif
+
+ ! observation depths
+ REAL*8 :: oz,ozs
+
+ ! output directory
+ CHARACTER(80) :: wdir
+
+ ! filenames
+ CHARACTER(80) :: reportfilename,reporttimefilename
+
+ ! elastic moduli and gravity parameter
+ REAL*8 :: lambda,mu,gam
+
+ ! time step parameters
+ REAL*8 :: interval
+ REAL*8 :: odt,tscale
+ INTEGER :: skip=0
+
+ ! number of observation planes
+ INTEGER :: nop
+
+ ! observation planes
+ TYPE(PLANE_STRUCT), DIMENSION(:), ALLOCATABLE :: op
+
+ ! number of stress observation planes
+ INTEGER :: nsop
+
+ ! stress observation planes
+ TYPE(SEGMENT_STRUCT), DIMENSION(:), ALLOCATABLE :: sop
+
+ ! number of observation points
+ INTEGER :: npts
+
+ ! observation points
+ TYPE(VECTOR_STRUCT), DIMENSION(:), ALLOCATABLE :: opts
+
+ ! observation points name
+ CHARACTER(LEN=4), DIMENSION(:), ALLOCATABLE :: ptsname
+
+ ! number of prestress interfaces
+ INTEGER :: nps
+
+ ! stress layers and stress structure
+ TYPE(TENSOR_LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: stresslayer,stressstruc
+
+ ! number of linear viscous interfaces
+ INTEGER :: nv
+
+ ! linear viscous layers and structure
+ TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: linearlayer,linearstruc
+
+ ! number of linear weak zones
+ INTEGER :: nlwz
+
+ ! linear weak zones
+ TYPE(WEAK_STRUCT), DIMENSION(:), ALLOCATABLE :: linearweakzone,linearweakzonec
+
+ ! number of nonlinear viscous interfaces
+ INTEGER :: npl
+
+ ! nonlinear viscous layers and structure
+ TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: nonlinearlayer,nonlinearstruc
+
+ ! number of nonlinear weak zones
+ INTEGER :: nnlwz
+
+ ! nonlinear viscous layers and structure
+ TYPE(WEAK_STRUCT), DIMENSION(:), ALLOCATABLE :: nonlinearweakzone,nonlinearweakzonec
+
+ ! number of fault creep interfaces
+ INTEGER :: nfc
+
+ ! fault creep interfaces
+ TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: faultcreeplayer,faultcreepstruc
+
+ ! number of afterslip planes
+ INTEGER :: np
+
+ ! afterslip planes
+ TYPE(PLANE_STRUCT), DIMENSION(:), ALLOCATABLE :: n
+
+ ! interseismic event
+ TYPE(EVENT_STRUC) :: inter
+
+ ! number of coseismic events
+ INTEGER :: ne
+
+ ! coseismic events
+ TYPE(EVENT_STRUC), DIMENSION(:), ALLOCATABLE :: events
+
+ ! overrides output to formats
+ LOGICAL :: isoutputproj=.TRUE.
+ LOGICAL :: isoutputrelax=.TRUE.
+ LOGICAL :: isoutputtxt=.TRUE.
+ LOGICAL :: isoutputvtk=.TRUE.
+ LOGICAL :: isoutputvtkrelax=.FALSE.
+ LOGICAL :: isoutputgrd=.TRUE.
+ LOGICAL :: isoutputxyz=.TRUE.
+ LOGICAL :: isoutputstress=.TRUE.
+
+ ! other options
+ LOGICAL :: isdryrun=.FALSE.
+ LOGICAL :: ishelp=.FALSE.
+
+ END TYPE SIMULATION_STRUC
+
+END MODULE types
diff -r 405d8f4fa05f -r e7295294f654 src/viscoelastic3d.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/viscoelastic3d.f90 Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,288 @@
+!-----------------------------------------------------------------------
+! Copyright 2007, 2008, 2009 Sylvain Barbot
+!
+! This file is part of RELAX
+!
+! RELAX 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 3 of the License, or
+! (at your option) any later version.
+!
+! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
+!-----------------------------------------------------------------------
+
+MODULE viscoelastic3d
+
+ USE elastic3d
+
+ IMPLICIT NONE
+
+#include "include.f90"
+
+ REAL*8, PRIVATE, PARAMETER :: pi = 3.141592653589793115997963468544185161_8
+ REAL*8, PRIVATE, PARAMETER :: pi2 = 6.28318530717958623199592693708837032318_8
+ REAL*8, PRIVATE, PARAMETER :: pid2 = 1.57079632679489655799898173427209258079_8
+
+CONTAINS
+
+ !-----------------------------------------------------------------
+ !> subroutine ViscoElasticDeviatoricStress
+ !! computes the instantaneous deviatoric stress tensor sigma_ij'
+ !!
+ !! sigma_ij' = 2*mu*(-delta_ij epsilon_kk/3 + epsilon_ij) - tau_ij
+ !!
+ !! such as
+ !!
+ !! sigma_kk'= 0
+ !!
+ !! where tau_ij is a second-order deviatoric symmetric tensor
+ !! that integrates the history of the relaxed stress. strain is
+ !! estimated using a centered finite difference derivative.
+ !!
+ !! \author sylvain barbot (07/07/07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE viscoelasticdeviatoricstress(mu,u1,u2,u3,tau,&
+ dx1,dx2,dx3,sx1,sx2,sx3,sig)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: mu,dx1,dx2,dx3
+ REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: u1,u2,u3
+ TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: tau
+ TYPE(TENSOR), INTENT(OUT), DIMENSION(:,:,:) :: sig
+
+ TYPE(TENSOR) :: s
+ INTEGER :: i1,i2,i3,i1p,i2p,i3p,i1m,i2m,i3m
+ REAL*8 :: epskk,px1,px2,px3
+
+ px1=dx1*2._8
+ px2=dx2*2._8
+ px3=dx3*2._8
+
+ ! space domain with finite difference scheme
+ DO i3=1,sx3
+ ! wrap around neighbor
+ i3m=mod(sx3+i3-2,sx3)+1
+ i3p=mod(i3,sx3)+1
+ DO i2=1,sx2
+ i2m=mod(sx2+i2-2,sx2)+1
+ i2p=mod(i2,sx2)+1
+
+ DO i1=1,sx1
+ i1m=mod(sx1+i1-2,sx1)+1
+ i1p=mod(i1,sx1)+1
+
+ ! trace component
+ epskk=((u1(i1p,i2,i3)-u1(i1m,i2,i3))/px1+&
+ (u2(i1,i2p,i3)-u2(i1,i2m,i3))/px2+&
+ (u3(i1,i2,i3p)-u3(i1,i2,i3m))/px3)/3._8
+
+ s%s11=2._8*mu*( (u1(i1p,i2,i3)-u1(i1m,i2,i3))/px1-epskk )
+ s%s12= mu*( (u1(i1,i2p,i3)-u1(i1,i2m,i3))/px2+ &
+ (u2(i1p,i2,i3)-u2(i1m,i2,i3))/px1)
+ s%s13= mu*( (u1(i1,i2,i3p)-u1(i1,i2,i3m))/px3+ &
+ (u3(i1p,i2,i3)-u3(i1m,i2,i3))/px1)
+ s%s22=2._8*mu*( (u2(i1,i2p,i3)-u2(i1,i2m,i3))/px2-epskk )
+ s%s23= mu*( (u2(i1,i2,i3p)-u2(i1,i2,i3m))/px3+ &
+ (u3(i1,i2p,i3)-u3(i1,i2m,i3))/px2)
+ s%s33=2._8*mu*( (u3(i1,i2,i3p)-u3(i1,i2,i3m))/px3-epskk )
+
+ sig(i1,i2,i3)= s .minus. tau(i1,i2,i3)
+
+ END DO
+ END DO
+ END DO
+
+ ! no normal traction at the boundary
+ sig(:,:,1)%s13=0
+ sig(:,:,1)%s23=0
+ sig(:,:,1)%s33=0
+ sig(:,:,sx3)%s13=0
+ sig(:,:,sx3)%s23=0
+ sig(:,:,sx3)%s33=0
+
+ END SUBROUTINE viscoelasticdeviatoricstress
+
+ !-----------------------------------------------------------------
+ !> subroutine ViscousEigenstress
+ !! computes the moment density rate due to a layered viscoelastic
+ !! structure with powerlaw creep
+ !!
+ !! d Ei / dt = C:F:sigma'
+ !!
+ !! where C is the elastic moduli tensor, F is the heterogeneous
+ !! fluidity tensor and sigma' is the instantaneous deviatoric
+ !! stress. F is stress dependent (powerlaw creep.)
+ !!
+ !! \author sylvain barbot (08/30/08) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE viscouseigenstress(mu,structure,ductilezones,nz,sig,sx1,sx2,sx3, &
+ dx1,dx2,dx3,moment,beta,maxwelltime,gamma)
+ REAL*8, INTENT(IN) :: mu,dx1,dx2,dx3,beta
+ INTEGER, INTENT(IN) :: nz
+ TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
+ TYPE(WEAK_STRUCT), DIMENSION(nz), INTENT(IN) :: ductilezones
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
+ TYPE(TENSOR), INTENT(OUT), DIMENSION(sx1,sx2,sx3) :: moment
+ REAL*8, OPTIONAL, INTENT(INOUT) :: maxwelltime
+#ifdef ALIGN_DATA
+ REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(OUT), OPTIONAL :: gamma
+#else
+ REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(OUT), OPTIONAL :: gamma
+#endif
+
+ INTEGER :: i1,i2,i3
+ TYPE(TENSOR) :: s,R
+ TYPE(TENSOR), PARAMETER :: zero = tensor(0._4,0._4,0._4,0._4,0._4,0._4)
+ REAL*8 :: gammadot,tau,tauc,gammadot0,power,cohesion,x1,x2,x3,dg0,dum
+ REAL*4 :: tm
+
+ IF (SIZE(structure,1) .NE. sx3) RETURN
+
+ IF (PRESENT(maxwelltime)) THEN
+ tm=REAL(maxwelltime)
+ ELSE
+ tm=1e30
+ END IF
+
+!$omp parallel do private(i1,i2,gammadot0,power,cohesion,s,tau,R,tauc,gammadot,dg0,x1,x2,x3,dum), &
+!$omp reduction(MIN:tm)
+ DO i3=1,sx3
+ power=structure(i3)%stressexponent
+ cohesion=structure(i3)%cohesion
+ x3=DBLE(i3-1)*dx3
+
+ IF (power .LT. 0.999999_8) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("power=",ES9.2E1)') power
+ WRITE (0,'("invalid power exponent. interrupting.")')
+ STOP 1
+ END IF
+
+ DO i2=1,sx2
+ DO i1=1,sx1
+ ! local coordinates
+ CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
+ dx1,dx2,dx3,x1,x2,dum)
+
+ ! depth-dependent fluidity structure
+ gammadot0=structure(i3)%gammadot0
+
+ ! perturbation from isolated viscous zones
+ dg0=dgammadot0(ductilezones,nz,x1,x2,x3,beta)
+
+ ! local fluidity structure
+ gammadot0=gammadot0+dg0
+
+ IF (1.0d-20 .GT. gammadot0) CYCLE
+
+ ! local deviatoric stress
+ s=tensordeviatoric(sig(i1,i2,i3))
+
+ ! s = tau * R
+ CALL tensordecomposition(s,tau,R)
+
+ ! effective stress
+ tauc=tau-cohesion
+
+ ! cohesion test
+ IF (tauc .LE. 1.0d-20) CYCLE
+
+ ! powerlaw viscosity
+ gammadot=gammadot0*(tauc/mu)**power
+
+ ! update moment density forcing
+ moment(i1,i2,i3)=moment(i1,i2,i3) .plus. &
+ (REAL(2._8*mu*gammadot) .times. R)
+
+ tm=MIN(tm,tauc/mu/gammadot)
+
+ IF (PRESENT(gamma)) &
+ gamma(i1,i2,i3)=gammadot
+
+ END DO
+ END DO
+ END DO
+!$omp end parallel do
+
+ IF (PRESENT(maxwelltime)) maxwelltime=MIN(tm,maxwelltime)
+
+ CONTAINS
+
+ !---------------------------------------------------------
+ !> function dgammadot0
+ !! evaluates the change of fluidity at position x1,x2,x3
+ !! due to the presence of weak ductile zones. the extent
+ !! and magnitude of ductile zones is tapered (beta).
+ !!
+ !! \author sylvain barbot (3/29/10) - original form
+ !---------------------------------------------------------
+ REAL*8 FUNCTION dgammadot0(zones,n,x1,x2,x3,beta)
+ INTEGER, INTENT(IN) :: n
+ TYPE(WEAK_STRUCT), INTENT(IN), DIMENSION(nz) :: zones
+ REAL*8, INTENT(IN) :: x1,x2,x3,beta
+
+ REAL*8 :: dg,x,y,z,L,W,D,strike,dip,LM
+ REAL*8 :: cstrike,sstrike,cdip,sdip, &
+ xr,yr,zr,x2r,Wp,Lp,Dp,x1s,x2s,x3s
+ INTEGER :: i
+
+ ! default is no change in fluidity
+ dgammadot0=0._8
+
+ DO i=1,n
+ ! retrieve weak zone geometry
+ dg=zones(i)%dgammadot0
+
+ x=zones(i)%x
+ y=zones(i)%y
+ z=zones(i)%z
+ W=zones(i)%length
+ L=zones(i)%width
+ D=zones(i)%thickness
+ strike=zones(i)%strike
+ dip=zones(i)%dip
+
+ ! effective tapered dimensions
+ Wp=W*(1._8+2._8*beta)/2._8
+ Lp=L*(1._8+2._8*beta)/2._8
+ Dp=D*(1._8+2._8*beta)/2._8
+ LM=MAX(Wp,Lp,Dp)
+
+ ! check distance from weak zone
+ IF ((ABS(x3-z).GT.LM) .OR. &
+ (ABS(x1-x).GT.LM) .OR. &
+ (ABS(x2-y).GT.LM)) CYCLE
+
+ ! evaluate contribution from weak zone
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! rotate centre coordinates of weak zone
+ x2r= cstrike*x -sstrike*y
+ xr = cdip *x2r-sdip *z
+ yr = sstrike*x +cstrike*y
+ zr = sdip *x2r+cdip *z
+
+ x2r= cstrike*x1 -sstrike*x2
+ x1s= cdip *x2r-sdip *x3
+ x2s= sstrike*x1 +cstrike*x2
+ x3s= sdip *x2r+cdip *x3
+
+ dgammadot0=dgammadot0+omega((x1s-xr)/D,beta) &
+ *omega((x2s-yr)/W,beta) &
+ *omega((x3s-zr)/L,beta)*dg
+ END DO
+
+ END FUNCTION dgammadot0
+
+ END SUBROUTINE viscouseigenstress
+
+END MODULE viscoelastic3d
diff -r 405d8f4fa05f -r e7295294f654 src/writegrd3.4.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/writegrd3.4.c Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,87 @@
+# include <gmt.h>
+
+/* Fortran callable routine to write a grd file in pixel registration */
+/* June 23, 1995 - David Sandwell */
+/* Revised for GMT3.4 December 28, 2002 - David Sandwell */
+/* Modified for node registration - March 19, 2008 - Sylvain Barbot */
+
+void writegrd(rdat,nx,ny,rlt0,rln0,dlt,dln,rland,rdum,title,fileout)
+
+ float *rdat; /* real array for output */
+ int *nx; /* number of x points */
+ int *ny; /* number of y points */
+ double *rlt0; /* starting latitude */
+ double *rln0; /* starting longitude */
+ double *dlt; /* latitude spacing */
+ double *dln; /* longitude spacing */
+ double *rland; /* land value */
+ double *rdum; /* dummy value */
+ char *title; /* title */
+ char *fileout; /* filename of output file */
+
+ {
+ int i;
+ double xmin, xmax, xinc, ymin, ymax, yinc, zmin, zmax;
+ int update = FALSE;
+ struct GRD_HEADER grd;
+ int argc = 0;
+ char **argv = NULL;
+
+/* Initialize with default values */
+
+ GMT_grdio_init();
+ GMT_make_dnan(GMT_d_NaN);
+ GMT_make_fnan(GMT_f_NaN);
+
+ GMT_grd_init(&grd, argc, argv, update);
+
+/* Calculate header parameters */
+ xmax = *rln0 + ((*nx)-1) * *dln;
+ xmin = *rln0;
+ if(xmax < xmin) {
+ xmin = xmax;
+ xmax = *rln0;
+ }
+ xinc = fabs((double)*dln);
+
+ ymax = *rlt0 + ((*ny)-1) * *dlt;
+ ymin = *rlt0;
+ if(ymax < ymin) {
+ ymin = ymax;
+ ymax = *rlt0;
+ }
+ yinc = fabs((double)*dlt);
+
+
+/* calculate zmin and zmax and zinc and set dummy values to NaN. */
+
+ zmin = fabs((double)*rdum);
+ zmax = -fabs((double)*rdum);
+
+ for (i = 0; i < *nx * *ny; i++) {
+ if((rdat[i] == *rdum) || (rdat[i] == *rland)) rdat[i] = GMT_f_NaN;
+ else {
+ if(rdat[i] < zmin) zmin = rdat[i];
+ if(rdat[i] > zmax) zmax = rdat[i];
+ }
+ }
+
+/* update the header using values passed */
+
+ strncpy(grd.title,title,80);
+ grd.nx = *nx;
+ grd.ny = *ny;
+ grd.node_offset = FALSE;
+ grd.x_min = xmin;
+ grd.x_max = xmax;
+ grd.x_inc = xinc;
+ grd.y_min = ymin;
+ grd.y_max = ymax;
+ grd.y_inc = yinc;
+ grd.z_min = zmin;
+ grd.z_max = zmax;
+
+/* write the file */
+ GMT_write_grd(fileout, &grd, rdat, 0.0, 0.0, 0.0, 0.0, GMT_pad, FALSE );
+
+ }
diff -r 405d8f4fa05f -r e7295294f654 src/writegrd4.2.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/writegrd4.2.c Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,100 @@
+/************************************************************************
+* writegrd routine to write a grd file in pixel registration *
+************************************************************************/
+/************************************************************************
+* Creator: David T. Sandwell Scripps Institution of Oceanography *
+* Date : 06/23/95 Copyright, David T. Sandwell *
+************************************************************************/
+/************************************************************************
+* Modification history: *
+* Revised for GMT3.4 December 28, 2002 - David Sandwell *
+* Revised for GMT4.2 May 10, 2007 - David Sandwell *
+* Modified for pixel registration April 18, 2008 - Sylvain Barbot *
+************************************************************************/
+
+# include <math.h>
+# include <gmt.h>
+
+void writegrd_(rdat,nx,ny,rlt0,rln0,dlt,dln,rland,rdum,title,fileout)
+
+ float *rdat; /* real array for output */
+ int *nx; /* number of x points */
+ int *ny; /* number of y points */
+ double *rlt0; /* starting latitude */
+ double *rln0; /* starting longitude */
+ double *dlt; /* latitude spacing */
+ double *dln; /* longitude spacing */
+ double *rland; /* land value */
+ double *rdum; /* dummy value */
+ char *title; /* title */
+ char *fileout; /* filename of output file */
+
+ {
+ int i;
+ double xmin, xmax, xinc, ymin, ymax, yinc, zmin, zmax;
+ struct GRD_HEADER grd;
+ int argc2 = 1;
+ char *argv2[2] = {"writegrd",0};
+
+/* Initialize with default values */
+
+ GMT_begin (argc2,argv2);
+ GMT_grd_init(&grd, argc2, argv2, FALSE);
+
+/* Calculate header parameters */
+
+ xmax = *rln0 + ((*nx)-1) * *dln;
+ xmin = *rln0;
+ if(xmax < xmin) {
+ xmin = xmax;
+ xmax = *rln0;
+ }
+ xinc = fabs((double)*dln);
+ ymax = *rlt0 + ((*ny)-1) * *dlt;
+ ymin = *rlt0;
+ if(ymax < ymin) {
+ ymin = ymax;
+ ymax = *rlt0;
+ }
+ yinc = fabs((double)*dlt);
+
+/* calculate zmin and zmax and zinc and set dummy values to NaN. */
+
+ zmin = +fabs((double)*rdum);
+ zmax = -fabs((double)*rdum);
+
+ for (i = 0; i < *nx * *ny; i++) {
+ if((rdat[i] == *rdum) || (rdat[i] == *rland)) rdat[i] = GMT_f_NaN;
+ else {
+ if(rdat[i] < zmin) zmin = rdat[i];
+ if(rdat[i] > zmax) zmax = rdat[i];
+ }
+ }
+
+/* update the header using values passed */
+
+ strncpy(grd.title,title,GRD_TITLE_LEN);
+ grd.nx = *nx;
+ grd.ny = *ny;
+ grd.node_offset = FALSE;
+ grd.x_min = xmin;
+ grd.x_max = xmax;
+ grd.x_inc = xinc;
+ grd.y_min = ymin;
+ grd.y_max = ymax;
+ grd.y_inc = yinc;
+ grd.z_min = zmin;
+ grd.z_max = zmax;
+
+/* grd.type = 10;
+ grd.z_id = 15;
+ grd.ncid = 15;*/
+
+/* write the file */
+
+ GMT_write_grd(fileout, &grd, rdat, 0.0, 0.0, 0.0, 0.0, GMT_pad, FALSE);
+
+/* GMT_end (argc2,argv2); */
+
+ }
+
diff -r 405d8f4fa05f -r e7295294f654 src/writevtk.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/writevtk.c Sun Apr 01 14:02:51 2012 -0700
@@ -0,0 +1,226 @@
+/*************************************************************
+* export vectors and tensors in big-endian mixed ascii/binary
+* vtk format for Paraview.
+*
+* sylvain barbot 10/27/11 - original form
+*************************************************************/
+
+#include <math.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "config.h"
+
+// check data alignment
+#ifdef FFTW3
+#define ALIGN_DATA 1
+#else
+#ifdef SGI_FFT
+#define ALIGN_DATA 1
+#else
+#ifdef IMKL_FFT
+#define ALIGN_DATA 1
+#endif
+#endif
+#endif
+
+int fix(int n){
+ if(n<0) return n-1;return n+1;
+}
+
+float swap(float d){
+ float a;
+ unsigned char *dst = (unsigned char *)&a;
+ unsigned char *src = (unsigned char *)&d;
+ dst[0] = src[3];
+ dst[1] = src[2];
+ dst[2] = src[1];
+ dst[3] = src[0];
+ return a;
+}
+
+// test endianness of the machine
+unsigned char isbigendian(){
+
+ typedef union{
+ int i;
+ char c[4];
+ } u;
+ u temp;
+
+ temp.i = 0x12345678;
+
+ switch(temp.c[0]) {
+ case 0x12:
+ return 1u; // big endian
+ case 0x78:
+ return 0u; // little endian
+ default:
+ fprintf(stderr,"invalid result for endianness test.\n");
+ fprintf(stderr,"temp %x %x %x %x.\n",temp.c[0],temp.c[1],temp.c[2],temp.c[3]);
+ fprintf(stderr,"temp %x \n",temp.c[0]);
+ return 2u;
+ }
+}
+
+/*************************************************************
+* subroutine ExportVTK_Vectors_Legacy
+* creates a .vtk file in the VTK Legacy binary format with
+* structured points containing a vector field.
+*
+* sylvain barbot 10/27/11 - original form
+*************************************************************/
+void exportvtk_vectors_legacy_(u1,u2,u3,sx1,sx2,sx3,dx1,dx2,dx3,j1,j2,j3,filename,title,name)
+ float *u1, *u2, *u3; /* data array for output */
+ int *sx1, *sx2, *sx3; /* number of points */
+ double*dx1, *dx2, *dx3; /* sampling distance */
+ int *j1, *j2, *j3; /* subsampling rate */
+ char *filename; /* output file name */
+ char *title; /* output file name */
+ char *name; /* output file name */
+{
+
+ FILE * funit;
+ float buffer[3];
+ int i1,i2,k1,k2,k3,index;
+ unsigned char endian;
+
+ funit=fopen(filename,"wb");
+ if (NULL==funit){
+ fprintf(stderr,"could not open file %s for vtk output\n",filename);
+ fprintf(stderr,"exiting.\n");
+ return;
+ }
+
+ // find endianness
+ endian=isbigendian();
+
+ // writing header of file
+ fprintf(funit,"# vtk DataFile Version 3.0\n");
+ fprintf(funit,"%s\n",title);
+ fprintf(funit,"BINARY\n");
+ fprintf(funit,"DATASET STRUCTURED_POINTS\n");
+
+ // structured points grid
+ fprintf(funit,"DIMENSIONS %i %i %i\n",(*sx1)/(*j1),(*sx2)/(*j2),(*sx3)/(*j3));
+ fprintf(funit,"ORIGIN %f %f %f\n",-(*dx1)*((*sx1)/2),-(*dx2)*((*sx2)/2),0.0);
+ fprintf(funit,"SPACING %f %f %f\n",(*dx1)*(*j1),(*dx2)*(*j2),(*dx3)*(*j3));
+
+ // data header for this grid
+ fprintf(funit,"POINT_DATA %i\n",((*sx1)/(*j1))*((*sx2)/(*j2))*((*sx3)/(*j3)));
+
+ // data array
+ fprintf(funit,"VECTORS %s float\n",name);
+
+ // data values
+ for (k3=0; k3<(*sx3); k3=k3+(*j3)){
+ for (k2=-(*sx2)/2; k2<(*sx2)/2; k2=k2+(*j2)){
+ i2=((*sx2)+fix(k2)) % (*sx2);
+
+ for (k1=-(*sx1)/2; k1<(*sx1)/2; k1+=(*j1)){
+ i1=((*sx1)+fix(k1)) % (*sx1);
+
+#ifdef ALIGN_DATA
+ index=i1+(i2+k3*(*sx2))*((*sx1)+2);
+#else
+ index=i1+(i2+k3*(*sx2))*(*sx1);
+#endif
+
+ // convert to big endian if necessary
+ buffer[0]=(1u==endian)?u1[index]:swap(u1[index]);
+ buffer[1]=(1u==endian)?u2[index]:swap(u2[index]);
+ buffer[2]=(1u==endian)?u3[index]:swap(u3[index]);
+
+ fwrite(buffer,12,1,funit);
+ }
+ }
+ }
+
+ // close binary file
+ fclose(funit);
+
+}
+
+
+/*************************************************************
+* subroutine ExportVTK_tensors_Legacy
+* creates a .vtk file in the VTK Legacy binary format with
+* structured points containing a vector field.
+*
+* sylvain barbot 10/28/11 - original form
+*************************************************************/
+void exportvtk_tensors_legacy_(sig,sx1,sx2,sx3,dx1,dx2,dx3,j1,j2,j3,filename,title,name)
+ float *sig; /* data array for tensor output */
+ int *sx1, *sx2, *sx3; /* number of points */
+ double*dx1, *dx2, *dx3; /* sampling distance */
+ int *j1, *j2, *j3; /* subsampling rate */
+ char *filename; /* output file name */
+ char *title; /* output file name */
+ char *name; /* output file name */
+{
+
+ FILE * funit;
+ float buffer[9];
+ int i1,i2,k1,k2,k3,index;
+ unsigned char endian;
+#define DOF 6
+
+ funit=fopen(filename,"wb");
+ if (NULL==funit){
+ fprintf(stderr,"could not open file %s for vtk output\n",filename);
+ fprintf(stderr,"exiting.\n");
+ return;
+ }
+
+ // find endianness
+ endian=isbigendian();
+
+ // writing header of file
+ fprintf(funit,"# vtk DataFile Version 3.0\n");
+ fprintf(funit,"%s\n",title);
+ fprintf(funit,"BINARY\n");
+ fprintf(funit,"DATASET STRUCTURED_POINTS\n");
+
+ // structured points grid
+ fprintf(funit,"DIMENSIONS %i %i %i\n",(*sx1)/(*j1),(*sx2)/(*j2),(*sx3)/(*j3));
+ fprintf(funit,"ORIGIN %f %f %f\n",-(*dx1)*((*sx1)/2),-(*dx2)*((*sx2)/2),0.0);
+ fprintf(funit,"SPACING %f %f %f\n",(*dx1)*(*j1),(*dx2)*(*j2),(*dx3)*(*j3));
+
+ // data header for this grid
+ fprintf(funit,"POINT_DATA %i\n",((*sx1)/(*j1))*((*sx2)/(*j2))*((*sx3)/(*j3)));
+
+ // data array
+ fprintf(funit,"TENSORS %s float\n",name);
+
+ // data values
+ for (k3=0; k3<(*sx3); k3=k3+(*j3)){
+ for (k2=-(*sx2)/2; k2<(*sx2)/2; k2=k2+(*j2)){
+ i2=((*sx2)+fix(k2)) % (*sx2);
+
+ for (k1=-(*sx1)/2; k1<(*sx1)/2; k1+=(*j1)){
+ i1=((*sx1)+fix(k1)) % (*sx1);
+
+ // index of first stress component
+ index=(i1+(i2+k3*(*sx2))*(*sx1))*DOF;
+
+ // convert to big endian if necessary
+ buffer[0]=(1u==endian)?sig[index+0]:swap(sig[index+0]);
+ buffer[1]=(1u==endian)?sig[index+1]:swap(sig[index+1]);
+ buffer[2]=(1u==endian)?sig[index+2]:swap(sig[index+2]);
+ buffer[3]=(1u==endian)?sig[index+1]:swap(sig[index+1]);
+ buffer[4]=(1u==endian)?sig[index+3]:swap(sig[index+3]);
+ buffer[5]=(1u==endian)?sig[index+4]:swap(sig[index+4]);
+ buffer[6]=(1u==endian)?sig[index+2]:swap(sig[index+2]);
+ buffer[7]=(1u==endian)?sig[index+4]:swap(sig[index+4]);
+ buffer[8]=(1u==endian)?sig[index+5]:swap(sig[index+5]);
+
+ // write buffer to disk
+ fwrite(buffer,36,1,funit);
+ }
+ }
+ }
+
+ // close binary file
+ fclose(funit);
+
+}
+
diff -r 405d8f4fa05f -r e7295294f654 types.f90
--- a/types.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,205 +0,0 @@
-!-----------------------------------------------------------------------
-! Copyright 2007, 2008, 2009 Sylvain Barbot
-!
-! This file is part of RELAX
-!
-! RELAX 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 3 of the License, or
-! (at your option) any later version.
-!
-! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
-!-----------------------------------------------------------------------
-
-#include "include.f90"
-
-MODULE types
-
- TYPE SOURCE_STRUCT
- SEQUENCE
- REAL*8 :: slip,x,y,z,width,length,strike,dip,rake,period,phase,beta
- END TYPE SOURCE_STRUCT
-
- TYPE PLANE_STRUCT
- SEQUENCE
- REAL*8 :: x,y,z,width,length,strike,dip,rake
- END TYPE PLANE_STRUCT
-
- TYPE LAYER_STRUCT
- SEQUENCE
- REAL*8 :: z,gammadot0,stressexponent,cohesion,friction
- END TYPE LAYER_STRUCT
-
- TYPE WEAK_STRUCT
- SEQUENCE
- REAL*8 :: dgammadot0,x,y,z,width,length,thickness,strike,dip
- END TYPE WEAK_STRUCT
-
- TYPE VECTOR_STRUCT
- SEQUENCE
- REAL*8 :: v1,v2,v3
- END TYPE VECTOR_STRUCT
-
- TYPE TENSOR
- SEQUENCE
- REAL*4 :: s11,s12,s13,s22,s23,s33
- END TYPE TENSOR
-
- TYPE TENSOR_LAYER_STRUCT
- SEQUENCE
- REAL*4 :: z,dum
- TYPE(TENSOR) :: t
- END TYPE TENSOR_LAYER_STRUCT
-
- TYPE SEGMENT_STRUCT
- SEQUENCE
- REAL*8 :: x,y,z,width,length,strike,dip,friction
- TYPE(TENSOR) :: sig0
- END TYPE SEGMENT_STRUCT
-
- TYPE SLIPPATCH_STRUCT
- SEQUENCE
- REAL*8 :: x1,x2,x3,lx,lz,slip,ss,ds
- TYPE(TENSOR) :: sig
- END TYPE SLIPPATCH_STRUCT
-
- TYPE EVENT_STRUC
- REAL*8 :: time
- INTEGER*4 :: i,ns,nt,nm,nl
- TYPE(SOURCE_STRUCT), DIMENSION(:), ALLOCATABLE :: s,sc,ts,tsc,m,mc,l,lc
- END TYPE EVENT_STRUC
-
- TYPE, PUBLIC :: SIMULATION_STRUC
- ! grid dimension
- INTEGER :: sx1,sx2,sx3
-
- ! sampling
- REAL*8 :: dx1,dx2,dx3
-
- ! smoothing factor
- REAL*8 :: beta
-
- ! filter parameter for slip models
- REAL*8 :: nyquist
-
- ! center coordinates and rotation
- REAL*8 :: x0,y0,rot
-
-#ifdef PROJ
- ! geographic coordinates of center, UTM zone, length unit
- REAL*8 :: lon0,lat0,umult
- INTEGER :: zone
-#endif
-
- ! observation depths
- REAL*8 :: oz,ozs
-
- ! output directory
- CHARACTER(80) :: wdir
-
- ! filenames
- CHARACTER(80) :: reportfilename,reporttimefilename
-
- ! elastic moduli and gravity parameter
- REAL*8 :: lambda,mu,gam
-
- ! time step parameters
- REAL*8 :: interval
- REAL*8 :: odt,tscale
- INTEGER :: skip=0
-
- ! number of observation planes
- INTEGER :: nop
-
- ! observation planes
- TYPE(PLANE_STRUCT), DIMENSION(:), ALLOCATABLE :: op
-
- ! number of stress observation planes
- INTEGER :: nsop
-
- ! stress observation planes
- TYPE(SEGMENT_STRUCT), DIMENSION(:), ALLOCATABLE :: sop
-
- ! number of observation points
- INTEGER :: npts
-
- ! observation points
- TYPE(VECTOR_STRUCT), DIMENSION(:), ALLOCATABLE :: opts
-
- ! observation points name
- CHARACTER(LEN=4), DIMENSION(:), ALLOCATABLE :: ptsname
-
- ! number of prestress interfaces
- INTEGER :: nps
-
- ! stress layers and stress structure
- TYPE(TENSOR_LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: stresslayer,stressstruc
-
- ! number of linear viscous interfaces
- INTEGER :: nv
-
- ! linear viscous layers and structure
- TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: linearlayer,linearstruc
-
- ! number of linear weak zones
- INTEGER :: nlwz
-
- ! linear weak zones
- TYPE(WEAK_STRUCT), DIMENSION(:), ALLOCATABLE :: linearweakzone,linearweakzonec
-
- ! number of nonlinear viscous interfaces
- INTEGER :: npl
-
- ! nonlinear viscous layers and structure
- TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: nonlinearlayer,nonlinearstruc
-
- ! number of nonlinear weak zones
- INTEGER :: nnlwz
-
- ! nonlinear viscous layers and structure
- TYPE(WEAK_STRUCT), DIMENSION(:), ALLOCATABLE :: nonlinearweakzone,nonlinearweakzonec
-
- ! number of fault creep interfaces
- INTEGER :: nfc
-
- ! fault creep interfaces
- TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: faultcreeplayer,faultcreepstruc
-
- ! number of afterslip planes
- INTEGER :: np
-
- ! afterslip planes
- TYPE(PLANE_STRUCT), DIMENSION(:), ALLOCATABLE :: n
-
- ! interseismic event
- TYPE(EVENT_STRUC) :: inter
-
- ! number of coseismic events
- INTEGER :: ne
-
- ! coseismic events
- TYPE(EVENT_STRUC), DIMENSION(:), ALLOCATABLE :: events
-
- ! overrides output to formats
- LOGICAL :: isoutputproj=.TRUE.
- LOGICAL :: isoutputrelax=.TRUE.
- LOGICAL :: isoutputtxt=.TRUE.
- LOGICAL :: isoutputvtk=.TRUE.
- LOGICAL :: isoutputvtkrelax=.FALSE.
- LOGICAL :: isoutputgrd=.TRUE.
- LOGICAL :: isoutputxyz=.TRUE.
- LOGICAL :: isoutputstress=.TRUE.
-
- ! other options
- LOGICAL :: isdryrun=.FALSE.
- LOGICAL :: ishelp=.FALSE.
-
- END TYPE SIMULATION_STRUC
-
-END MODULE types
diff -r 405d8f4fa05f -r e7295294f654 viscoelastic3d.f90
--- a/viscoelastic3d.f90 Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,288 +0,0 @@
-!-----------------------------------------------------------------------
-! Copyright 2007, 2008, 2009 Sylvain Barbot
-!
-! This file is part of RELAX
-!
-! RELAX 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 3 of the License, or
-! (at your option) any later version.
-!
-! RELAX 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 RELAX. If not, see <http://www.gnu.org/licenses/>.
-!-----------------------------------------------------------------------
-
-MODULE viscoelastic3d
-
- USE elastic3d
-
- IMPLICIT NONE
-
-#include "include.f90"
-
- REAL*8, PRIVATE, PARAMETER :: pi = 3.141592653589793115997963468544185161_8
- REAL*8, PRIVATE, PARAMETER :: pi2 = 6.28318530717958623199592693708837032318_8
- REAL*8, PRIVATE, PARAMETER :: pid2 = 1.57079632679489655799898173427209258079_8
-
-CONTAINS
-
- !-----------------------------------------------------------------
- !> subroutine ViscoElasticDeviatoricStress
- !! computes the instantaneous deviatoric stress tensor sigma_ij'
- !!
- !! sigma_ij' = 2*mu*(-delta_ij epsilon_kk/3 + epsilon_ij) - tau_ij
- !!
- !! such as
- !!
- !! sigma_kk'= 0
- !!
- !! where tau_ij is a second-order deviatoric symmetric tensor
- !! that integrates the history of the relaxed stress. strain is
- !! estimated using a centered finite difference derivative.
- !!
- !! \author sylvain barbot (07/07/07) - original form
- !-----------------------------------------------------------------
- SUBROUTINE viscoelasticdeviatoricstress(mu,u1,u2,u3,tau,&
- dx1,dx2,dx3,sx1,sx2,sx3,sig)
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- REAL*8, INTENT(IN) :: mu,dx1,dx2,dx3
- REAL*4, INTENT(IN), DIMENSION(sx1,sx2,sx3) :: u1,u2,u3
- TYPE(TENSOR), INTENT(IN), DIMENSION(:,:,:) :: tau
- TYPE(TENSOR), INTENT(OUT), DIMENSION(:,:,:) :: sig
-
- TYPE(TENSOR) :: s
- INTEGER :: i1,i2,i3,i1p,i2p,i3p,i1m,i2m,i3m
- REAL*8 :: epskk,px1,px2,px3
-
- px1=dx1*2._8
- px2=dx2*2._8
- px3=dx3*2._8
-
- ! space domain with finite difference scheme
- DO i3=1,sx3
- ! wrap around neighbor
- i3m=mod(sx3+i3-2,sx3)+1
- i3p=mod(i3,sx3)+1
- DO i2=1,sx2
- i2m=mod(sx2+i2-2,sx2)+1
- i2p=mod(i2,sx2)+1
-
- DO i1=1,sx1
- i1m=mod(sx1+i1-2,sx1)+1
- i1p=mod(i1,sx1)+1
-
- ! trace component
- epskk=((u1(i1p,i2,i3)-u1(i1m,i2,i3))/px1+&
- (u2(i1,i2p,i3)-u2(i1,i2m,i3))/px2+&
- (u3(i1,i2,i3p)-u3(i1,i2,i3m))/px3)/3._8
-
- s%s11=2._8*mu*( (u1(i1p,i2,i3)-u1(i1m,i2,i3))/px1-epskk )
- s%s12= mu*( (u1(i1,i2p,i3)-u1(i1,i2m,i3))/px2+ &
- (u2(i1p,i2,i3)-u2(i1m,i2,i3))/px1)
- s%s13= mu*( (u1(i1,i2,i3p)-u1(i1,i2,i3m))/px3+ &
- (u3(i1p,i2,i3)-u3(i1m,i2,i3))/px1)
- s%s22=2._8*mu*( (u2(i1,i2p,i3)-u2(i1,i2m,i3))/px2-epskk )
- s%s23= mu*( (u2(i1,i2,i3p)-u2(i1,i2,i3m))/px3+ &
- (u3(i1,i2p,i3)-u3(i1,i2m,i3))/px2)
- s%s33=2._8*mu*( (u3(i1,i2,i3p)-u3(i1,i2,i3m))/px3-epskk )
-
- sig(i1,i2,i3)= s .minus. tau(i1,i2,i3)
-
- END DO
- END DO
- END DO
-
- ! no normal traction at the boundary
- sig(:,:,1)%s13=0
- sig(:,:,1)%s23=0
- sig(:,:,1)%s33=0
- sig(:,:,sx3)%s13=0
- sig(:,:,sx3)%s23=0
- sig(:,:,sx3)%s33=0
-
- END SUBROUTINE viscoelasticdeviatoricstress
-
- !-----------------------------------------------------------------
- !> subroutine ViscousEigenstress
- !! computes the moment density rate due to a layered viscoelastic
- !! structure with powerlaw creep
- !!
- !! d Ei / dt = C:F:sigma'
- !!
- !! where C is the elastic moduli tensor, F is the heterogeneous
- !! fluidity tensor and sigma' is the instantaneous deviatoric
- !! stress. F is stress dependent (powerlaw creep.)
- !!
- !! \author sylvain barbot (08/30/08) - original form
- !-----------------------------------------------------------------
- SUBROUTINE viscouseigenstress(mu,structure,ductilezones,nz,sig,sx1,sx2,sx3, &
- dx1,dx2,dx3,moment,beta,maxwelltime,gamma)
- REAL*8, INTENT(IN) :: mu,dx1,dx2,dx3,beta
- INTEGER, INTENT(IN) :: nz
- TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
- TYPE(WEAK_STRUCT), DIMENSION(nz), INTENT(IN) :: ductilezones
- INTEGER, INTENT(IN) :: sx1,sx2,sx3
- TYPE(TENSOR), INTENT(IN), DIMENSION(sx1,sx2,sx3) :: sig
- TYPE(TENSOR), INTENT(OUT), DIMENSION(sx1,sx2,sx3) :: moment
- REAL*8, OPTIONAL, INTENT(INOUT) :: maxwelltime
-#ifdef ALIGN_DATA
- REAL*4, DIMENSION(sx1+2,sx2,sx3), INTENT(OUT), OPTIONAL :: gamma
-#else
- REAL*4, DIMENSION(sx1,sx2,sx3), INTENT(OUT), OPTIONAL :: gamma
-#endif
-
- INTEGER :: i1,i2,i3
- TYPE(TENSOR) :: s,R
- TYPE(TENSOR), PARAMETER :: zero = tensor(0._4,0._4,0._4,0._4,0._4,0._4)
- REAL*8 :: gammadot,tau,tauc,gammadot0,power,cohesion,x1,x2,x3,dg0,dum
- REAL*4 :: tm
-
- IF (SIZE(structure,1) .NE. sx3) RETURN
-
- IF (PRESENT(maxwelltime)) THEN
- tm=REAL(maxwelltime)
- ELSE
- tm=1e30
- END IF
-
-!$omp parallel do private(i1,i2,gammadot0,power,cohesion,s,tau,R,tauc,gammadot,dg0,x1,x2,x3,dum), &
-!$omp reduction(MIN:tm)
- DO i3=1,sx3
- power=structure(i3)%stressexponent
- cohesion=structure(i3)%cohesion
- x3=DBLE(i3-1)*dx3
-
- IF (power .LT. 0.999999_8) THEN
- WRITE_DEBUG_INFO
- WRITE (0,'("power=",ES9.2E1)') power
- WRITE (0,'("invalid power exponent. interrupting.")')
- STOP 1
- END IF
-
- DO i2=1,sx2
- DO i1=1,sx1
- ! local coordinates
- CALL shiftedcoordinates(i1,i2,i3,sx1,sx2,sx3, &
- dx1,dx2,dx3,x1,x2,dum)
-
- ! depth-dependent fluidity structure
- gammadot0=structure(i3)%gammadot0
-
- ! perturbation from isolated viscous zones
- dg0=dgammadot0(ductilezones,nz,x1,x2,x3,beta)
-
- ! local fluidity structure
- gammadot0=gammadot0+dg0
-
- IF (1.0d-20 .GT. gammadot0) CYCLE
-
- ! local deviatoric stress
- s=tensordeviatoric(sig(i1,i2,i3))
-
- ! s = tau * R
- CALL tensordecomposition(s,tau,R)
-
- ! effective stress
- tauc=tau-cohesion
-
- ! cohesion test
- IF (tauc .LE. 1.0d-20) CYCLE
-
- ! powerlaw viscosity
- gammadot=gammadot0*(tauc/mu)**power
-
- ! update moment density forcing
- moment(i1,i2,i3)=moment(i1,i2,i3) .plus. &
- (REAL(2._8*mu*gammadot) .times. R)
-
- tm=MIN(tm,tauc/mu/gammadot)
-
- IF (PRESENT(gamma)) &
- gamma(i1,i2,i3)=gammadot
-
- END DO
- END DO
- END DO
-!$omp end parallel do
-
- IF (PRESENT(maxwelltime)) maxwelltime=MIN(tm,maxwelltime)
-
- CONTAINS
-
- !---------------------------------------------------------
- !> function dgammadot0
- !! evaluates the change of fluidity at position x1,x2,x3
- !! due to the presence of weak ductile zones. the extent
- !! and magnitude of ductile zones is tapered (beta).
- !!
- !! \author sylvain barbot (3/29/10) - original form
- !---------------------------------------------------------
- REAL*8 FUNCTION dgammadot0(zones,n,x1,x2,x3,beta)
- INTEGER, INTENT(IN) :: n
- TYPE(WEAK_STRUCT), INTENT(IN), DIMENSION(nz) :: zones
- REAL*8, INTENT(IN) :: x1,x2,x3,beta
-
- REAL*8 :: dg,x,y,z,L,W,D,strike,dip,LM
- REAL*8 :: cstrike,sstrike,cdip,sdip, &
- xr,yr,zr,x2r,Wp,Lp,Dp,x1s,x2s,x3s
- INTEGER :: i
-
- ! default is no change in fluidity
- dgammadot0=0._8
-
- DO i=1,n
- ! retrieve weak zone geometry
- dg=zones(i)%dgammadot0
-
- x=zones(i)%x
- y=zones(i)%y
- z=zones(i)%z
- W=zones(i)%length
- L=zones(i)%width
- D=zones(i)%thickness
- strike=zones(i)%strike
- dip=zones(i)%dip
-
- ! effective tapered dimensions
- Wp=W*(1._8+2._8*beta)/2._8
- Lp=L*(1._8+2._8*beta)/2._8
- Dp=D*(1._8+2._8*beta)/2._8
- LM=MAX(Wp,Lp,Dp)
-
- ! check distance from weak zone
- IF ((ABS(x3-z).GT.LM) .OR. &
- (ABS(x1-x).GT.LM) .OR. &
- (ABS(x2-y).GT.LM)) CYCLE
-
- ! evaluate contribution from weak zone
- cstrike=cos(strike)
- sstrike=sin(strike)
- cdip=cos(dip)
- sdip=sin(dip)
-
- ! rotate centre coordinates of weak zone
- x2r= cstrike*x -sstrike*y
- xr = cdip *x2r-sdip *z
- yr = sstrike*x +cstrike*y
- zr = sdip *x2r+cdip *z
-
- x2r= cstrike*x1 -sstrike*x2
- x1s= cdip *x2r-sdip *x3
- x2s= sstrike*x1 +cstrike*x2
- x3s= sdip *x2r+cdip *x3
-
- dgammadot0=dgammadot0+omega((x1s-xr)/D,beta) &
- *omega((x2s-yr)/W,beta) &
- *omega((x3s-zr)/L,beta)*dg
- END DO
-
- END FUNCTION dgammadot0
-
- END SUBROUTINE viscouseigenstress
-
-END MODULE viscoelastic3d
diff -r 405d8f4fa05f -r e7295294f654 writegrd3.4.c
--- a/writegrd3.4.c Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,87 +0,0 @@
-# include <gmt.h>
-
-/* Fortran callable routine to write a grd file in pixel registration */
-/* June 23, 1995 - David Sandwell */
-/* Revised for GMT3.4 December 28, 2002 - David Sandwell */
-/* Modified for node registration - March 19, 2008 - Sylvain Barbot */
-
-void writegrd(rdat,nx,ny,rlt0,rln0,dlt,dln,rland,rdum,title,fileout)
-
- float *rdat; /* real array for output */
- int *nx; /* number of x points */
- int *ny; /* number of y points */
- double *rlt0; /* starting latitude */
- double *rln0; /* starting longitude */
- double *dlt; /* latitude spacing */
- double *dln; /* longitude spacing */
- double *rland; /* land value */
- double *rdum; /* dummy value */
- char *title; /* title */
- char *fileout; /* filename of output file */
-
- {
- int i;
- double xmin, xmax, xinc, ymin, ymax, yinc, zmin, zmax;
- int update = FALSE;
- struct GRD_HEADER grd;
- int argc = 0;
- char **argv = NULL;
-
-/* Initialize with default values */
-
- GMT_grdio_init();
- GMT_make_dnan(GMT_d_NaN);
- GMT_make_fnan(GMT_f_NaN);
-
- GMT_grd_init(&grd, argc, argv, update);
-
-/* Calculate header parameters */
- xmax = *rln0 + ((*nx)-1) * *dln;
- xmin = *rln0;
- if(xmax < xmin) {
- xmin = xmax;
- xmax = *rln0;
- }
- xinc = fabs((double)*dln);
-
- ymax = *rlt0 + ((*ny)-1) * *dlt;
- ymin = *rlt0;
- if(ymax < ymin) {
- ymin = ymax;
- ymax = *rlt0;
- }
- yinc = fabs((double)*dlt);
-
-
-/* calculate zmin and zmax and zinc and set dummy values to NaN. */
-
- zmin = fabs((double)*rdum);
- zmax = -fabs((double)*rdum);
-
- for (i = 0; i < *nx * *ny; i++) {
- if((rdat[i] == *rdum) || (rdat[i] == *rland)) rdat[i] = GMT_f_NaN;
- else {
- if(rdat[i] < zmin) zmin = rdat[i];
- if(rdat[i] > zmax) zmax = rdat[i];
- }
- }
-
-/* update the header using values passed */
-
- strncpy(grd.title,title,80);
- grd.nx = *nx;
- grd.ny = *ny;
- grd.node_offset = FALSE;
- grd.x_min = xmin;
- grd.x_max = xmax;
- grd.x_inc = xinc;
- grd.y_min = ymin;
- grd.y_max = ymax;
- grd.y_inc = yinc;
- grd.z_min = zmin;
- grd.z_max = zmax;
-
-/* write the file */
- GMT_write_grd(fileout, &grd, rdat, 0.0, 0.0, 0.0, 0.0, GMT_pad, FALSE );
-
- }
diff -r 405d8f4fa05f -r e7295294f654 writegrd4.2.c
--- a/writegrd4.2.c Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,100 +0,0 @@
-/************************************************************************
-* writegrd routine to write a grd file in pixel registration *
-************************************************************************/
-/************************************************************************
-* Creator: David T. Sandwell Scripps Institution of Oceanography *
-* Date : 06/23/95 Copyright, David T. Sandwell *
-************************************************************************/
-/************************************************************************
-* Modification history: *
-* Revised for GMT3.4 December 28, 2002 - David Sandwell *
-* Revised for GMT4.2 May 10, 2007 - David Sandwell *
-* Modified for pixel registration April 18, 2008 - Sylvain Barbot *
-************************************************************************/
-
-# include <math.h>
-# include <gmt.h>
-
-void writegrd_(rdat,nx,ny,rlt0,rln0,dlt,dln,rland,rdum,title,fileout)
-
- float *rdat; /* real array for output */
- int *nx; /* number of x points */
- int *ny; /* number of y points */
- double *rlt0; /* starting latitude */
- double *rln0; /* starting longitude */
- double *dlt; /* latitude spacing */
- double *dln; /* longitude spacing */
- double *rland; /* land value */
- double *rdum; /* dummy value */
- char *title; /* title */
- char *fileout; /* filename of output file */
-
- {
- int i;
- double xmin, xmax, xinc, ymin, ymax, yinc, zmin, zmax;
- struct GRD_HEADER grd;
- int argc2 = 1;
- char *argv2[2] = {"writegrd",0};
-
-/* Initialize with default values */
-
- GMT_begin (argc2,argv2);
- GMT_grd_init(&grd, argc2, argv2, FALSE);
-
-/* Calculate header parameters */
-
- xmax = *rln0 + ((*nx)-1) * *dln;
- xmin = *rln0;
- if(xmax < xmin) {
- xmin = xmax;
- xmax = *rln0;
- }
- xinc = fabs((double)*dln);
- ymax = *rlt0 + ((*ny)-1) * *dlt;
- ymin = *rlt0;
- if(ymax < ymin) {
- ymin = ymax;
- ymax = *rlt0;
- }
- yinc = fabs((double)*dlt);
-
-/* calculate zmin and zmax and zinc and set dummy values to NaN. */
-
- zmin = +fabs((double)*rdum);
- zmax = -fabs((double)*rdum);
-
- for (i = 0; i < *nx * *ny; i++) {
- if((rdat[i] == *rdum) || (rdat[i] == *rland)) rdat[i] = GMT_f_NaN;
- else {
- if(rdat[i] < zmin) zmin = rdat[i];
- if(rdat[i] > zmax) zmax = rdat[i];
- }
- }
-
-/* update the header using values passed */
-
- strncpy(grd.title,title,GRD_TITLE_LEN);
- grd.nx = *nx;
- grd.ny = *ny;
- grd.node_offset = FALSE;
- grd.x_min = xmin;
- grd.x_max = xmax;
- grd.x_inc = xinc;
- grd.y_min = ymin;
- grd.y_max = ymax;
- grd.y_inc = yinc;
- grd.z_min = zmin;
- grd.z_max = zmax;
-
-/* grd.type = 10;
- grd.z_id = 15;
- grd.ncid = 15;*/
-
-/* write the file */
-
- GMT_write_grd(fileout, &grd, rdat, 0.0, 0.0, 0.0, 0.0, GMT_pad, FALSE);
-
-/* GMT_end (argc2,argv2); */
-
- }
-
diff -r 405d8f4fa05f -r e7295294f654 writevtk.c
--- a/writevtk.c Thu Mar 29 15:55:33 2012 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,226 +0,0 @@
-/*************************************************************
-* export vectors and tensors in big-endian mixed ascii/binary
-* vtk format for Paraview.
-*
-* sylvain barbot 10/27/11 - original form
-*************************************************************/
-
-#include <math.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include "config.h"
-
-// check data alignment
-#ifdef FFTW3
-#define ALIGN_DATA 1
-#else
-#ifdef SGI_FFT
-#define ALIGN_DATA 1
-#else
-#ifdef IMKL_FFT
-#define ALIGN_DATA 1
-#endif
-#endif
-#endif
-
-int fix(int n){
- if(n<0) return n-1;return n+1;
-}
-
-float swap(float d){
- float a;
- unsigned char *dst = (unsigned char *)&a;
- unsigned char *src = (unsigned char *)&d;
- dst[0] = src[3];
- dst[1] = src[2];
- dst[2] = src[1];
- dst[3] = src[0];
- return a;
-}
-
-// test endianness of the machine
-unsigned char isbigendian(){
-
- typedef union{
- int i;
- char c[4];
- } u;
- u temp;
-
- temp.i = 0x12345678;
-
- switch(temp.c[0]) {
- case 0x12:
- return 1u; // big endian
- case 0x78:
- return 0u; // little endian
- default:
- fprintf(stderr,"invalid result for endianness test.\n");
- fprintf(stderr,"temp %x %x %x %x.\n",temp.c[0],temp.c[1],temp.c[2],temp.c[3]);
- fprintf(stderr,"temp %x \n",temp.c[0]);
- return 2u;
- }
-}
-
-/*************************************************************
-* subroutine ExportVTK_Vectors_Legacy
-* creates a .vtk file in the VTK Legacy binary format with
-* structured points containing a vector field.
-*
-* sylvain barbot 10/27/11 - original form
-*************************************************************/
-void exportvtk_vectors_legacy_(u1,u2,u3,sx1,sx2,sx3,dx1,dx2,dx3,j1,j2,j3,filename,title,name)
- float *u1, *u2, *u3; /* data array for output */
- int *sx1, *sx2, *sx3; /* number of points */
- double*dx1, *dx2, *dx3; /* sampling distance */
- int *j1, *j2, *j3; /* subsampling rate */
- char *filename; /* output file name */
- char *title; /* output file name */
- char *name; /* output file name */
-{
-
- FILE * funit;
- float buffer[3];
- int i1,i2,k1,k2,k3,index;
- unsigned char endian;
-
- funit=fopen(filename,"wb");
- if (NULL==funit){
- fprintf(stderr,"could not open file %s for vtk output\n",filename);
- fprintf(stderr,"exiting.\n");
- return;
- }
-
- // find endianness
- endian=isbigendian();
-
- // writing header of file
- fprintf(funit,"# vtk DataFile Version 3.0\n");
- fprintf(funit,"%s\n",title);
- fprintf(funit,"BINARY\n");
- fprintf(funit,"DATASET STRUCTURED_POINTS\n");
-
- // structured points grid
- fprintf(funit,"DIMENSIONS %i %i %i\n",(*sx1)/(*j1),(*sx2)/(*j2),(*sx3)/(*j3));
- fprintf(funit,"ORIGIN %f %f %f\n",-(*dx1)*((*sx1)/2),-(*dx2)*((*sx2)/2),0.0);
- fprintf(funit,"SPACING %f %f %f\n",(*dx1)*(*j1),(*dx2)*(*j2),(*dx3)*(*j3));
-
- // data header for this grid
- fprintf(funit,"POINT_DATA %i\n",((*sx1)/(*j1))*((*sx2)/(*j2))*((*sx3)/(*j3)));
-
- // data array
- fprintf(funit,"VECTORS %s float\n",name);
-
- // data values
- for (k3=0; k3<(*sx3); k3=k3+(*j3)){
- for (k2=-(*sx2)/2; k2<(*sx2)/2; k2=k2+(*j2)){
- i2=((*sx2)+fix(k2)) % (*sx2);
-
- for (k1=-(*sx1)/2; k1<(*sx1)/2; k1+=(*j1)){
- i1=((*sx1)+fix(k1)) % (*sx1);
-
-#ifdef ALIGN_DATA
- index=i1+(i2+k3*(*sx2))*((*sx1)+2);
-#else
- index=i1+(i2+k3*(*sx2))*(*sx1);
-#endif
-
- // convert to big endian if necessary
- buffer[0]=(1u==endian)?u1[index]:swap(u1[index]);
- buffer[1]=(1u==endian)?u2[index]:swap(u2[index]);
- buffer[2]=(1u==endian)?u3[index]:swap(u3[index]);
-
- fwrite(buffer,12,1,funit);
- }
- }
- }
-
- // close binary file
- fclose(funit);
-
-}
-
-
-/*************************************************************
-* subroutine ExportVTK_tensors_Legacy
-* creates a .vtk file in the VTK Legacy binary format with
-* structured points containing a vector field.
-*
-* sylvain barbot 10/28/11 - original form
-*************************************************************/
-void exportvtk_tensors_legacy_(sig,sx1,sx2,sx3,dx1,dx2,dx3,j1,j2,j3,filename,title,name)
- float *sig; /* data array for tensor output */
- int *sx1, *sx2, *sx3; /* number of points */
- double*dx1, *dx2, *dx3; /* sampling distance */
- int *j1, *j2, *j3; /* subsampling rate */
- char *filename; /* output file name */
- char *title; /* output file name */
- char *name; /* output file name */
-{
-
- FILE * funit;
- float buffer[9];
- int i1,i2,k1,k2,k3,index;
- unsigned char endian;
-#define DOF 6
-
- funit=fopen(filename,"wb");
- if (NULL==funit){
- fprintf(stderr,"could not open file %s for vtk output\n",filename);
- fprintf(stderr,"exiting.\n");
- return;
- }
-
- // find endianness
- endian=isbigendian();
-
- // writing header of file
- fprintf(funit,"# vtk DataFile Version 3.0\n");
- fprintf(funit,"%s\n",title);
- fprintf(funit,"BINARY\n");
- fprintf(funit,"DATASET STRUCTURED_POINTS\n");
-
- // structured points grid
- fprintf(funit,"DIMENSIONS %i %i %i\n",(*sx1)/(*j1),(*sx2)/(*j2),(*sx3)/(*j3));
- fprintf(funit,"ORIGIN %f %f %f\n",-(*dx1)*((*sx1)/2),-(*dx2)*((*sx2)/2),0.0);
- fprintf(funit,"SPACING %f %f %f\n",(*dx1)*(*j1),(*dx2)*(*j2),(*dx3)*(*j3));
-
- // data header for this grid
- fprintf(funit,"POINT_DATA %i\n",((*sx1)/(*j1))*((*sx2)/(*j2))*((*sx3)/(*j3)));
-
- // data array
- fprintf(funit,"TENSORS %s float\n",name);
-
- // data values
- for (k3=0; k3<(*sx3); k3=k3+(*j3)){
- for (k2=-(*sx2)/2; k2<(*sx2)/2; k2=k2+(*j2)){
- i2=((*sx2)+fix(k2)) % (*sx2);
-
- for (k1=-(*sx1)/2; k1<(*sx1)/2; k1+=(*j1)){
- i1=((*sx1)+fix(k1)) % (*sx1);
-
- // index of first stress component
- index=(i1+(i2+k3*(*sx2))*(*sx1))*DOF;
-
- // convert to big endian if necessary
- buffer[0]=(1u==endian)?sig[index+0]:swap(sig[index+0]);
- buffer[1]=(1u==endian)?sig[index+1]:swap(sig[index+1]);
- buffer[2]=(1u==endian)?sig[index+2]:swap(sig[index+2]);
- buffer[3]=(1u==endian)?sig[index+1]:swap(sig[index+1]);
- buffer[4]=(1u==endian)?sig[index+3]:swap(sig[index+3]);
- buffer[5]=(1u==endian)?sig[index+4]:swap(sig[index+4]);
- buffer[6]=(1u==endian)?sig[index+2]:swap(sig[index+2]);
- buffer[7]=(1u==endian)?sig[index+4]:swap(sig[index+4]);
- buffer[8]=(1u==endian)?sig[index+5]:swap(sig[index+5]);
-
- // write buffer to disk
- fwrite(buffer,36,1,funit);
- }
- }
- }
-
- // close binary file
- fclose(funit);
-
-}
-
diff -r 405d8f4fa05f -r e7295294f654 wscript
--- a/wscript Thu Mar 29 15:55:33 2012 -0700
+++ b/wscript Sun Apr 01 14:02:51 2012 -0700
@@ -191,22 +191,22 @@ def configure(cnf):
def build(bld):
bld.program(features='c fc fcprogram',
- source=['relax.f90',
- 'types.f90',
- 'ctfft.f',
- 'fourier.f90',
- 'green.f90',
- 'elastic3d.f90',
- 'friction3d.f90',
- 'viscoelastic3d.f90',
- 'writevtk.c',
- 'writegrd4.2.c',
- 'proj.c',
- 'export.f90',
- 'getdata.f',
- 'getopt_m.f90',
- 'input.f90',
- 'mkl_dfti.f90'],
+ source=['src/relax.f90',
+ 'src/types.f90',
+ 'src/ctfft.f',
+ 'src/fourier.f90',
+ 'src/green.f90',
+ 'src/elastic3d.f90',
+ 'src/friction3d.f90',
+ 'src/viscoelastic3d.f90',
+ 'src/writevtk.c',
+ 'src/writegrd4.2.c',
+ 'src/proj.c',
+ 'src/export.f90',
+ 'src/getdata.f',
+ 'src/getopt_m.f90',
+ 'src/input.f90',
+ 'src/mkl_dfti.f90'],
includes=['build'],
use=['gmt','proj','openmp','fftw','imkl','zero','cpp'],
target='relax'
More information about the CIG-COMMITS
mailing list