[cig-commits] commit: Initial import
Mercurial
hg at geodynamics.org
Tue Sep 20 12:12:54 PDT 2011
changeset: 0:56a2cd733fb8
tag: version-1-0
user: Sylvain Barbot <sylbar.vainbot at gmail.com>
date: Thu Jan 06 15:36:19 2011 -0800
files: COPYING clean.mk ctfft.f elastic3d.f90 export.f90 fourier.f90 friction3d.f90 getdata.f green.f90 include.f90 kernel1.inc kernel11.inc kernel14.inc kernel14bis.inc kernel7.inc makefile makefile_fftw makefile_fourt makefile_imkl makefile_sgfft mkl_dfti.f90 proj.c relax.f90 relax.sh run1.sh template.sh viscoelastic3d.f90 writegrd3.4.c writegrd4.2.c
description:
Initial import
diff -r 000000000000 -r 56a2cd733fb8 COPYING
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/COPYING Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,675 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ 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. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ <program> Copyright (C) <year> <name of author>
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+<http://www.gnu.org/licenses/>.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+
diff -r 000000000000 -r 56a2cd733fb8 clean.mk
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/clean.mk Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,3 @@
+clean:
+ rm -f *.o *.mod *~
+
diff -r 000000000000 -r 56a2cd733fb8 ctfft.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ctfft.f Thu Jan 06 15:36:19 2011 -0800
@@ -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 000000000000 -r 56a2cd733fb8 elastic3d.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/elastic3d.f90 Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,3151 @@
+!-----------------------------------------------------------------------
+! 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 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
+
+ TYPE SOURCE_STRUCT
+ SEQUENCE
+ REAL*8 :: slip,x,y,z,width,length,strike,dip,rake
+ END TYPE SOURCE_STRUCT
+
+ TYPE PLANE_STRUCT
+ SEQUENCE
+ REAL*8 :: x,y,z,width,length,strike,dip
+ 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 SLIPPATCH_STRUCT
+ SEQUENCE
+ REAL*8 :: x1,x2,x3,lx,lz,slip,ss,ds
+ END TYPE SLIPPATCH_STRUCT
+
+ TYPE EVENT_STRUC
+ REAL*8 :: time
+ INTEGER*4 :: ns,nt,nm,nl
+ TYPE(SOURCE_STRUCT), DIMENSION(:), ALLOCATABLE :: s,sc,ts,tsc,m,mc,l,lc
+ END TYPE EVENT_STRUC
+
+ 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
+ ! k wavenumber
+ ! 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.
+ !
+ ! 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(:)%stressexponent=1 ! default is linear
+ vstruct(:)%friction=0.6 ! default is friction=0.6
+ vstruct(:)%cohesion=0 ! default is no cohesion
+
+ 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
+ !
+ ! epsilon_ij = 1/2 ( u_i,j + u_j,i )
+ !
+ ! 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
+ !
+ ! 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');
+ !
+ ! 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
+ !
+ ! sigma' = - C' : E
+ !
+ ! or in indicial notation
+ !
+ ! sigma_ij' = -lambda'*delta_ij*epsilon_kk - 2*mu'*epsilon_ij
+ !
+ ! where C' is the heterogeneous elastic moduli tensor and lambda'
+ ! and mu' are the inhomogeneous lame parameters
+ !
+ ! C' = C(x) - C_0
+ !
+ ! For isotropic materials
+ !
+ ! mu'(x) = mu(x) - mu_0
+ ! lambda'(x) = lambda(x) - lambda_0
+ !
+ ! Optionally, the surface traction sigma_i3 can be sampled.
+ !
+ ! 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.
+ !
+ ! 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.
+ !
+ ! 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.
+ !
+ ! 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
+ !
+ ! 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
+ !
+ ! 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:
+ !
+ ! x1
+ ! |
+ ! | ^ f2
+ ! | |<-----
+ ! +---+------+---- x2
+ ! ----->|
+ ! v f1
+ !
+ ! 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:
+ !
+ ! x1 f1
+ ! | ^^^^^^^
+ ! | |||||||
+ ! | -f2 <--+-------+--> f2
+ ! | |||||||
+ ! | vvvvvvv
+ ! | -f1
+ ! |
+ ! +----------------------------- x2
+ !
+ ! The eigenstrain/potency tensor for a point source is
+ !
+ ! | 1 0 0 |
+ ! E^i = | 0 0 0 |
+ ! | 0 0 0 |
+ !
+ ! and the corresponding moment density for a point source is
+ !
+ ! | lambda+2*mu 0 0 |
+ ! m = C : E^i = | 0 lambda 0 |
+ ! | 0 0 lambda |
+ !
+ ! Moment density 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. 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_i = - ( m_ij ),j
+ !
+ ! derivatives are performed analytically on the gaussian and
+ ! omega_beta functions.
+ !
+ ! 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
+ !
+ ! E^i = o 1/3 I delta(x-xs)
+ !
+ ! 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
+ !
+ ! m = C : E^i = K o I delta(x-xs)
+ !
+ ! The equivalent body-force density is
+ !
+ ! f = - Nabla . m = K o nabla delta(x-xs)
+ !
+ ! where nabla is the gradient operator. Default source opening is
+ ! represented with the isotropic equivalent body-force density:
+ !
+ ! x1
+ ! | f1
+ ! | ^
+ ! | f2 | f2
+ ! +---<--+-->---- x2
+ ! |
+ ! v f1
+ !
+ ! x3
+ ! | f3
+ ! | ^
+ ! | f2 | f2
+ ! +---<--+-->---- x2
+ ! |
+ ! v f3
+ !
+ ! 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
+
+ !---------------------------------------------------------------------
+ ! 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,
+ !
+ ! x1 ! x1
+ ! n theta | ! n phi |
+ ! \ ____| ! \ ____|
+ ! \ | ! \ |
+ ! \ | ! \ |
+ ! -----\+------ x2 ! -----\+------ x3
+ ! (x3 down) ! (x2 up)
+ !
+ ! where theta is the strike and phi is the dip (internal convention),
+ ! and introducting the rotation matrices
+ !
+ ! | 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) |
+ !
+ ! a normal vector n of arbitrary orientation and the corresponding
+ ! strike-slip and dip-slip vector, s and d respectively, are
+ !
+ ! | 1 | | 0 | | 0 |
+ ! n = R1 R2 | 0 |, s = R1 R2 | 1 |, d = R1 R2 | 0 |
+ ! | 0 | | 0 | | 1 |
+ !
+ ! 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.
+ !
+ ! 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
+ !
+ ! E^i_ij = 1/2 ( n_i s_j + s_i n_j )
+ !
+ ! The eigenstrain/potency tensor for a point source opening crack is
+ !
+ ! | 1 0 0 |
+ ! E^i = | 0 0 0 |
+ ! | 0 0 0 |
+
+ !
+ ! In a heterogeneous medium of elastic moduli tensor C_ijkl, the
+ ! corresponding moment density tensor is
+ !
+ ! m_ij = C_ijkl E^i_kl = lambda E^i_kk delta_ij + 2 mu E^i_ij
+ !
+ ! 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
+ !
+ ! | lambda+2*mu 0 0 |
+ ! m(x) = | 0 lambda 0 |
+ ! | 0 0 lambda |
+ !
+ ! 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_i = - ( m_ji ),j
+ !
+ ! The corresponding equivalent surface traction is simply
+ !
+ ! t_i = m_ij n_j
+ !
+ ! 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,
+ !
+ ! x1 ! x1
+ ! n theta | ! n phi |
+ ! \ ____| ! \ ____|
+ ! \ | ! \ |
+ ! \ | ! \ |
+ ! -----\+------ x2 ! -----\+------ x3
+ ! (x3 down) ! (x2 up)
+ !
+ ! 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,
+ !
+ ! | 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) |
+ !
+ ! a normal vector n of arbitrary orientation and the corresponding
+ ! slip vector s are
+ !
+ ! | 1 | | 1 |
+ ! n = R1 R2 | 0 |, s = n = R1 R2 | 0 |
+ ! | 0 | | 0 |
+ !
+ ! The method of images is used to avoid tapering of the fault at
+ ! the surface.
+ !
+ ! 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
+ !
+ ! E^i_ij = o 1/3 delta_ij
+ !
+ ! 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.
+ !
+ ! 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.
+ !
+ ! W
+ ! +-------------+
+ ! | |
+ ! L | + | - - - > along strike direction
+ ! | (x,y,z) |
+ ! +-------------|
+ ! |
+ ! v
+ ! down-dip direction
+ !
+ ! 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:
+ !
+ ! n x1 n x1
+ ! \ | \ |
+ ! \ | \ |
+ ! 90 - strike \ | 90 - dip \ |
+ ! ( \| ( \|
+ ! ----------+------ x2 ----------+------ x3
+ ! (x3 down) (x2 up)
+ !
+ ! edges of the rectangle are tapered.
+ !
+ ! 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 MonitorField
+ ! samples a scalar field along a specified planar surface.
+ !
+ ! 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
+
+ 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)
+
+ 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.
+ !
+ ! 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.
+ !
+ ! 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
+ !
+ ! 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 000000000000 -r 56a2cd733fb8 export.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/export.f90 Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,1620 @@
+!-----------------------------------------------------------------------
+! 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.
+ !
+ ! 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.
+ !
+ ! 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.
+ !
+ ! 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)
+ ! ...
+ !
+ ! sylvain barbot (11/10/07) - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportpoints(c1,c2,c3,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(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
+ 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")
+ 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)
+
+ ! 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,'(7ES11.3E2)') y1,y2,y3,time,v1,v2,v3
+ 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 exportEigenstrain
+ ! samples the value of an input scalar field at the location of
+ ! defined plane (position, strike, dip, length and width).
+ !
+ ! input variables
+ ! field - sampled scalar array
+ ! nop - number of observation planes
+ ! op - structure of observation planes (position, orientation)
+ ! x0, y0 - origin position of coordinate system
+ ! dx1,2,3 - sampling size
+ ! sx1,2,3 - size of the scalar field
+ ! wdir - output directory for writing
+ ! 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
+ !
+ ! 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
+#ifdef 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
+ ! np - number of frictional planes
+ ! n - array of frictional planes (position, orientation)
+ ! structure - array of depth-dependent frictional properties
+ ! x0, y0 - origin position of coordinate system
+ ! dx1,2,3 - sampling size
+ ! sx1,2,3 - size of the stress tensor field
+ ! beta - smoothing factor controlling the extent of planes
+ ! wdir - output directory for writing
+ ! 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.
+ !
+ ! sylvain barbot (01/01/07) - original form
+ ! (02/25/10) - output in TXT and GRD formats
+ !---------------------------------------------------------------------
+ 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,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,'(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.
+ !
+ ! 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.
+ !
+ ! 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
+ !
+ ! sylvain barbot 06/24/09 - original form
+ !------------------------------------------------------------------
+ SUBROUTINE exportvtk_grid(sx1,sx2,sx3,dx1,dx2,dx3,origx,origy,cgfilename)
+ INTEGER, INTENT(IN) :: sx1,sx2,sx3
+ REAL*8, INTENT(IN) :: dx1,dx2,dx3,origx,origy
+ 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, &
+ +sx1*dx1/2, -sx2*dx2/2, 0, &
+ +sx1*dx1/2, +sx2*dx2/2, 0, &
+ -sx1*dx1/2, +sx2*dx2/2, 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 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.
+ !
+ ! 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_Rectangle
+ ! creates a .vtp file (in the VTK PolyData XML format) containing
+ ! a rectangle.
+ !
+ ! 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 ExportVTK_Brick
+ ! creates a .vtp file (in the VTK PolyData XML format) containing
+ ! a brick (3d rectangle, cuboid).
+ !
+ ! 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.
+ !
+ ! 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
+ CHARACTER :: q
+ 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 x3=0,sx3-1,j3
+ DO x2=-sx2/2,sx2/2-1,j2
+ DO x1=-sx1/2,sx1/2-1,j1
+
+ 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,x3+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 x3=0,sx3-1,j3
+ DO x2=-sx2/2,sx2/2-1,j2
+ DO x1=-sx1/2,sx1/2-1,j1
+
+ 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,x3+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 x3=0,sx3-1,j3
+ DO x2=-sx2/2,sx2/2-1,j2
+ DO x1=-sx1/2,sx1/2-1,j1
+
+ 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,x3+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 x1=-sx1/2,sx1/2-1,j1
+ 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 x2=-sx2/2,sx2/2-1,j2
+ 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 x3=0,sx3-1,j3
+ 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.
+ !
+ ! 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
+ 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 x2=-sx2/2,sx2/2-1,j2
+ DO x1=-sx1/2,sx1/2-1,j1
+
+ 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,x3+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 x2=-sx2/2,sx2/2-1,j2
+ DO x1=-sx1/2,sx1/2-1,j1
+
+ 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,x3+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 x2=-sx2/2,sx2/2-1,j2
+ DO x1=-sx1/2,sx1/2-1,j1
+
+ 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,x3+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 x1=-sx1/2,sx1/2-1,j1
+ 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 x2=-sx2/2,sx2/2-1,j2
+ 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 000000000000 -r 56a2cd733fb8 fourier.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/fourier.f90 Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,586 @@
+!-----------------------------------------------------------------------
+! 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
+ ! i1 i3 running index in the discrete Fourier domain array
+ ! sx1 sx3 number of elements in the 2 directions
+ ! dx1 dx3 sampling interval in the 2 directions
+ !
+ ! OUTPUT
+ ! k1 k3 wavenumbers in the 2 direction
+ !
+ ! 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
+ !
+ ! 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)
+
+ WRITE_MKL_DEBUG_INFO(iret)
+
+ 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)
+ WRITE_MKL_DEBUG_INFO(iret)
+
+ 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)
+
+ WRITE_MKL_DEBUG_INFO(iret)
+
+ 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)
+ WRITE_MKL_DEBUG_INFO(iret)
+
+ 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
+ !
+ ! 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)
+ WRITE_MKL_DEBUG_INFO(iret)
+
+ 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)
+ WRITE_MKL_DEBUG_INFO(iret)
+
+ 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 000000000000 -r 56a2cd733fb8 friction3d.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/friction3d.f90 Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,538 @@
+!-----------------------------------------------------------------------
+! 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
+ ! 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 )
+ !
+ ! 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 = 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.
+ !
+ ! sylvain barbot (07/24/07) - original form
+ !-----------------------------------------------------------------
+ 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 )
+ !
+ ! 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 = 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.
+ !
+ ! sylvain barbot (07/24/07) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE frictioneigenstress(x,y,z,L,W,strike,dip,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,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
+ 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,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)
+
+ ! 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
+
+ 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=taus+friction*taun-cohesion
+
+ ! 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
+
+ ! yield surface test
+ IF ((0._8 .GE. taus) .OR. (tau .LE. 0._8)) CYCLE
+
+ ! 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:
+ ! x,y,z coordinates of the creeping segment
+ ! L dimension of segment in the depth direction
+ ! W dimension of segment in the strike direction
+ ! beta smoothing factor
+ ! sx1,2,3 dimension of the stress tensor array
+ ! dx1,2,3 sampling size
+ ! sig stress tensor array
+ ! structure frictional properties as a function of depth
+ !
+ ! output:
+ ! patch list of strike- and dip-slip as a function of position
+ ! on the fault.
+ !
+ ! sylvain barbot (10-16-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE monitorfriction(x,y,z,L,W,strike,dip,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,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,slip,ss,ds
+ 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
+
+ cstrike=cos(strike)
+ sstrike=sin(strike)
+ cdip=cos(dip)
+ sdip=sin(dip)
+
+ ! 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
+
+ ! 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)
+
+ ! 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
+ slip=0._8
+ ss=0._8
+ ds=0._8
+ ELSE
+ ! 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=taus+friction*taun-cohesion
+
+ ! yield surface test
+ IF ((0._8 .GE. taus) .OR. (tau .LE. 0._8)) THEN
+ ss=0;ds=0;slip=0;
+ ELSE
+ ! shear traction direction
+ ts=ts/taus
+
+ ! creep rate
+ slip=vo*2._8*sinh(tau/tauc)
+
+ ! strike-direction creep rate
+ ss=slip*SUM(ts*sv)
+
+ ! dip-direction creep rate
+ ds=slip*SUM(ts*dv)
+ END IF
+ END IF
+
+ ! gather absolute and relative position, total,
+ ! strike and dip slip in a single structure
+ patch(j2,j3)=SLIPPATCH_STRUCT(x1,x2,x3,yr,zr,slip,ss,ds)
+
+ 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 000000000000 -r 56a2cd733fb8 getdata.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/getdata.f Thu Jan 06 15:36:19 2011 -0800
@@ -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 000000000000 -r 56a2cd733fb8 green.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/green.f90 Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,1698 @@
+!-----------------------------------------------------------------------
+! 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"
+
+#ifdef MPI_IMP
+ INCLUDE 'mpif.h'
+ INCLUDE 'mpiparams.f90'
+#endif
+
+ 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:
+ ! mu shear modulus
+ ! f2 equivalent body-forces in the Fourier domain
+ ! sx1, sx3
+ !
+ ! sylvain barbot (04/14/07) - original form
+ ! (02/06/09) - parallel implementation with MPI and OpenMP
+ !------------------------------------------------------------------------
+ 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
+#ifdef MPI_IMP
+ INTEGER :: iostatus,maxbuffersize,buffersize,i3m,i3p,position
+ INTEGER, DIMENSION(128) :: displs,counts
+ INTEGER, PARAMETER :: psize=256
+ CHARACTER, DIMENSION(256) :: packed
+ REAL*4, ALLOCATABLE, DIMENSION(:,:,:) :: u1,u2,u3
+#endif
+
+ 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)
+
+#ifdef MPI_IMP
+
+ ! assign job to all threads
+ maxbuffersize=CEILING(REAL(sx3)/REAL(nthreads))
+
+ ! values for master thread
+ displs(1)=0
+ counts(1)=maxbuffersize*(sx1+2)*sx2
+
+ ! send computational parameters to dependent threads
+ DO islave=1,nslaves
+
+ ! declare intentions to dependent thread
+ CALL MPI_SEND(iflag_TellSlaveToRecv_ElasResp,1,MPI_INTEGER,islave,tag_MasterSendingData,mcomm,ierr)
+
+ ! computation bounds (slave-number dependent)
+ i3m=maxbuffersize*islave+1
+ IF (islave .NE. nslaves) THEN
+ i3p=maxbuffersize*(islave+1)
+ ELSE
+ i3p=sx3
+ END IF
+ buffersize=i3p-i3m+1
+ counts(islave+1)=buffersize*(sx1+2)*sx2
+ displs(islave+1)=displs(islave)+counts(islave)
+
+ position=0
+ ! send computation parameters
+ CALL MPI_PACK(sx1,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(sx2,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(sx3,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+
+ ! computation bounds
+ CALL MPI_PACK(i3m,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(i3p,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(buffersize,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+
+ ! elastic properties
+ CALL MPI_PACK(lambda,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(mu ,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+
+ ! grid sampling size
+ CALL MPI_PACK(dx1,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(dx2,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(dx3,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+
+ ! sending package
+ CALL MPI_SEND(packed,position,MPI_PACKED,islave,tag_MasterSendingData_ElasResp,mcomm,ierr)
+
+ END DO
+
+ ! special treatment for master thread (no new memory allocation)
+ counts(1)=0
+
+ ! sending to all threads (except master thread)
+ CALL MPI_SCATTERV(f1,counts,displs,MPI_REAL,u1,counts(1),MPI_REAL,master,mcomm,ierr)
+ CALL MPI_SCATTERV(f2,counts,displs,MPI_REAL,u2,counts(1),MPI_REAL,master,mcomm,ierr)
+ CALL MPI_SCATTERV(f3,counts,displs,MPI_REAL,u3,counts(1),MPI_REAL,master,mcomm,ierr)
+
+ ! setting computation limit for master thread
+ ubound3=maxbuffersize
+
+#else
+ ubound3=sx3
+#endif
+
+ ! 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
+
+#ifdef MPI_IMP
+
+ ! getting back computation results from all threads
+ CALL MPI_GATHERV(u1,counts(1),MPI_REAL,f1,counts,displs,MPI_REAL,master,mcomm,ierr)
+ CALL MPI_GATHERV(u2,counts(1),MPI_REAL,f2,counts,displs,MPI_REAL,master,mcomm,ierr)
+ CALL MPI_GATHERV(u3,counts(1),MPI_REAL,f3,counts,displs,MPI_REAL,master,mcomm,ierr)
+
+#endif
+
+ ! 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
+
+#ifdef MPI_IMP
+ !---------------------------------------------------------------------
+ ! subroutine ElasticResponseSlave
+ ! computes the core computation corresponding to serial routine
+ ! elasticresponse. implements the MPI standard.
+ !
+ ! sylvain barbot (02/05/09) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE elasticresponseslave(islave)
+ INTEGER, INTENT(IN) :: islave
+
+ REAL*8 :: k1,k2,k3,denom,r2,ratio1,ratio2,lambda,mu,dx1,dx2,dx3
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3,position,i3m,i3p,buffersize,ib,iostatus
+ COMPLEX(kind=8) :: buf1,buf2,buf3,c1,c2,c3
+ INTEGER, PARAMETER :: psize=256
+ CHARACTER, DIMENSION(256) :: packed
+ INTEGER, DIMENSION(18) :: counts,displs
+ REAL*4, ALLOCATABLE, DIMENSION(:,:,:) :: v1,v2,v3,temp
+
+ ! receive computation parameters
+ CALL MPI_RECV(packed,psize,MPI_PACKED,master,tag_MasterSendingData_ElasResp,mcomm,status,ierr)
+ position=0
+
+ ! retrieve variables from buffer
+ CALL MPI_UNPACK(packed,psize,position,sx1,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,sx2,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,sx3,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+
+ ! computational bounds
+ CALL MPI_UNPACK(packed,psize,position,i3m,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,i3p,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,buffersize,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+
+ ! elastic parameters
+ CALL MPI_UNPACK(packed,psize,position,lambda,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,mu ,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+
+ ! grid sampling-size
+ CALL MPI_UNPACK(packed,psize,position,dx1,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,dx2,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,dx3,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+
+ ALLOCATE(v1(sx1+2,sx2,buffersize),v2(sx1+2,sx2,buffersize),v3(sx1+2,sx2,buffersize),STAT=iostatus)
+ IF (iostatus /= 0) STOP 21
+
+ ! get data from master thread
+ CALL MPI_SCATTERV(temp,counts,displs,MPI_REAL,v1,(sx1+2)*sx2*buffersize,MPI_REAL,master,mcomm,ierr)
+ CALL MPI_SCATTERV(temp,counts,displs,MPI_REAL,v2,(sx1+2)*sx2*buffersize,MPI_REAL,master,mcomm,ierr)
+ CALL MPI_SCATTERV(temp,counts,displs,MPI_REAL,v3,(sx1+2)*sx2*buffersize,MPI_REAL,master,mcomm,ierr)
+
+ ! core computations
+ ratio1=(lambda+mu)/(lambda+2._8*mu)/mu/(pi2**2._8)
+ ratio2=mu/(lambda+mu)
+
+ ib=1
+ DO i3=i3m,i3m+buffersize-1
+ 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(v1(2*i1-1,i2,ib),v1(2*i1,i2,ib),8)
+ c2=CMPLX(v2(2*i1-1,i2,ib),v2(2*i1,i2,ib),8)
+ c3=CMPLX(v3(2*i1-1,i2,ib),v3(2*i1,i2,ib),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
+
+ v1(2*i1-1:2*i1,i2,ib)=REAL((/ REAL(buf1),AIMAG(buf1) /))
+ v2(2*i1-1:2*i1,i2,ib)=REAL((/ REAL(buf2),AIMAG(buf2) /))
+ v3(2*i1-1:2*i1,i2,ib)=REAL((/ REAL(buf3),AIMAG(buf3) /))
+ END DO
+ END DO
+ ib=ib+1
+ END DO
+
+ CALL MPI_GATHERV(v1,(sx1+2)*sx2*buffersize,MPI_REAL,temp,counts,displs,MPI_REAL,master,mcomm,ierr)
+ CALL MPI_GATHERV(v2,(sx1+2)*sx2*buffersize,MPI_REAL,temp,counts,displs,MPI_REAL,master,mcomm,ierr)
+ CALL MPI_GATHERV(v3,(sx1+2)*sx2*buffersize,MPI_REAL,temp,counts,displs,MPI_REAL,master,mcomm,ierr)
+
+ DEALLOCATE(v1,v2,v3)
+
+ END SUBROUTINE elasticresponseslave
+#endif
+
+ !---------------------------------------------------------------------
+ ! 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.
+ !
+ ! 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]
+ !
+ ! 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.
+ !
+ ! 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
+
+#ifdef MPI_IMP
+ INTEGER :: buffersize,maxbuffersize,iostatus,i3m,position
+ REAL*4, ALLOCATABLE, DIMENSION(:,:) :: temp
+ INTEGER, PARAMETER :: psize=256
+ CHARACTER, DIMENSION(256) :: packed
+#endif
+
+ sx1=SIZE(u1,1)-2
+ sx2=SIZE(u1,2)
+ sx3=SIZE(u1,3)
+
+#ifdef MPI_IMP
+
+ p1=0;p2=0;p3=0
+
+ ! temp is a buffer used by MPI_REDUCE
+ ALLOCATE(temp(sx1+2,sx2),STAT=iostatus)
+ IF (iostatus /= 0) STOP 15
+
+ ! assign job to all threads
+ maxbuffersize=CEILING(REAL(sx3)/REAL(nslaves))
+
+ DO islave=1,nslaves
+
+ ! declare intentions to dependent thread
+ CALL MPI_SEND(iflag_TellSlaveToRecv_SurfTrac,1,MPI_INTEGER,islave,tag_MasterSendingData,mcomm,ierr)
+
+ ! buffersize (slave-number dependent)
+ i3m=1+(islave-1)*maxbuffersize
+ IF (islave .NE. nslaves) THEN
+ buffersize=maxbuffersize
+ ELSE
+ buffersize=sx3-i3m+1
+ END IF
+
+ position=0
+
+ ! computation parameters
+ CALL MPI_PACK(sx1,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(sx2,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(sx3,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+
+ ! elastic parameters
+ CALL MPI_PACK(lambda,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(mu ,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+
+ ! sampling size
+ CALL MPI_PACK(dx1,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(dx2,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(dx3,1,MPI_REAL8,packed,psize,position,mcomm,ierr)
+
+ ! start index of buffer
+ CALL MPI_PACK(i3m,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+ CALL MPI_PACK(buffersize,1,MPI_INTEGER,packed,psize,position,mcomm,ierr)
+
+ ! sending package
+ CALL MPI_SEND(packed,position,MPI_PACKED,islave,tag_MasterSendingData_SurfTrac,mcomm,ierr)
+
+ ! sub arrays
+ CALL MPI_SEND(u1(:,:,i3m),(sx1+2)*sx2*buffersize,MPI_REAL,islave,tag_MasterSendingData_SurfTrac,mcomm,ierr)
+ CALL MPI_SEND(u2(:,:,i3m),(sx1+2)*sx2*buffersize,MPI_REAL,islave,tag_MasterSendingData_SurfTrac,mcomm,ierr)
+ CALL MPI_SEND(u3(:,:,i3m),(sx1+2)*sx2*buffersize,MPI_REAL,islave,tag_MasterSendingData_SurfTrac,mcomm,ierr)
+
+ END DO
+
+ ! cascade results down to master
+ CALL MPI_REDUCE(temp,p1,(sx1+2)*sx2,MPI_REAL,MPI_SUM,master,MPI_COMM_WORLD,ierr)
+ CALL MPI_REDUCE(temp,p2,(sx1+2)*sx2,MPI_REAL,MPI_SUM,master,MPI_COMM_WORLD,ierr)
+ CALL MPI_REDUCE(temp,p3,(sx1+2)*sx2,MPI_REAL,MPI_SUM,master,MPI_COMM_WORLD,ierr)
+
+ DEALLOCATE(temp)
+
+#else
+
+ 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)
+
+#endif
+
+ END SUBROUTINE surfacetraction
+
+#ifdef MPI_IMP
+
+ !---------------------------------------------------------------------
+ ! subroutine SurfaceTractionSlave
+ ! compute the stress in the Fourier domain for master thread.
+ !
+ ! sylvain barbot (02/04/09) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE surfacetractionslave(islave)
+ INTEGER, INTENT(IN) :: islave
+
+ REAL*8 :: modulus,lambda,mu,dx1,dx2,dx3,k1,k2,k3
+ INTEGER :: i1,i2,i3,sx1,sx2,sx3,i3m,iostatus,ib,buffersize,position
+ COMPLEX(KIND=8), PARAMETER :: i=CMPLX(0._8,pi2,8)
+ COMPLEX(KIND=8) :: sum1,sum2,sum3,c1,c2,c3
+ REAL*4, ALLOCATABLE, DIMENSION(:,:) :: p1,p2,p3,temp
+ REAL*4, ALLOCATABLE, DIMENSION(:,:,:) :: u1,u2,u3
+ INTEGER, PARAMETER :: psize=256
+ CHARACTER, DIMENSION(256) :: packed
+
+ ! receive computation parameters
+ CALL MPI_RECV(packed,psize,MPI_PACKED,master,tag_MasterSendingData_SurfTrac,mcomm,status,ierr)
+ position=0
+
+ ! grid dimension
+ CALL MPI_UNPACK(packed,psize,position,sx1,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,sx2,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,sx3,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+
+ ! elastic parameters
+ CALL MPI_UNPACK(packed,psize,position,lambda,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,mu ,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+
+ ! sampling size
+ CALL MPI_UNPACK(packed,psize,position,dx1,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,dx2,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,dx3,1,MPI_REAL8,MPI_COMM_WORLD,ierr)
+
+ ! start index of buffer
+ CALL MPI_UNPACK(packed,psize,position,i3m,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+ CALL MPI_UNPACK(packed,psize,position,buffersize,1,MPI_INTEGER,MPI_COMM_WORLD,ierr)
+
+ ALLOCATE(u1(sx1+2,sx2,buffersize),u2(sx1+2,sx2,buffersize),u3(sx1+2,sx2,buffersize), &
+ p1(sx1+2,sx2),p2(sx1+2,sx2),p3(sx1+2,sx2),STAT=iostatus)
+ IF (iostatus /= 0) STOP 18
+
+ ! sub arrays
+ CALL MPI_RECV(u1,(sx1+2)*sx2*buffersize,MPI_REAL,master,tag_MasterSendingData_SurfTrac,mcomm,status,ierr)
+ CALL MPI_RECV(u2,(sx1+2)*sx2*buffersize,MPI_REAL,master,tag_MasterSendingData_SurfTrac,mcomm,status,ierr)
+ CALL MPI_RECV(u3,(sx1+2)*sx2*buffersize,MPI_REAL,master,tag_MasterSendingData_SurfTrac,mcomm,status,ierr)
+
+ modulus=lambda+2._8*mu
+
+ p1=0;p2=0;p3=0
+ ib=1;
+ DO i3=i3m,i3m+buffersize-1
+ 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,ib),u1(2*i1,i2,ib),8)
+ c2=CMPLX(u2(2*i1-1,i2,ib),u2(2*i1,i2,ib),8)
+ c3=CMPLX(u3(2*i1-1,i2,ib),u3(2*i1,i2,ib),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
+ ! update the local counter for buffer array
+ ib=ib+1
+ END DO
+
+ DEALLOCATE(u1,u2,u3)
+
+ p1=p1/(sx3*dx3)
+ p2=p2/(sx3*dx3)
+ p3=p3/(sx3*dx3)
+
+ ! cascade results to master thread
+ CALL MPI_REDUCE(p1,temp,(sx1+2)*sx2,MPI_REAL,MPI_SUM,master,MPI_COMM_WORLD,ierr)
+ CALL MPI_REDUCE(p2,temp,(sx1+2)*sx2,MPI_REAL,MPI_SUM,master,MPI_COMM_WORLD,ierr)
+ CALL MPI_REDUCE(p3,temp,(sx1+2)*sx2,MPI_REAL,MPI_SUM,master,MPI_COMM_WORLD,ierr)
+
+ DEALLOCATE(p1,p2,p3)
+
+ END SUBROUTINE surfacetractionslave
+
+#endif
+
+ !---------------------------------------------------------------------
+ ! 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
+ !
+ ! 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.
+ !
+ ! sylvain barbot (07/07/07) - original form
+ ! (02/01/09) - parallelized with MPI and OpenMP
+ !---------------------------------------------------------------------
+ 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
+#ifdef MPI_IMP
+ LOGICAL :: lflag
+ INTEGER :: i2m,i2p,index=1
+#else
+ COMPLEX(KIND=4) :: t1,t2,t3
+ INTEGER, PARAMETER :: stride=64
+#endif
+ 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)
+
+#ifdef MPI_IMP
+
+ nslaves = nthreads-1
+
+ ALLOCATE(b1(sx3,buffercerruti),b2(sx3,buffercerruti),b3(sx3,buffercerruti),STAT=iostatus)
+ IF (0/=iostatus) STOP "could not allocate arrays for Cerruti3D"
+
+ ! assign job to all threads
+ DO islave=1,nslaves
+ ! declare intentions to dependent thread
+ CALL MPI_SEND(iflag_TellSlaveToRecv_Cerruti3d,1,MPI_INTEGER,islave,tag_MasterSendingData,mcomm,ierr)
+
+ ! send computation parameters
+ CALL MPI_SEND(mu ,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(sx1 ,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(sx2 ,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(sx3 ,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(dx1 ,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(dx2 ,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(dx3 ,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(alpha,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+
+ ! computation bounds (slave-number dependent)
+ IF (islave .NE. nslaves) THEN
+ i2m=CEILING(REAL(sx2)/REAL(nslaves))*(islave-1)+1
+ i2p=CEILING(REAL(sx2)/REAL(nslaves))*islave
+ ELSE
+ i2m=CEILING(REAL(sx2)/REAL(nslaves))*(islave-1)+1
+ i2p=sx2
+ END IF
+
+ ! send computation bounds
+ CALL MPI_SEND(i2m,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(i2p,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+
+ ! send surface traction to all dependent threads
+ CALL MPI_SEND(p1,(sx1/2+1)*sx2,MPI_COMPLEX,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(p2,(sx1/2+1)*sx2,MPI_COMPLEX,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(p3,(sx1/2+1)*sx2,MPI_COMPLEX,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+
+ END DO
+
+ ! listen for results from threads
+ DO
+ ! exit if all points have been processed
+ IF (index .GT. (sx2 * (sx1/2+1))) EXIT
+
+ status=0
+ ! check for a message from any slave without data transfer
+ CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG,MPI_COMM_WORLD,lflag,status,ierr)
+
+ ! if message from thread, receive computation results
+ IF (lflag) THEN
+
+ ! find thread source
+ islave = status(MPI_SOURCE)
+
+ ! check intentions of sender
+ IF (status(MPI_TAG) == tag_SlaveSendingData_Cerruti3d) THEN
+
+ ! receive computation results from slave thread
+ CALL MPI_RECV(i1,1,MPI_INTEGER,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(i2,1,MPI_INTEGER,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+
+ CALL MPI_RECV(buffersize,1,MPI_INTEGER,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(b1,sx3*buffersize,MPI_COMPLEX,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(b2,sx3*buffersize,MPI_COMPLEX,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(b3,sx3*buffersize,MPI_COMPLEX,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+
+ IF (buffersize .GT. buffercerruti) THEN
+ ! incorrect buffersize
+ PRINT *, "buffersize", buffersize,"exceeds upper limit",buffercerruti
+ END IF
+
+ ! update solution displacement
+ DO ib=0,buffersize-1
+ DO i3=1,sx3
+ 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
+
+ ! count number of returned results
+ index=index+buffersize
+
+ ENDIF
+
+ ENDIF ! lflag
+
+ END DO
+
+ DEALLOCATE(b1,b2,b3)
+
+#else
+ ! 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
+
+#endif
+#ifdef MPI_IMP
+ END SUBROUTINE cerruti3d
+
+ !---------------------------------------------------------------------------
+ ! subroutine Cerruti3dSlave
+ ! performs the core of the serial Cerruti3d routine. called only
+ ! by dependent threads.
+ !
+ ! sylvain barbot (01/31/09) - original form
+ !---------------------------------------------------------------------------
+ SUBROUTINE cerruti3dslave(islave)
+ INTEGER, INTENT(IN) :: islave
+
+ INTEGER :: i1,i2,i2m,i2p,i3,ib,sx1,sx2,sx3,iostatus,buffersize
+ REAL*8 :: k1,k2,k3,x3,alpha,dx1,dx2,dx3,mu
+ COMPLEX(KIND=4), ALLOCATABLE, DIMENSION(:,:) :: b1,b2,b3
+ REAL*4, ALLOCATABLE, DIMENSION(:,:) :: p1,p2,p3
+ COMPLEX(KIND=4) :: t1,t2,t3
+
+ ! receive computation parameters
+ CALL MPI_RECV(mu ,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(sx1 ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(sx2 ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(sx3 ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(dx1 ,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(dx2 ,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(dx3 ,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(alpha,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+
+ ! receive computation bounds
+ CALL MPI_RECV(i2m ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(i2p ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+
+ ! receive surface traction (in Fourier domain)
+ ALLOCATE(p1(sx1+2,sx2),p2(sx1+2,sx2),p3(sx1+2,sx2),STAT=iostatus)
+ IF (0/=iostatus) STOP "could not allocate arrays for incoming transferts (Cerruti3dSlave)."
+
+ CALL MPI_RECV(p1,(sx1+2)*sx2,MPI_REAL,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(p2,(sx1+2)*sx2,MPI_REAL,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(p3,(sx1+2)*sx2,MPI_REAL,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+
+ ! start computation
+ ALLOCATE(b1(sx3,buffercerruti),b2(sx3,buffercerruti),b3(sx3,buffercerruti),STAT=iostatus)
+ IF (0/=iostatus) STOP "could not allocate buffers for computation (Cerruti3dSlave)"
+
+ DO i2=i2m,i2p
+ DO i1=1,sx1/2+1,buffercerruti
+
+ ! buffer results
+ IF (i1+buffercerruti-1 .GT. sx1/2+1) THEN
+ buffersize=sx1/2+1-i1+1
+ ELSE
+ buffersize=buffercerruti
+ 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
+
+ ! send the Cerruti's contribution to the master thread
+ CALL MPI_SEND(i1,1,MPI_INTEGER,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(i2,1,MPI_INTEGER,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+
+ ! tell the buffersize before sending
+ CALL MPI_SEND(buffersize,1,MPI_INTEGER,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(b1,sx3*buffersize,MPI_COMPLEX,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(b2,sx3*buffersize,MPI_COMPLEX,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(b3,sx3*buffersize,MPI_COMPLEX,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+
+ END DO
+ END DO
+
+ DEALLOCATE(b1,b2,b3,p1,p2,p3)
+
+#endif
+ 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.
+ !
+ ! 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
+#ifdef MPI_IMP
+ END SUBROUTINE cerruti3dslave
+#else
+ END SUBROUTINE cerruti3d
+#endif
+
+ !---------------------------------------------------------------------
+ ! subroutine CerrutiCowling
+ ! computes the deformation field in the 3-dimensional grid
+ ! due to an arbitrary surface traction.
+ !
+ ! sylvain barbot - 07/07/07 - original form
+ ! 21/11/08 - gravity effect
+ ! 02/01/09 - parallelized with MPI and OpenMP
+ !---------------------------------------------------------------------
+ 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
+#ifdef MPI_IMP
+ LOGICAL :: lflag
+ INTEGER :: i2m,i2p,index=1
+#else
+ COMPLEX(KIND=4) :: t1,t2,t3
+ INTEGER, PARAMETER :: stride=64
+#endif
+ 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)
+
+#ifdef MPI_IMP
+
+ nslaves = nthreads-1
+
+ ALLOCATE(b1(sx3,buffercerruti),b2(sx3,buffercerruti),b3(sx3,buffercerruti),STAT=iostatus)
+ IF (0/=iostatus) STOP "could not allocate arrays for Cerruti3D"
+
+ ! assign job to all threads
+ DO islave=1,nslaves
+ ! declare intentions to dependent thread
+ CALL MPI_SEND(iflag_TellSlaveToRecv_Cerruti3d,1,MPI_INTEGER,islave,tag_MasterSendingData,mcomm,ierr)
+
+ ! send computation parameters
+ CALL MPI_SEND(mu ,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(sx1 ,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(sx2 ,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(sx3 ,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(dx1 ,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(dx2 ,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(dx3 ,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(alpha,1,MPI_REAL8 ,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+
+ ! computation bounds (slave-number dependent)
+ IF (islave .NE. nslaves) THEN
+ i2m=CEILING(REAL(sx2)/REAL(nslaves))*(islave-1)+1
+ i2p=CEILING(REAL(sx2)/REAL(nslaves))*islave
+ ELSE
+ i2m=CEILING(REAL(sx2)/REAL(nslaves))*(islave-1)+1
+ i2p=sx2
+ END IF
+
+ ! send computation bounds
+ CALL MPI_SEND(i2m,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(i2p,1,MPI_INTEGER,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+
+ ! send surface traction to all dependent threads
+ CALL MPI_SEND(p1,(sx1/2+1)*sx2,MPI_COMPLEX,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(p2,(sx1/2+1)*sx2,MPI_COMPLEX,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(p3,(sx1/2+1)*sx2,MPI_COMPLEX,islave,tag_MasterSendingData_Cerruti3d,mcomm,ierr)
+
+ END DO
+
+ ! listen for results from threads
+ DO
+ ! exit if all points have been processed
+ IF (index .GT. (sx2 * (sx1/2+1))) EXIT
+
+ status=0
+ ! check for a message from any slave without data transfer
+ CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG,MPI_COMM_WORLD,lflag,status,ierr)
+
+ ! if message from thread, receive computation results
+ IF (lflag) THEN
+
+ ! find thread source
+ islave = status(MPI_SOURCE)
+
+ ! check intentions of sender
+ IF (status(MPI_TAG) == tag_SlaveSendingData_Cerruti3d) THEN
+
+ ! receive computation results from slave thread
+ CALL MPI_RECV(i1,1,MPI_INTEGER,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(i2,1,MPI_INTEGER,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+
+ CALL MPI_RECV(buffersize,1,MPI_INTEGER,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(b1,sx3*buffersize,MPI_COMPLEX,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(b2,sx3*buffersize,MPI_COMPLEX,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(b3,sx3*buffersize,MPI_COMPLEX,islave,tag_SlaveSendingData_Cerruti3d,mcomm,status,ierr)
+
+ IF (buffersize .GT. buffercerruti) THEN
+ ! incorrect buffersize
+ PRINT *, "buffersize", buffersize,"exceeds upper limit",buffercerruti
+ END IF
+
+ ! update solution displacement
+ DO ib=0,buffersize-1
+ DO i3=1,sx3
+ 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
+
+ ! count number of returned results
+ index=index+buffersize
+
+ ENDIF
+
+ ENDIF ! lflag
+
+ END DO
+
+ DEALLOCATE(b1,b2,b3)
+
+#else
+ ! 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
+
+#endif
+#ifdef MPI_IMP
+ END SUBROUTINE cerruticowling
+
+ !---------------------------------------------------------------------------
+ ! subroutine CerrutiCowlingSlave
+ ! performs the core of the serial Cerruti3d routine. called only
+ ! by dependent threads.
+ !
+ ! sylvain barbot (01/31/09) - original form
+ !---------------------------------------------------------------------------
+ SUBROUTINE cerruticowlingslave(islave)
+ INTEGER, INTENT(IN) :: islave
+
+ INTEGER :: i1,i2,i2m,i2p,i3,ib,sx1,sx2,sx3,iostatus,buffersize
+ REAL*8 :: k1,k2,k3,x3,alpha,dx1,dx2,dx3,mu
+ COMPLEX(KIND=4), ALLOCATABLE, DIMENSION(:,:) :: b1,b2,b3
+ REAL*4, ALLOCATABLE, DIMENSION(:,:) :: p1,p2,p3
+ COMPLEX(KIND=4) :: t1,t2,t3
+
+ ! receive computation parameters
+ CALL MPI_RECV(mu ,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(sx1 ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(sx2 ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(sx3 ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(dx1 ,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(dx2 ,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(dx3 ,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(alpha,1,MPI_REAL8 ,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+
+ ! receive computation bounds
+ CALL MPI_RECV(i2m ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(i2p ,1,MPI_INTEGER,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+
+ ! receive surface traction (in Fourier domain)
+ ALLOCATE(p1(sx1+2,sx2),p2(sx1+2,sx2),p3(sx1+2,sx2),STAT=iostatus)
+ IF (0/=iostatus) STOP "could not allocate arrays for incoming transferts (Cerruti3dSlave)."
+
+ CALL MPI_RECV(p1,(sx1+2)*sx2,MPI_REAL,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(p2,(sx1+2)*sx2,MPI_REAL,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+ CALL MPI_RECV(p3,(sx1+2)*sx2,MPI_REAL,master,tag_MasterSendingData_Cerruti3d,mcomm,status,ierr)
+
+ ! start computation
+ ALLOCATE(b1(sx3,buffercerruti),b2(sx3,buffercerruti),b3(sx3,buffercerruti),STAT=iostatus)
+ IF (0/=iostatus) STOP "could not allocate buffers for computation (Cerruti3dSlave)"
+
+ DO i2=i2m,i2p
+ DO i1=1,sx1/2+1,buffercerruti
+
+ ! buffer results
+ IF (i1+buffercerruti-1 .GT. sx1/2+1) THEN
+ buffersize=sx1/2+1-i1+1
+ ELSE
+ buffersize=buffercerruti
+ 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
+
+ ! send the Cerruti's contribution to the master thread
+ CALL MPI_SEND(i1,1,MPI_INTEGER,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(i2,1,MPI_INTEGER,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+
+ ! tell the buffersize before sending
+ CALL MPI_SEND(buffersize,1,MPI_INTEGER,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(b1,sx3*buffersize,MPI_COMPLEX,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(b2,sx3*buffersize,MPI_COMPLEX,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+ CALL MPI_SEND(b3,sx3*buffersize,MPI_COMPLEX,master,tag_SlaveSendingData_Cerruti3d,mcomm,ierr)
+
+ END DO
+ END DO
+
+ DEALLOCATE(b1,b2,b3,p1,p2,p3)
+
+#endif
+ 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
+#ifdef MPI_IMP
+ END SUBROUTINE cerruticowlingslave
+#else
+ END SUBROUTINE cerruticowling
+#endif
+
+ !---------------------------------------------------------------------
+ ! 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:
+ ! . c1,c2,c3 is a set of body forces
+ ! . dx1,dx2,dx3 are the sampling size
+ ! . lambda,mu are the Lame elastic parameters
+ ! . 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 000000000000 -r 56a2cd733fb8 include.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/include.f90 Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,66 @@
+
+! implement the Intel Math Kernel Library
+#define IMKL_FFT
+
+! implement the Fastest Fourier Transform of the West, version 3
+!#define FFTW3 1
+! use multithreaded libraries
+!#define FFTW3_THREADS 1
+
+! 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 000000000000 -r 56a2cd733fb8 kernel1.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/kernel1.inc Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,3 @@
+ ! centered finite difference scheme
+ REAL*8, PARAMETER, DIMENSION(1) :: &
+ fir1= (/ 5.000e-01 /) ! filter kernel
diff -r 000000000000 -r 56a2cd733fb8 kernel11.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/kernel11.inc Thu Jan 06 15:36:19 2011 -0800
@@ -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 000000000000 -r 56a2cd733fb8 kernel14.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/kernel14.inc Thu Jan 06 15:36:19 2011 -0800
@@ -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 000000000000 -r 56a2cd733fb8 kernel14bis.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/kernel14bis.inc Thu Jan 06 15:36:19 2011 -0800
@@ -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 000000000000 -r 56a2cd733fb8 kernel7.inc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/kernel7.inc Thu Jan 06 15:36:19 2011 -0800
@@ -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 000000000000 -r 56a2cd733fb8 makefile
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/makefile Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,1 @@
+makefile_imkl
\ No newline at end of file
diff -r 000000000000 -r 56a2cd733fb8 makefile_fftw
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/makefile_fftw Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,29 @@
+
+LIBPATH=-L/sw/lib
+INCPATH=-I/sw/include
+
+LIBS=-lgmt -lnetcdf -lfftw3f_threads -lfftw3f -lm -lpthread
+
+CC=cc
+F77=ifort
+FC=ifort -openmp
+
+FFLAGS=-cpp $(INCPATH) -zero -warn all
+F77FLAGS=-zero
+CFLAGS=-I/sw/include
+
+OBJ = include.f90 ctfft.o fourier.o green.o elastic3d.o friction3d.o viscoelastic3d.o writegrd4.2.o export.o getdata.o relax.o
+
+%.o : %.c
+ $(CC) $(CFLAGS) -c $^
+
+%.o : %.f
+ $(F77) $(F77FLAGS) -c $^
+
+%.o : %.f90
+ $(FC) $(FFLAGS) -c $^
+
+relax: $(OBJ)
+ $(FC) $(FFLAGS) $(CDF) $(GMT) -o $@ $^ $(LIBPATH) $(LIBS)
+
+include clean.mk
diff -r 000000000000 -r 56a2cd733fb8 makefile_fourt
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/makefile_fourt Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,28 @@
+
+GMT=/sw/lib/libgmt.a
+CDF=/sw/lib/libnetcdf.3.dylib
+GCC=/usr/lib/gcc/powerpc-apple-darwin8/4.0.0/libgcc.a
+
+F77=ifort
+FC=ifort
+#FC=g95 -cpp
+#F77=g95 -O5
+
+FFLAGS=-O3
+CFLAGS=
+
+OBJ = fourt.o fourier.o green.o elastic3d.o friction3d.o writegrd4.2.o viscoelastic3d.o export.o getdata.o relax.o
+
+%.o : %.c
+ $(CC) $(CFLAGS) -c $^
+
+%.o : %.f
+ $(F77) -c $^
+
+%.o : %.f90
+ $(FC) $(FFLAGS) -c $^
+
+relax: $(OBJ)
+ $(FC) $(FFLAGS) $(CDF) $(GMT) -o $@ $^
+
+include clean.mk
diff -r 000000000000 -r 56a2cd733fb8 makefile_imkl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/makefile_imkl Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,39 @@
+# Makefile including the Intel Math Kernel Library (MKL) FFT and OpenMP parallelization.
+# Successful loading of libraries at runtime upon initialization of environment variable
+#
+# export DYLD_LIBRARY_PATH="/opt/intel/Compiler/11.1/084/lib:$DYLD_LIBRARY_PATH"
+#
+# in bash_profile or equivalent. Check out the Intel link advisor online
+#
+# http://software.intel.com/en-us/articles/intel-mkl-link-line-advisor/
+#
+# to fit with your environment.
+
+LIBPATH=-L/sw/lib -L/opt/intel/Compiler/11.1/084/Frameworks/mkl/lib/em64t/ -L/opt/intel/Compiler/11.1/084/lib/
+INCPATH=-I/sw/include -I/opt/intel/Compiler/11.1/084/Frameworks/mkl/include
+
+LIBS=-lproj -lgmt -lnetcdf -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core -openmp -lpthread
+
+CC=cc
+F77=ifort
+FC=ifort -openmp
+
+FFLAGS=-cpp $(INCPATH) -zero -warn all
+F77FLAGS=-zero
+CFLAGS=-I/sw/include
+
+OBJ = mkl_dfti.o fourier.o green.o elastic3d.o friction3d.o viscoelastic3d.o writegrd4.2.o proj.o export.o getdata.o relax.o
+
+%.o : %.c
+ $(CC) $(CFLAGS) -c $^
+
+%.o : %.f
+ $(F77) $(F77FLAGS) -c $^
+
+%.o : %.f90 include.f90
+ $(FC) $(FFLAGS) -c $(filter-out include.f90,$^)
+
+relax: $(OBJ)
+ $(FC) $(FFLAGS) -o $@ $(filter-out include.f90,$^) $(LIBPATH) $(LIBS)
+
+include clean.mk
diff -r 000000000000 -r 56a2cd733fb8 makefile_sgfft
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/makefile_sgfft Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,31 @@
+
+GMTLIB=-L/usr/local/gmt/lib -lgmt
+CDFLIB=-L/usr/local/lib -lnetcdf
+GCCLIB=-L/sio_raid2/gcc/gcc-4.1.0/gcc -lgcc
+SCSLIB=-L/usr/lib -lscs_mp
+
+FFLAGS=-i-static -O3 -zero -warn all
+CFLAGS=-I/sw/include
+OPENMP=-openmp
+LINK=-Wl,--allow-multiple-definition
+
+FC=ifort
+F77=ifort
+CC=cc
+
+OBJ = fourier.o green.o elastic3d.o friction3d.o viscoelastic3d.o writegrd4.2.o export.o getdata.o relax.o
+
+%.o : %.c
+ $(CC) $(CFLAGS) -c $^
+
+%.o : %.f
+ $(F77) $(OPENMP) $(FFLAGS) $(SCSLIB) -c $^
+
+%.o : %.f90
+ $(FC) $(SCSLIB) $(OPENMP) $(FFLAGS) -fpp -c $^
+
+relax: $(OBJ)
+ $(FC) $(LINK) $(FFLAGS) $(OPENMP) $^ $(GMTLIB) $(CDFLIB) $(GCCLIB) $(SCSLIB) -o $@
+
+include clean.mk
+
diff -r 000000000000 -r 56a2cd733fb8 mkl_dfti.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/mkl_dfti.f90 Thu Jan 06 15:36:19 2011 -0800
@@ -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 000000000000 -r 56a2cd733fb8 proj.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/proj.c Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,62 @@
+#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
+ *
+ * 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 000000000000 -r 56a2cd733fb8 relax.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/relax.f90 Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,2018 @@
+!-----------------------------------------------------------------------
+! 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/>.
+!-----------------------------------------------------------------------
+
+PROGRAM relax
+ !-----------------------------------------------------------------------
+ ! 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.
+ !
+ ! 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.
+ !
+ ! METHOD:
+ ! The current implementation is organized to integrate stress/strain-
+ ! rate constitutive laws (rheologies) of the form
+ !
+ ! epsilon^dot = f(sigma)
+ !
+ ! 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:
+ !
+ ! 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)
+ !
+ ! 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.
+ !
+ ! 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:
+ !
+ ! N (x1)
+ ! /
+ ! /| Strike
+ ! Pos:-> @------------------------ (x2)
+ ! |\ p . \ W
+ ! :-\ i . \ i
+ ! | \ l . \ d
+ ! :90 \ S . \ t
+ ! |-Dip\ . \ h
+ ! : \. | Rake \
+ ! | -------------------------
+ ! : L e n g t h
+ ! Z (x3)
+ !
+ ! Dislocations are converted to double-couple equivalent body-force
+ ! analytically. Solution displacement is obtained by application of
+ ! the Greens functions in the Fourier domain.
+ !
+ ! 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.
+ !
+ ! 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:
+ ! sylvain barbot (07-06-07) - original form
+ ! (08-28-08) - FFTW/SGI_FFT support, FIR derivatives,
+ ! Runge-Kutta integration, tensile cracks,
+ ! GMT output, comments in input file
+ ! (10-24-08) - interseismic loading, postseismic signal
+ ! output in separate files
+ ! (12-08-09) - slip distribution smoothing
+ ! (05-05-10) - lateral variations in viscous properties
+ ! Intel MKL implementation of the FFT
+ ! (06-04-10) - output in geographic coordinates
+ ! and output components of stress tensor
+ ! (07-19-10) - includes surface tractions initial condition
+ ! output geometry in VTK format for Paraview
+ !-----------------------------------------------------------------------
+
+ USE green
+ USE elastic3d
+ USE viscoelastic3d
+ USE friction3d
+ USE export
+
+#include "include.f90"
+
+ IMPLICIT NONE
+
+ REAL*8, PARAMETER :: DEG2RAD = 0.01745329251994329547437168059786927_8
+ INTEGER, PARAMETER :: ITERATION_MAX = 900
+ REAL*8, PARAMETER :: STEP_MAX = 1e7
+
+ INTEGER :: i,k,sx1,sx2,sx3,e,ne,nv,np,nop,npl,nps,oi,nfc, &
+ unit,iostatus,iargc,npts,skip=0,mech(3),nlwz,nnlwz
+#ifdef FFTW3_THREADS
+ INTEGER :: iret
+!$ INTEGER :: omp_get_max_threads
+#endif
+ REAL*8 :: beta,lambda,mu,gam,x0,y0,interval, &
+ minlength,minwidth,rot,maxwell(3),nyquist
+#ifdef PROJ
+ REAL*8 :: lon0,lat0,umult
+ INTEGER :: zone
+#endif
+ CHARACTER(80) :: wdir,reporttimefilename,reportfilename, &
+ inputfile,logfilename,inputfilename
+#ifdef VTK
+ INTEGER :: j
+ CHARACTER(80) :: rffilename,vcfilename,cgfilename
+ CHARACTER(3) :: digit
+#endif
+ REAL*8 :: dx1,dx2,dx3,oz,ozs,t,Dt,tm,odt
+ ! coseismic events
+ TYPE(EVENT_STRUC), DIMENSION(:), ALLOCATABLE :: events
+ TYPE(EVENT_STRUC) :: inter
+
+ ! input dislocation (shear and tensile cracks)
+ TYPE(PLANE_STRUCT), DIMENSION(:), ALLOCATABLE :: n, op
+ TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: linearlayer,nonlinearlayer
+ TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: faultcreeplayer
+ TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: linearstruc,nonlinearstruc
+ TYPE(LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: faultcreepstruc
+ TYPE(TENSOR_LAYER_STRUCT), DIMENSION(:), ALLOCATABLE :: stresslayer,stressstruc
+ TYPE(WEAK_STRUCT), DIMENSION(:), ALLOCATABLE :: linearweakzone,linearweakzonec, &
+ nonlinearweakzone,nonlinearweakzonec
+
+ ! arrays
+ REAL*4, DIMENSION(:,:,:), ALLOCATABLE :: v1,v2,v3,u1,u2,u3,gamma
+ REAL*4, DIMENSION(:,:), ALLOCATABLE :: t1,t2,t3
+ REAL*4, DIMENSION(:,:,:), ALLOCATABLE :: inter1,inter2,inter3
+ TYPE(TENSOR), DIMENSION(:,:,:), ALLOCATABLE :: tau,sig,moment
+ TYPE(VECTOR_STRUCT), DIMENSION(:), ALLOCATABLE :: opts
+ CHARACTER(LEN=4), DIMENSION(:), ALLOCATABLE :: ptsname
+ REAL*4, DIMENSION(:), ALLOCATABLE :: depthmask
+
+#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
+
+#ifdef MPI_IMP
+
+ ! initialize MPI:
+ CALL MPI_INIT(ierr)
+ CALL MPI_COMM_RANK(MPI_COMM_WORLD,threadid,ierr)
+ CALL MPI_COMM_SIZE(MPI_COMM_WORLD,nthreads,ierr)
+
+ ! next instructions for master thread only
+ IF (threadid .EQ. 0) THEN
+ nslaves=nthreads-1
+ status=0
+
+#endif
+
+ ! read standard input or filename given in argument
+ IF (0 .EQ. iargc()) THEN
+ ! standard input
+ unit=5
+ ELSE
+ ! open input file
+ CALL getarg(1,inputfile)
+
+ OPEN (UNIT=15,FILE=inputfile,IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus .GT. 0) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("unable to access input file ",a)') inputfile
+ STOP 1
+ END IF
+ ! input file
+ unit=15
+ END IF
+
+ CALL init(UNIT=unit)
+
+ ! close input file
+ IF (iargc() .GT. 0) CLOSE(15)
+
+ ALLOCATE (v1(sx1+2,sx2,sx3),v2(sx1+2,sx2,sx3),v3(sx1+2,sx2,sx3), &
+ u1(sx1+2,sx2,sx3/2),u2(sx1+2,sx2,sx3/2),u3(sx1+2,sx2,sx3/2), &
+ inter1(sx1+2,sx2,2),inter2(sx1+2,sx2,2),inter3(sx1+2,sx2,2), &
+ tau(sx1,sx2,sx3/2),gamma(sx1+2,sx2,sx3/2), &
+ depthmask(sx3/2),t1(sx1+2,sx2),t2(sx1+2,sx2),t3(sx1+2,sx2), &
+ STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate memory"
+ v1=0;v2=0;v3=0;u1=0;u2=0;u3=0;gamma=0;depthmask=0;t1=0;t2=0;t3=0
+ CALL tensorfieldadd(tau,tau,sx1,sx2,sx3/2,c1=0._4,c2=0._4)
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - construct pre-stress structure
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (ALLOCATED(stresslayer)) THEN
+ CALL tensorstructure(stressstruc,stresslayer,dx3)
+ DEALLOCATE(stresslayer)
+
+ DO k=1,sx3/2
+ tau(:,:,k)=(-1._4) .times. stressstruc(k)%t
+ END DO
+ DEALLOCATE(stressstruc)
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - construct linear viscoelastic structure
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (ALLOCATED(linearlayer)) THEN
+ CALL viscoelasticstructure(linearstruc,linearlayer,dx3)
+ DEALLOCATE(linearlayer)
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - construct nonlinear viscoelastic structure
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (ALLOCATED(nonlinearlayer)) THEN
+ CALL viscoelasticstructure(nonlinearstruc,nonlinearlayer,dx3)
+ DEALLOCATE(nonlinearlayer)
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! - construct nonlinear fault creep structure (rate-strenghtening)
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (ALLOCATED(faultcreeplayer)) THEN
+ CALL viscoelasticstructure(faultcreepstruc,faultcreeplayer,dx3)
+ DEALLOCATE(faultcreeplayer)
+ END IF
+
+ ! flag depths where creep is expected
+ CALL eqbf_mask(depthmask,sx3/2)
+
+ ! first event
+ e=1
+ ! first output
+ oi=1;
+
+ ! sources
+ CALL dislocations(events(e),lambda,mu,beta,sx1,sx2,sx3, &
+ dx1,dx2,dx3,v1,v2,v3,t1,t2,t3,tau)
+ CALL traction(mu,events(e),sx1,sx2,dx1,dx2,t3)
+
+ PRINT '("coseismic event ",I3.3)', e
+ PRINT 0990
+
+ ! export the amplitude of eigenstrain
+ CALL exporteigenstrain(gamma,nop,op,x0,y0,dx1,dx2,dx3,sx1,sx2,sx3/2,wdir,0)
+
+ ! export equivalent body forces
+ IF (isoutput(skip,t,i,odt,oi,events(e)%time)) THEN
+#ifdef GRD_EQBF
+ CALL exportgrd(v1,v2,v3,sx1,sx2,sx3/2,dx1,dx2,dx3,0.7_8,x0,y0,wdir,0,convention=3)
+#endif
+ END IF
+
+ ! test the presence of dislocations for coseismic calculation
+ IF ((events(e)%nt .NE. 0) .OR. &
+ (events(e)%ns .NE. 0) .OR. &
+ (events(e)%nm .NE. 0)) THEN
+
+ ! apply the 3d elastic transfer function
+ CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3,dx1,dx2,dx3,lambda,mu,gam)
+ END IF
+
+ ! transfer solution
+ CALL fieldrep(u1,v1,sx1+2,sx2,sx3/2)
+ CALL fieldrep(u2,v2,sx1+2,sx2,sx3/2)
+ CALL fieldrep(u3,v3,sx1+2,sx2,sx3/2)
+
+ ! export
+#ifdef TXT
+ CALL exporttxt(u1,u2,u3,sx1,sx2,sx3/2,oz,dx3,0,0._8,wdir,reportfilename)
+#endif
+#ifdef XYZ
+ CALL exportxyz(u1,u2,u3,sx1,sx2,sx3/2,oz,dx1,dx2,dx3,0,wdir)
+#endif
+#ifdef GRD
+ CALL exportgrd(u1,u2,u3,sx1,sx2,sx3/2,dx1,dx2,dx3,oz,x0,y0,wdir,0)
+ CALL exportgrd(inter1,inter2,inter3,sx1,sx2,sx3/2, &
+ dx1,dx2,dx3,0._8,x0,y0,wdir,0,convention=2)
+#endif
+#ifdef PROJ
+ CALL exportproj(u1,u2,u3,sx1,sx2,sx3/2,dx1,dx2,dx3,oz, &
+ x0,y0,lon0,lat0,zone,umult,wdir,0)
+#endif
+#ifdef VTK
+ j=INDEX(wdir," ")
+ vcfilename=wdir(1:j-1)//"/disp-000.vtr"
+ CALL exportvtk_vectors(u1,u2,u3,sx1,sx2,sx3/4,dx1,dx2,dx3,8,8,8,vcfilename)
+ !CALL exportvtk_vectors_slice(u1,u2,u3,sx1,sx2,sx3/2,dx1,dx2,dx3,oz,8,8,vcfilename)
+#endif
+ IF (ALLOCATED(ptsname)) THEN
+ CALL exportpoints(u1,u2,u3,sx1,sx2,sx3/2,dx1,dx2,dx3, &
+ opts,ptsname,0._8,wdir,.true.,x0,y0,rot)
+ END IF
+ CALL reporttime(0,0._8,reporttimefilename)
+
+ PRINT 1101,0,0._8,0._8,0._8,0._8,0._8,interval,0._8,tensoramplitude(tau,dx1,dx2,dx3)
+ IF (interval .LE. 0) THEN
+ GOTO 100 ! no time integration
+ END IF
+
+ ALLOCATE(moment(sx1,sx2,sx3/2),sig(sx1,sx2,sx3/2),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the mechanical structure"
+
+ CALL tensorfieldadd(sig,sig,sx1,sx2,sx3/2,c1=0._4,c2=0._4)
+ CALL tensorfieldadd(moment,moment,sx1,sx2,sx3/2,c1=0._4,c2=0._4)
+
+ t=0
+ DO i=1,ITERATION_MAX
+ IF (t > (interval+1e-6)) GOTO 100 ! proper exit
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! predictor
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ CALL tensorfieldadd(sig,tau,sx1,sx2,sx3/2,c1=0._4,c2=-1._4)
+ CALL stressupdate(u1,u2,u3,lambda,mu,dx1,dx2,dx3,sx1,sx2,sx3/2,sig)
+
+ ! export stress
+#ifdef GRD
+ CALL exportstressgrd(sig,sx1,sx2,sx3/2,dx1,dx2,dx3,ozs,x0,y0,wdir,i-1)
+#endif
+#ifdef PROJ
+ CALL exportstressproj(sig,sx1,sx2,sx3/2,dx1,dx2,dx3,ozs, &
+ x0,y0,lon0,lat0,zone,umult,wdir,i-1)
+#endif
+
+ ! 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,sx1,sx2,sx3/2,0._4,0._4)
+
+ ! power density from three mechanisms (linear and power-law viscosity
+ ! and fault creep)
+ ! 1- linear viscosity
+ IF (ALLOCATED(linearstruc)) THEN
+ CALL viscouseigenstress(mu,linearstruc,linearweakzone,sig,sx1,sx2,sx3/2, &
+ dx1,dx2,dx3,moment,0.01_8,MAXWELLTIME=maxwell(1))
+ mech(1)=1
+ END IF
+
+ ! 2- powerlaw viscosity
+ IF (ALLOCATED(nonlinearstruc)) THEN
+ CALL viscouseigenstress(mu,nonlinearstruc,nonlinearweakzone,sig,sx1,sx2,sx3/2, &
+ dx1,dx2,dx3,moment,0.01_8,MAXWELLTIME=maxwell(2))
+ mech(2)=1
+ END IF
+
+ ! 3- nonlinear fault creep with rate-strengthening friction
+ IF (ALLOCATED(faultcreepstruc)) THEN
+ DO k=1,np
+ CALL frictioneigenstress(n(k)%x,n(k)%y,n(k)%z, &
+ n(k)%width,n(k)%length,n(k)%strike,n(k)%dip,beta, &
+ sig,mu,faultcreepstruc,sx1,sx2,sx3/2,dx1,dx2,dx3,moment, &
+ maxwelltime=maxwell(3))
+ END DO
+ mech(3)=1
+ END IF
+
+ ! 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 ((inter%ns .GT. 0) .OR. (inter%nt .GT. 0)) THEN
+ IF (tm .EQ. STEP_MAX) THEN
+ ! no relaxation occurs, pick a small integration time
+ tm=interval/20._8
+ END IF
+ END IF
+
+ ! choose an integration time step
+ CALL integrationstep(tm,Dt,t,oi,odt,events,e,ne)
+
+ CALL tensorfieldadd(sig,moment,sx1,sx2,sx3/2,c1=0.0_4,c2=1._4)
+
+ v1=0;v2=0;v3=0;t1=0;t2=0;t3=0;
+ CALL equivalentbodyforce(sig,dx1,dx2,dx3,sx1,sx2,sx3/2,v1,v2,v3,t1,t2,t3)
+ CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3,dx1,dx2,dx3,lambda,mu,gam)
+
+ ! v1,v2,v3 contain the predictor displacement
+ CALL fieldadd(v1,u1,sx1+2,sx2,sx3/2,c1=REAL(Dt/2))
+ CALL fieldadd(v2,u2,sx1+2,sx2,sx3/2,c1=REAL(Dt/2))
+ CALL fieldadd(v3,u3,sx1+2,sx2,sx3/2,c1=REAL(Dt/2))
+ CALL tensorfieldadd(sig,tau,sx1,sx2,sx3/2,c1=-REAL(Dt/2),c2=-1._4)
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! corrector
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ CALL stressupdate(v1,v2,v3,lambda,mu,dx1,dx2,dx3,sx1,sx2,sx3/2,sig)
+
+ ! reinitialize moment density tensor
+ CALL tensorfieldadd(moment,moment,sx1,sx2,sx3/2,0._4,0._4)
+
+ IF (ALLOCATED(linearstruc)) THEN
+ ! linear viscosity
+ v1=0
+ CALL viscouseigenstress(mu,linearstruc,linearweakzone,sig,sx1,sx2,sx3/2, &
+ dx1,dx2,dx3,moment,0.01_8,GAMMA=v1)
+
+ ! update slip history
+ CALL fieldadd(gamma,v1,sx1+2,sx2,sx3/2,c2=REAL(Dt))
+ END IF
+
+ IF (ALLOCATED(nonlinearstruc)) THEN
+ ! powerlaw viscosity
+ v1=0
+ CALL viscouseigenstress(mu,nonlinearstruc,nonlinearweakzone,sig,sx1,sx2,sx3/2, &
+ dx1,dx2,dx3,moment,0.01_8,GAMMA=v1)
+
+ ! update slip history
+ CALL fieldadd(gamma,v1,sx1+2,sx2,sx3/2,c2=REAL(Dt))
+ END IF
+
+ ! nonlinear fault creep with rate-strengthening friction
+ IF (ALLOCATED(faultcreepstruc)) THEN
+ ! use v1 as placeholders for the afterslip planes
+ v1=0
+ DO k=1,np
+ CALL frictioneigenstress(n(k)%x,n(k)%y,n(k)%z, &
+ n(k)%width,n(k)%length,n(k)%strike,n(k)%dip,beta, &
+ sig,mu,faultcreepstruc,sx1,sx2,sx3/2,dx1,dx2,dx3,moment,VEL=v1)
+ END DO
+
+ ! update slip history
+ CALL fieldadd(gamma,v1,sx1+2,sx2,sx3/2,c2=REAL(Dt))
+
+ ! export strike and dip creep velocity
+ CALL exportcreep(np,n,beta,sig,faultcreepstruc, &
+ sx1,sx2,sx3/2,dx1,dx2,dx3,x0,y0,wdir,oi)
+ END IF
+
+ ! interseismic loading
+ IF ((inter%ns .GT. 0) .OR. (inter%nt .GT. 0)) THEN
+ ! vectors v1,v2,v3 are not affected.
+ CALL dislocations(inter,lambda,mu,beta,sx1,sx2,sx3, &
+ dx1,dx2,dx3,v1,v2,v3,t1,t2,t3,tau,factor=Dt,eigenstress=moment)
+ END IF
+
+ v1=0;v2=0;v3=0;t1=0;t2=0;t3=0;
+ CALL equivalentbodyforce(moment,dx1,dx2,dx3,sx1,sx2,sx3/2,v1,v2,v3,t1,t2,t3)
+
+ ! export equivalent body forces
+ IF (isoutput(skip,t,i,odt,oi,events(e)%time)) THEN
+#ifdef VTK_EQBF
+ WRITE (digit,'(I3.3)') oi
+ j=INDEX(wdir," ")
+ vcfilename=wdir(1:j-1)//"/eqbf-"//digit//".vtr"
+ CALL exportvtk_vectors(v1,v2,v3,sx1,sx2,sx3/4,dx1,dx2,dx3,8,8,8,vcfilename)
+#endif
+#ifdef GRD_EQBF
+ CALL exportgrd(v1,v2,v3,sx1,sx2,sx3/2,dx1,dx2,dx3,30.7_8,x0,y0,wdir,oi,convention=3)
+#endif
+ END IF
+
+ CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3,dx1,dx2,dx3,lambda,mu,gam)
+
+ ! update deformation field
+ CALL fieldadd(u1,v1,sx1+2,sx2,sx3/2,c2=REAL(Dt))
+ CALL fieldadd(u2,v2,sx1+2,sx2,sx3/2,c2=REAL(Dt))
+ CALL fieldadd(u3,v3,sx1+2,sx2,sx3/2,c2=REAL(Dt))
+ CALL tensorfieldadd(tau,moment,sx1,sx2,sx3/2,c2=REAL(Dt))
+
+ ! keep track of the viscoelastic contribution alone
+ CALL sliceadd(inter1(:,:,1),v1,sx1+2,sx2,sx3,int(oz/dx3)+1,c2=REAL(Dt))
+ CALL sliceadd(inter2(:,:,1),v2,sx1+2,sx2,sx3,int(oz/dx3)+1,c2=REAL(Dt))
+ CALL sliceadd(inter3(:,:,1),v3,sx1+2,sx2,sx3,int(oz/dx3)+1,c2=REAL(Dt))
+
+ ! time increment
+ t=t+Dt
+
+ ! next event
+ IF (e .LT. ne) THEN
+ IF (abs(t-events(e+1)%time) .LT. 1e-6) THEN
+ e=e+1
+ PRINT '("coseismic event ",I3.3)', e
+ PRINT 0990
+
+ v1=0;v2=0;v3=0;t1=0;t2=0;t3=0;
+ CALL dislocations(events(e),lambda,mu,beta,sx1,sx2,sx3, &
+ dx1,dx2,dx3,v1,v2,v3,t1,t2,t3,tau)
+ CALL traction(mu,events(e),sx1,sx2,dx1,dx2,t3)
+
+ ! apply the 3d elastic transfert function
+ CALL greenfunctioncowling(v1,v2,v3,t1,t2,t3,dx1,dx2,dx3,lambda,mu,gam)
+
+ ! transfer solution
+ CALL fieldadd(u1,v1,sx1+2,sx2,sx3/2)
+ CALL fieldadd(u2,v2,sx1+2,sx2,sx3/2)
+ CALL fieldadd(u3,v3,sx1+2,sx2,sx3/2)
+
+ END IF
+ END IF
+
+ ! points are exported systematically
+ IF (ALLOCATED(ptsname)) THEN
+ CALL exportpoints(u1,u2,u3,sx1,sx2,sx3/2,dx1,dx2,dx3, &
+ opts,ptsname,t,wdir,.false.,x0,y0,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(skip,t,i,odt,oi,events(e)%time)) THEN
+
+ CALL reporttime(1,t,reporttimefilename)
+
+ ! export
+#ifdef TXT
+ CALL exporttxt(u1,u2,u3,sx1,sx2,sx3/2,oz,dx3,oi,t,wdir,reportfilename)
+#endif
+#ifdef XYZ
+ CALL exportxyz(u1,u2,u3,sx1,sx2,sx3/2,oz,dx1,dx2,dx3,i,wdir)
+ !CALL exportxyz(inter1,inter2,inter3,sx1,sx2,sx3/2,0.0_8,dx1,dx2,dx3,i,wdir)
+#endif
+ CALL exporteigenstrain(gamma,nop,op,x0,y0,dx1,dx2,dx3,sx1,sx2,sx3/2,wdir,oi)
+#ifdef GRD
+ CALL exportgrd(inter1,inter2,inter3,sx1,sx2,sx3/2, &
+ dx1,dx2,dx3,0._8,x0,y0,wdir,oi,convention=2)
+ CALL exportgrd(u1,u2,u3,sx1,sx2,sx3/2,dx1,dx2,dx3,oz,x0,y0,wdir,oi)
+#endif
+#ifdef PROJ
+ CALL exportproj(inter1,inter2,inter3,sx1,sx2,sx3/2, &
+ dx1,dx2,dx3,oz,x0,y0, &
+ lon0,lat0,zone,umult,wdir,oi,convention=2)
+ CALL exportproj(u1,u2,u3,sx1,sx2,sx3/2,dx1,dx2,dx3,oz,x0,y0, &
+ lon0,lat0,zone,umult,wdir,oi)
+#endif
+#ifdef VTK
+ WRITE (digit,'(I3.3)') oi
+ j=INDEX(wdir," ")
+ ! export total displacement in VTK XML format
+ vcfilename=wdir(1:j-1)//"/disp-"//digit//".vtr"
+ CALL exportvtk_vectors(u1,u2,u3,sx1,sx2,sx3/4,dx1,dx2,dx3,8,8,8,vcfilename)
+ !CALL exportvtk_vectors_slice(u1,u2,u3,sx1,sx2,sx3/2,dx1,dx2,dx3,oz,8,8,vcfilename)
+
+ ! export instantaneous velocity in VTK XML format
+ vcfilename=wdir(1:j-1)//"/vel-"//digit//".vtr"
+ CALL exportvtk_vectors(v1,v2,v3,sx1,sx2,sx3/4,dx1,dx2,dx3,8,8,8,vcfilename)
+ !CALL exportvtk_vectors_slice(v1,v2,v3,sx1,sx2,sx3/2,dx1,dx2,dx3,oz,8,8,vcfilename)
+#endif
+
+ PRINT 1101,i,Dt,maxwell,t,interval, &
+ tensoramplitude(moment,dx1,dx2,dx3), &
+ tensoramplitude(tau,dx1,dx2,dx3)
+
+ ! update output counter
+ oi=oi+1
+ ELSE
+ PRINT 1100,i,Dt,maxwell,t,interval, &
+ tensoramplitude(moment,dx1,dx2,dx3), &
+ tensoramplitude(tau,dx1,dx2,dx3)
+ END IF
+
+ END DO
+
+100 CONTINUE
+
+ DO i=1,ne
+ IF (ALLOCATED(events(i)%s)) DEALLOCATE(events(i)%s,events(i)%sc)
+ IF (ALLOCATED(events(i)%ts)) DEALLOCATE(events(i)%ts,events(i)%tsc)
+ END DO
+ IF (ALLOCATED(events)) DEALLOCATE(events)
+
+ ! free memory
+ IF (ALLOCATED(gamma)) DEALLOCATE(gamma)
+ IF (ALLOCATED(opts)) DEALLOCATE(opts)
+ IF (ALLOCATED(op)) DEALLOCATE(op)
+ IF (ALLOCATED(n)) DEALLOCATE(n)
+ IF (ALLOCATED(stressstruc)) DEALLOCATE(stressstruc)
+ IF (ALLOCATED(linearstruc)) DEALLOCATE(linearstruc)
+ IF (ALLOCATED(nonlinearstruc)) DEALLOCATE(nonlinearstruc)
+ IF (ALLOCATED(faultcreepstruc)) DEALLOCATE(faultcreepstruc)
+ IF (ALLOCATED(sig)) DEALLOCATE(sig)
+ IF (ALLOCATED(tau)) DEALLOCATE(tau)
+ IF (ALLOCATED(moment)) DEALLOCATE(moment)
+ IF (ALLOCATED(stresslayer)) DEALLOCATE(stresslayer)
+ IF (ALLOCATED(linearlayer)) DEALLOCATE(linearlayer)
+ IF (ALLOCATED(nonlinearlayer)) DEALLOCATE(nonlinearlayer)
+ IF (ALLOCATED(faultcreeplayer)) DEALLOCATE(faultcreeplayer)
+ DEALLOCATE(v1,v2,v3,t1,t2,t3)
+ DEALLOCATE(u1,u2,u3)
+ DEALLOCATE(inter1,inter2,inter3)
+
+
+#ifdef FFTW3_THREADS
+ CALL sfftw_cleanup_threads()
+#endif
+
+#ifdef MPI_IMP
+
+ ! clean exit all slave threads
+ DO islave=1,nslaves
+ CALL MPI_SEND(iflag_TellSlaveToQuit,1,MPI_INTEGER,islave,tag_MasterSendingData,MPI_COMM_WORLD,ierr)
+ ENDDO
+
+ ELSE ! (myid == 0)
+ CALL mpi_slave_controller(threadid)
+ ENDIF
+
+ ! close MPI
+ CALL MPI_FINALIZE(ierr)
+#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
+
+#ifdef MPI_IMP
+
+ !--------------------------------------------------------
+ ! subroutine MPI_Slave_Controller
+ ! is the main program for the dependent threads.
+ ! Listens for instruction from main thread. When an
+ ! instruction is recognized, run the adequate task.
+ !
+ ! sylvain barbot (02/03/09) - original form
+ !--------------------------------------------------------
+ SUBROUTINE mpi_slave_controller(islave)
+ INTEGER, INTENT(IN) :: islave
+
+ INTEGER :: ierr,iflag
+
+ ! infinite while loop for slave controller
+ DO
+ ! check instructions from master thread
+ CALL MPI_RECV(iflag,1,MPI_INTEGER,master,tag_MasterSendingData,MPI_COMM_WORLD,status,ierr)
+
+ ! Check to see what the master is telling me:
+ SELECT CASE(iflag)
+
+ CASE(iflag_TellSlaveToQuit)
+ PRINT '("thread ",I3.3," is shutting down properly.")', islave
+ RETURN
+
+ CASE(iflag_TellSlaveToRecv_Cerruti3d)
+
+ CALL Cerruti3dSlave(islave)
+
+ CASE(iflag_TellSlaveToRecv_SurfTrac)
+
+ CALL SurfaceTractionSlave(islave)
+
+ CASE(iflag_TellSlaveToRecv_ElasResp)
+
+ CALL ElasticResponseSlave(islave)
+
+ CASE(iflag_TellSlaveToRecv_Stress)
+
+ CALL stressslave(islave)
+
+ CASE(iflag_TellSlaveToRecv_Eqbf)
+
+ CALL stresseqbf(islave)
+
+ CASE DEFAULT
+ WRITE_DEBUG_INFO
+ WRITE(*,*) 'error in slave', islave, ' received unknown command from master'
+ WRITE(*,*) 'iflag is: ',iflag
+ RETURN
+ END SELECT
+
+ END DO
+
+ END SUBROUTINE mpi_slave_controller
+
+#endif
+
+ !--------------------------------------------------------------------
+ ! subroutine eqbf_mask
+ ! fills an array with positive values if some linear/nonlinear/creep
+ ! is expected at the corresponding depth, zero otherwise.
+ !
+ ! the mask can be given to the routine "equivalentBodyForce" to skip
+ ! these depths where no creep happens.
+ !--------------------------------------------------------------------
+ SUBROUTINE eqbf_mask(mask,sx)
+ INTEGER, INTENT(IN) :: sx
+ REAL*4, DIMENSION(sx), INTENT(OUT) :: mask
+
+ IF (ALLOCATED(linearstruc)) THEN
+ DO k=1,sx
+ mask(k)=MAX(mask(k),REAL(linearstruc(k)%gammadot0,4))
+ END DO
+ END IF
+ IF (ALLOCATED(nonlinearstruc)) THEN
+ DO k=1,sx
+ mask(k)=MAX(mask(k),REAL(nonlinearstruc(k)%gammadot0,4))
+ END DO
+ END IF
+ IF (ALLOCATED(faultcreepstruc)) THEN
+ DO k=1,sx
+ mask(k)=MAX(mask(k),REAL(faultcreepstruc(k)%gammadot0,4))
+ END DO
+ END IF
+
+ ! smooth the mask in the depth direction
+ mask(1:sx-2)=(mask(1:sx-2)+mask(2:sx-1)+mask(3:sx))/3._4
+
+ END SUBROUTINE eqbf_mask
+
+ !---------------------------------------------------------------------
+ ! subroutine Traction
+ ! assigns the traction vector at the surface
+ !
+ ! sylvain barbot (07-19-07) - original form
+ !---------------------------------------------------------------------
+ SUBROUTINE traction(mu,e,sx1,sx2,dx1,dx2,t3)
+ TYPE(EVENT_STRUC), INTENT(IN) :: e
+ INTEGER, INTENT(IN) :: sx1,sx2
+ REAL*8, INTENT(IN) :: mu,dx1,dx2
+#ifdef ALIGN_DATA
+ REAL*4, DIMENSION(sx1+2,sx2), INTENT(INOUT) :: t3
+#else
+ REAL*4, DIMENSION(sx1,sx2), INTENT(INOUT) :: t3
+#endif
+
+ INTEGER :: i1,i2,i3
+
+ DO i=1,e%nl
+ CALL shiftedindex(e%l(i)%x,e%l(i)%y,0._8,sx1,sx2,1,dx1,dx2,1._8,i1,i2,i3)
+
+ ! surface tractions
+ t3(i1,i2)=t3(i1,i2)-e%l(i)%slip*mu
+ END DO
+
+ END SUBROUTINE traction
+
+ !--------------------------------------------------------------------
+ ! 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=1._8
+
+ 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, &
+ 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, &
+ 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, &
+ 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
+
+ SUBROUTINE init(unit)
+ INTEGER, OPTIONAL, INTENT(INOUT) :: unit
+
+ INTEGER :: k,iostatus,i,e
+ CHARACTER(180) :: dataline
+#ifdef VTK
+ INTEGER :: j
+ CHARACTER(3) :: digit
+#endif
+ INTEGER :: iunit
+!$ INTEGER :: omp_get_num_procs,omp_get_max_threads
+ REAL*8 :: dummy
+
+ ! default is standard input
+ IF (.NOT. PRESENT(unit)) THEN
+ iunit=5
+ ELSE
+ iunit=unit
+ END IF
+
+ PRINT 2000
+ PRINT '(" nonlinear viscoelastic postseismic relaxation")'
+#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
+#ifdef MPI_IMP
+ PRINT '(" * parallel MPI implementation with ",I3.3," threads")',nthreads
+#endif
+!$ PRINT '(" * parallel OpenMP implementation with ",I3.3,"/",I3.3," threads")', &
+!$ omp_get_max_threads(),omp_get_num_procs()
+#ifdef GRD
+ PRINT '(" * export to GRD format")'
+#endif
+#ifdef TXT
+ PRINT '(" * export to TXT format")'
+#endif
+#ifdef VTK
+ PRINT '(" * export to VTK format")'
+#endif
+#ifdef PROJ
+ PRINT '(" * export to longitude/latitude text format")'
+#endif
+ PRINT 2000
+
+ PRINT '(a)', "grid dimension (sx1,sx2,sx3)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) sx1,sx2,sx3
+ PRINT '(3I5)', sx1,sx2,sx3
+
+ PRINT '(a)', "sampling (dx1,dx2,dx3), smoothing (beta, nyquist)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) dx1,dx2,dx3,beta,nyquist
+ PRINT '(5ES9.2E1)', dx1,dx2,dx3,beta,nyquist
+
+ PRINT '(a)', "origin position (x0,y0) and rotation"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) x0, y0, rot
+ PRINT '(3ES9.2E1)', x0, y0, rot
+
+#ifdef PROJ
+ PRINT '(a)', "geographic origin (longitude, latitude, UTM zone, unit)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) lon0,lat0,zone,umult
+ PRINT '(2ES9.2E1,I3.2,ES9.2E1)',lon0,lat0,zone,umult
+ IF (zone.GT.60 .OR. zone.LT.1) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("invalid UTM zone ",I," (1<=zone<=60. exiting.)")') zone
+ STOP 1
+ ENDIF
+#endif
+
+ PRINT '(a)', "observation depth (displacement and stress)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) oz,ozs
+ PRINT '(2ES9.2E1)', oz,ozs
+
+ PRINT '(a)', "output directory"
+ CALL getdata(iunit,dataline)
+ READ (dataline,'(a)') wdir
+ i=INDEX(wdir," ")
+ reporttimefilename=wdir(1:i-1)//"/time.txt"
+ reportfilename=wdir(1:i-1)//"/report.txt"
+ logfilename=wdir(1:i-1)//"/relax.log"
+ inputfilename=wdir(1:i-1)//"/relax.inp"
+#ifdef TXT
+ PRINT '(" ",a," (report: ",a,")")', wdir(1:i-1),reportfilename(1:i+10)
+#else
+ PRINT '(" ",a," (time report: ",a,")")', wdir(1:i-1),reporttimefilename(1:i+8)
+#endif
+
+ ! test write permissions on output directory
+ OPEN (UNIT=14,FILE=reportfilename,POSITION="APPEND",&
+ IOSTAT=iostatus,FORM="FORMATTED")
+ IF (iostatus>0) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("unable to access ",a)') reporttimefilename(1:i+10)
+ STOP 1
+ END IF
+ CLOSE(14)
+ ! end test
+
+#ifdef VTK
+ cgfilename=wdir(1:i-1)//"/cgrid.vtp"
+ CALL exportvtk_grid(sx1,sx2,sx3,dx1,dx2,dx3,x0,y0,cgfilename)
+#endif
+
+ PRINT '(a)', "lambda, mu, gamma (gamma = (1 - nu) rho g / mu)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) lambda,mu,gam
+ PRINT '(3ES10.2E2)',lambda,mu,gam
+
+ PRINT '(a)', "integration time and time step"
+ CALL getdata(unit,dataline)
+ READ (dataline,*) interval, odt
+ IF (odt .LT. 0.) THEN
+ skip=fix(-odt)
+ PRINT '(ES9.2E1," (output every ",I3.3," computational steps)")', interval,skip
+ ELSE
+ PRINT '(2ES9.2E1)', interval,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(unit,dataline)
+ READ (dataline,*) nop
+ PRINT '(I5)', nop
+ IF (nop .gt. 0) THEN
+ ALLOCATE(op(nop),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the observation plane list"
+ PRINT 2000
+ PRINT 2100
+ PRINT 2000
+ DO k=1,nop
+ CALL getdata(unit,dataline)
+ READ (dataline,*) i,op(k)%x,op(k)%y,op(k)%z,&
+ op(k)%length,op(k)%width,op(k)%strike,op(k)%dip
+
+ PRINT '(I3.3," ",5ES9.2E1,2f7.1)', &
+ k,op(k)%x,op(k)%y,op(k)%z, &
+ op(k)%length,op(k)%width,op(k)%strike,op(k)%dip
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,*) "error in input file: plane index misfit", k,"<>",i
+ WRITE (0,*) op(k)
+ STOP 1
+ END IF
+
+ ! comply to Wang's convention
+ CALL wangconvention(dummy,op(k)%x,op(k)%y,op(k)%z,&
+ op(k)%length,op(k)%width,op(k)%strike,op(k)%dip,dummy,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,*) npts
+ PRINT '(I5)', npts
+ IF (npts .gt. 0) THEN
+ ALLOCATE(opts(npts),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the observation point list"
+ ALLOCATE(ptsname(npts),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the list of point name"
+
+ PRINT 2000
+ PRINT 2300
+ PRINT 2000
+ DO k=1,npts
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,ptsname(k),opts(k)%v1,opts(k)%v2,opts(k)%v3
+
+ PRINT '(I3.3," ",A4,3ES9.2E1)', i,ptsname(k), &
+ opts(k)%v1,opts(k)%v2,opts(k)%v3
+
+ ! shift and rotate coordinates
+ opts(k)%v1=opts(k)%v1-x0
+ opts(k)%v2=opts(k)%v2-y0
+ CALL rotation(opts(k)%v1,opts(k)%v2,rot)
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: points index misfit")')
+ STOP 1
+ END IF
+ END DO
+
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! P R E S T R E S S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of prestress interfaces"
+ CALL getdata(unit,dataline)
+ READ (dataline,*) nps
+ PRINT '(I5)', nps
+
+ IF (nps .GT. 0) THEN
+ ALLOCATE(stresslayer(nps),stressstruc(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,nps
+ CALL getdata(unit,dataline)
+ READ (dataline,*) i,stresslayer(k)%z, &
+ stresslayer(k)%t%s11, stresslayer(k)%t%s12, &
+ stresslayer(k)%t%s13, stresslayer(k)%t%s22, &
+ stresslayer(k)%t%s23, stresslayer(k)%t%s33
+
+ PRINT '(I3.3,7ES9.2E1)', i, &
+ stresslayer(k)%z, &
+ stresslayer(k)%t%s11, stresslayer(k)%t%s12, &
+ stresslayer(k)%t%s13, stresslayer(k)%t%s22, &
+ stresslayer(k)%t%s23, 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(unit,dataline)
+ READ (dataline,*) nv
+ PRINT '(I5)', nv
+
+ IF (nv .GT. 0) THEN
+ ALLOCATE(linearlayer(nv),linearstruc(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,nv
+ CALL getdata(unit,dataline)
+ READ (dataline,*) i,linearlayer(k)%z, &
+ linearlayer(k)%gammadot0, linearlayer(k)%cohesion
+
+ linearlayer(k)%stressexponent=1
+
+ PRINT '(I3.3,3ES10.2E2)', i, &
+ linearlayer(k)%z, &
+ linearlayer(k)%gammadot0, &
+ linearlayer(k)%cohesion
+
+ ! check positive strain rates
+ IF (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
+ j=INDEX(wdir," ")
+ WRITE (digit,'(I3.3)') k
+
+ rffilename=wdir(1:j-1)//"/linearlayer-"//digit//".vtp"
+ CALL exportvtk_rectangle(0.d0,0.d0,linearlayer(k)%z, &
+ DBLE(sx1)*dx1,DBLE(sx2)*dx2, &
+ 0._8,1.57d0,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 (nlwz)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) nlwz
+ PRINT '(I5)', nlwz
+ IF (nlwz .GT. 0) THEN
+ ALLOCATE(linearweakzone(nlwz),linearweakzonec(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,nlwz
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i, &
+ linearweakzone(k)%dgammadot0, &
+ linearweakzone(k)%x,linearweakzone(k)%y,linearweakzone(k)%z,&
+ linearweakzone(k)%length,linearweakzone(k)%width,linearweakzone(k)%thickness, &
+ linearweakzone(k)%strike,linearweakzone(k)%dip
+
+ linearweakzonec(k)=linearweakzone(k)
+
+ PRINT '(I3.3,4ES9.2E1,3ES8.2E1,f7.1,f6.1)',k,&
+ linearweakzone(k)%dgammadot0, &
+ linearweakzone(k)%x,linearweakzone(k)%y,linearweakzone(k)%z, &
+ linearweakzone(k)%length,linearweakzone(k)%width, &
+ linearweakzone(k)%thickness, &
+ linearweakzone(k)%strike,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, &
+ linearweakzone(k)%x,linearweakzone(k)%y,linearweakzone(k)%z, &
+ linearweakzone(k)%length,linearweakzone(k)%width, &
+ linearweakzone(k)%strike,linearweakzone(k)%dip,dummy,rot)
+#ifdef VTK
+ ! export the ductile zone in VTK format
+ j=INDEX(wdir," ")-1
+ WRITE (digit,'(I3.3)') k
+
+ rffilename=wdir(1:j)//"/weakzone-"//digit//".vtp"
+ CALL exportvtk_brick(linearweakzone(k)%x,linearweakzone(k)%y,linearweakzone(k)%z, &
+ linearweakzone(k)%length,linearweakzone(k)%width,linearweakzone(k)%thickness, &
+ linearweakzone(k)%strike,linearweakzone(k)%dip,rffilename)
+#endif
+ 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(unit,dataline)
+ READ (dataline,*) npl
+ PRINT '(I5)', npl
+
+ IF (npl .GT. 0) THEN
+ ALLOCATE(nonlinearlayer(npl),nonlinearstruc(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,npl
+ CALL getdata(unit,dataline)
+
+ READ (dataline,*) i,nonlinearlayer(k)%z, &
+ nonlinearlayer(k)%gammadot0, &
+ nonlinearlayer(k)%stressexponent, &
+ nonlinearlayer(k)%cohesion
+
+ PRINT '(I3.3,4ES10.2E2)', i, &
+ nonlinearlayer(k)%z, &
+ nonlinearlayer(k)%gammadot0, &
+ nonlinearlayer(k)%stressexponent, &
+ nonlinearlayer(k)%cohesion
+
+ ! check positive strain rates
+ IF (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
+
+ 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 (nnlwz)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) nnlwz
+ PRINT '(I5)', nnlwz
+ IF (nnlwz .GT. 0) THEN
+ ALLOCATE(nonlinearweakzone(nnlwz),nonlinearweakzonec(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,nnlwz
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i, &
+ nonlinearweakzone(k)%dgammadot0, &
+ nonlinearweakzone(k)%x,nonlinearweakzone(k)%y,nonlinearweakzone(k)%z,&
+ nonlinearweakzone(k)%length,nonlinearweakzone(k)%width,nonlinearweakzone(k)%thickness, &
+ nonlinearweakzone(k)%strike,nonlinearweakzone(k)%dip
+
+ nonlinearweakzonec(k)=nonlinearweakzone(k)
+
+ PRINT '(I3.3,4ES9.2E1,3ES8.2E1,f7.1,f6.1)',k,&
+ nonlinearweakzone(k)%dgammadot0, &
+ nonlinearweakzone(k)%x,nonlinearweakzone(k)%y,nonlinearweakzone(k)%z, &
+ nonlinearweakzone(k)%length,nonlinearweakzone(k)%width, &
+ nonlinearweakzone(k)%thickness, &
+ nonlinearweakzone(k)%strike,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, &
+ nonlinearweakzone(k)%x,nonlinearweakzone(k)%y,nonlinearweakzone(k)%z, &
+ nonlinearweakzone(k)%length,nonlinearweakzone(k)%width, &
+ nonlinearweakzone(k)%strike,nonlinearweakzone(k)%dip,dummy,rot)
+ 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(unit,dataline)
+ READ (dataline,*) nfc
+ PRINT '(I5)', nfc
+
+ IF (nfc .GT. 0) THEN
+ ALLOCATE(faultcreeplayer(nfc),faultcreepstruc(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,nfc
+ CALL getdata(unit,dataline)
+ READ (dataline,*) i,faultcreeplayer(k)%z, &
+ faultcreeplayer(k)%gammadot0, &
+ faultcreeplayer(k)%stressexponent, &
+ faultcreeplayer(k)%friction, &
+ faultcreeplayer(k)%cohesion
+
+ PRINT '(I3.3,5ES9.2E1)', i, &
+ faultcreeplayer(k)%z, &
+ faultcreeplayer(k)%gammadot0, &
+ faultcreeplayer(k)%stressexponent, &
+ faultcreeplayer(k)%friction, &
+ faultcreeplayer(k)%cohesion
+
+ ! check positive strain rates
+ IF (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(unit,dataline)
+ READ (dataline,*) np
+ PRINT '(I5)', np
+
+ IF (np .gt. 0) THEN
+ ALLOCATE(n(np),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the plane list"
+
+ PRINT 2000
+ PRINT 2100
+ PRINT 2000
+
+ DO k=1,np
+ CALL getdata(unit,dataline)
+ READ (dataline,*) i,n(k)%x,n(k)%y,n(k)%z,&
+ n(k)%length,n(k)%width,n(k)%strike,n(k)%dip
+
+ PRINT '(I3.3," ",5ES9.2E1,2f7.1)',i, &
+ n(k)%x,n(k)%y,n(k)%z, &
+ n(k)%length,n(k)%width,n(k)%strike,n(k)%dip
+
+ IF (i .ne. k) THEN
+ WRITE_DEBUG_INFO
+ WRITE (0,'("error in input file: plane index misfit")')
+ STOP 1
+ END IF
+
+ ! comply to Wang's convention
+ CALL wangconvention(dummy,n(k)%x,n(k)%y,n(k)%z,&
+ n(k)%length,n(k)%width,n(k)%strike,n(k)%dip,dummy,rot)
+
+#ifdef VTK
+ ! export the afterslip segment in VTK format
+ j=INDEX(wdir," ")
+ WRITE (digit,'(I3.3)') k
+
+ rffilename=wdir(1:j-1)//"/aplane-"//digit//".vtp"
+ CALL exportvtk_rectangle(n(k)%x,n(k)%y,n(k)%z,n(k)%length,n(k)%width, &
+ n(k)%strike,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=sx1*dx1+sx2*dx2
+ minwidth=sx3*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,*) inter%ns
+ PRINT '(I5)', inter%ns
+ IF (inter%ns .GT. 0) THEN
+ ALLOCATE(inter%s(inter%ns),inter%sc(inter%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,inter%ns
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,inter%s(k)%slip, &
+ inter%s(k)%x,inter%s(k)%y,inter%s(k)%z, &
+ inter%s(k)%length,inter%s(k)%width, &
+ inter%s(k)%strike,inter%s(k)%dip,inter%s(k)%rake
+ ! copy the input format for display
+ inter%sc(k)=inter%s(k)
+
+ PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1)',i, &
+ inter%sc(k)%slip,&
+ inter%sc(k)%x,inter%sc(k)%y,inter%sc(k)%z, &
+ inter%sc(k)%length,inter%sc(k)%width, &
+ inter%sc(k)%strike,inter%sc(k)%dip, &
+ 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(inter%s(k)%length,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 (inter%s(k)%length .lt. minlength) THEN
+ minlength=inter%s(k)%length
+ END IF
+ IF (inter%s(k)%width .lt. minwidth ) THEN
+ minwidth =inter%s(k)%width
+ END IF
+
+ ! smooth out the slip distribution
+ CALL antialiasingfilter(inter%s(k)%slip, &
+ inter%s(k)%length,inter%s(k)%width, &
+ dx1,dx2,dx3,nyquist)
+
+ ! comply to Wang's convention
+ CALL wangconvention(inter%s(k)%slip, &
+ inter%s(k)%x,inter%s(k)%y,inter%s(k)%z, &
+ inter%s(k)%length,inter%s(k)%width, &
+ inter%s(k)%strike,inter%s(k)%dip, &
+ inter%s(k)%rake,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,*) inter%nt
+ PRINT '(I5)', inter%nt
+ IF (inter%nt .GT. 0) THEN
+ ALLOCATE(inter%ts(inter%nt),inter%tsc(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,inter%nt
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,inter%ts(k)%slip, &
+ inter%ts(k)%x,inter%ts(k)%y,inter%ts(k)%z, &
+ inter%ts(k)%length,inter%ts(k)%width, &
+ inter%ts(k)%strike,inter%ts(k)%dip
+ ! copy the input format for display
+ inter%tsc(k)=inter%ts(k)
+
+ PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1)', i, &
+ inter%tsc(k)%slip,&
+ inter%tsc(k)%x,inter%tsc(k)%y,inter%tsc(k)%z, &
+ inter%tsc(k)%length,inter%tsc(k)%width, &
+ inter%tsc(k)%strike,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(inter%ts(k)%length,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 (inter%ts(k)%length .lt. minlength) THEN
+ minlength=inter%ts(k)%length
+ END IF
+ IF (inter%ts(k)%width .lt. minwidth) THEN
+ minwidth =inter%ts(k)%width
+ END IF
+
+ ! smooth out the slip distribution
+ CALL antialiasingfilter(inter%ts(k)%slip, &
+ inter%ts(k)%length,inter%ts(k)%width, &
+ dx1,dx2,dx3,nyquist)
+
+ ! comply to Wang's convention
+ CALL wangconvention(inter%ts(k)%slip, &
+ inter%ts(k)%x,inter%ts(k)%y,inter%ts(k)%z, &
+ inter%ts(k)%length,inter%ts(k)%width, &
+ inter%ts(k)%strike,inter%ts(k)%dip,dummy,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,*) ne
+ PRINT '(I5)', ne
+ IF (ne .GT. 0) ALLOCATE(events(ne),STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the event list"
+
+ DO e=1,ne
+ IF (1 .NE. e) THEN
+ PRINT '("time of next coseismic event")'
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) events(e)%time
+
+ IF (0 .EQ. skip) THEN
+ ! change event time to multiples of output time step
+ events(e)%time=fix(events(e)%time/odt)*odt
+ END IF
+
+ PRINT '(ES9.2E1," (multiple of ",ES9.2E1,")")', &
+ events(e)%time,odt
+
+ IF (events(e)%time .LE. 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
+ events(1)%time=0._8
+ END IF
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! S H E A R S O U R C E S
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+ PRINT '(a)', "number of coseismic strike-slip segments (ns)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) events(e)%ns
+ PRINT '(I5)', events(e)%ns
+ IF (events(e)%ns .GT. 0) THEN
+ ALLOCATE(events(e)%s(events(e)%ns),events(e)%sc(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,events(e)%ns
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,events(e)%s(k)%slip, &
+ events(e)%s(k)%x,events(e)%s(k)%y,events(e)%s(k)%z, &
+ events(e)%s(k)%length,events(e)%s(k)%width, &
+ events(e)%s(k)%strike,events(e)%s(k)%dip,events(e)%s(k)%rake
+ ! copy the input format for display
+ events(e)%sc(k)=events(e)%s(k)
+
+ PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1,f7.1)',i, &
+ events(e)%sc(k)%slip,&
+ events(e)%sc(k)%x,events(e)%sc(k)%y,events(e)%sc(k)%z, &
+ events(e)%sc(k)%length,events(e)%sc(k)%width, &
+ events(e)%sc(k)%strike,events(e)%sc(k)%dip, &
+ events(e)%sc(k)%rake
+
+ 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(events(e)%s(k)%length,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 (events(e)%s(k)%length .lt. minlength) THEN
+ minlength=events(e)%s(k)%length
+ END IF
+ IF (events(e)%s(k)%width .lt. minwidth ) THEN
+ minwidth =events(e)%s(k)%width
+ END IF
+
+ ! smooth out the slip distribution
+ CALL antialiasingfilter(events(e)%s(k)%slip, &
+ events(e)%s(k)%length,events(e)%s(k)%width, &
+ dx1,dx2,dx3,nyquist)
+
+ ! comply to Wang's convention
+ CALL wangconvention(events(e)%s(k)%slip, &
+ events(e)%s(k)%x,events(e)%s(k)%y,events(e)%s(k)%z, &
+ events(e)%s(k)%length,events(e)%s(k)%width, &
+ events(e)%s(k)%strike,events(e)%s(k)%dip, &
+ events(e)%s(k)%rake,rot)
+
+ END DO
+
+#ifdef VTK
+ ! export the fault segments in VTK format for the current event
+ j=INDEX(wdir," ")
+ WRITE (digit,'(I3.3)') e
+
+ rffilename=wdir(1:j-1)//"/rfaults-"//digit//".vtp"
+ CALL exportvtk_rfaults(events(e),rffilename)
+#endif
+
+ 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 (nt)"
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) events(e)%nt
+ PRINT '(I5)', events(e)%nt
+ IF (events(e)%nt .GT. 0) THEN
+ ALLOCATE(events(e)%ts(events(e)%nt),events(e)%tsc(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,events(e)%nt
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,events(e)%ts(k)%slip, &
+ events(e)%ts(k)%x,events(e)%ts(k)%y,events(e)%ts(k)%z, &
+ events(e)%ts(k)%length,events(e)%ts(k)%width, &
+ events(e)%ts(k)%strike,events(e)%ts(k)%dip
+ ! copy the input format for display
+ events(e)%tsc(k)=events(e)%ts(k)
+
+ PRINT '(I3.3,4ES9.2E1,2ES8.2E1,f7.1,f6.1)',k, &
+ events(e)%tsc(k)%slip,&
+ events(e)%tsc(k)%x,events(e)%tsc(k)%y,events(e)%tsc(k)%z, &
+ events(e)%tsc(k)%length,events(e)%tsc(k)%width, &
+ events(e)%tsc(k)%strike,events(e)%tsc(k)%dip
+
+ IF (i .ne. k) THEN
+ PRINT *, "error in input file: source index misfit"
+ STOP 1
+ END IF
+ IF (events(e)%ts(k)%length .lt. minlength) THEN
+ minlength=events(e)%ts(k)%length
+ END IF
+ IF (events(e)%ts(k)%width .lt. minwidth) THEN
+ minwidth =events(e)%ts(k)%width
+ END IF
+
+ ! smooth out the slip distribution
+ CALL antialiasingfilter(events(e)%ts(k)%slip, &
+ events(e)%ts(k)%length,events(e)%ts(k)%width, &
+ dx1,dx2,dx3,nyquist)
+
+ ! comply to Wang's convention
+ CALL wangconvention(events(e)%ts(k)%slip, &
+ events(e)%ts(k)%x,events(e)%ts(k)%y,events(e)%ts(k)%z, &
+ events(e)%ts(k)%length,events(e)%ts(k)%width, &
+ events(e)%ts(k)%strike,events(e)%ts(k)%dip,dummy,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,*) events(e)%nm
+ PRINT '(I5)', events(e)%nm
+ IF (events(e)%nm .GT. 0) THEN
+ ALLOCATE(events(e)%m(events(e)%nm),events(e)%mc(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,events(e)%nm
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i,events(e)%m(k)%slip, &
+ events(e)%m(k)%x,events(e)%m(k)%y,events(e)%m(k)%z
+ ! copy the input format for display
+ events(e)%mc(k)=events(e)%m(k)
+
+ PRINT '(I3.3,4ES9.2E1)',k, &
+ events(e)%mc(k)%slip,&
+ events(e)%mc(k)%x,events(e)%mc(k)%y,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(events(e)%m(k)%x,events(e)%m(k)%y,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,*) events(e)%nl
+ PRINT '(I5)', events(e)%nl
+ IF (events(e)%nl .GT. 0) THEN
+ ALLOCATE(events(e)%l(events(e)%nl),events(e)%lc(events(e)%nl), &
+ STAT=iostatus)
+ IF (iostatus>0) STOP "could not allocate the load list"
+ PRINT 2000
+ PRINT '(a)',"no. xs ys t3 (force/surface/rigidity, positive down)"
+ PRINT 2000
+ DO k=1,events(e)%nl
+ CALL getdata(iunit,dataline)
+ READ (dataline,*) i, &
+ events(e)%l(k)%x,events(e)%l(k)%y,events(e)%l(k)%slip
+ ! copy the input format for display
+ events(e)%lc(k)=events(e)%l(k)
+
+ PRINT '(I3.3,4ES9.2E1)',k, &
+ events(e)%lc(k)%x,events(e)%lc(k)%y,events(e)%lc(k)%slip
+
+ 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(events(e)%l(k)%x,events(e)%l(k)%y,rot)
+ END DO
+ PRINT 2000
+ END IF
+
+ END DO
+
+ ! test the presence of dislocations for coseismic calculation
+ IF ((events(1)%nt .EQ. 0) .AND. &
+ (events(1)%ns .EQ. 0) .AND. &
+ (events(1)%nm .EQ. 0) .AND. &
+ (events(1)%nl .EQ. 0) .AND. &
+ (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)")
+
+ END SUBROUTINE init
+
+ !--------------------------------------------------------------------
+ ! 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.
+ !
+ ! 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)) .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 based on user-defined
+ ! conditions. by default, time step is five times smaller than the
+ ! instantaneous Maxwell relaxation time. Time step can be reduced
+ ! so that next step corresponds to a following coseismic event.
+ !
+ ! sylvain barbot (01/01/08) - original form
+ !--------------------------------------------------------------------
+ SUBROUTINE integrationstep(tm,Dt,t,oi,odt,events,e,ne)
+ REAL*8, INTENT(INOUT) :: tm,Dt
+ REAL*8, INTENT(IN) :: t,odt
+ INTEGER, INTENT(IN) :: oi,e,ne
+ TYPE(EVENT_STRUC), INTENT(IN), DIMENSION(:) :: events
+
+ Dt=tm/10._8
+ IF (0 .EQ. skip) THEN
+ ! uniform output interval
+ IF ((t+Dt) .GE. (dble(oi)*odt)-Dt*0.04) THEN
+ ! pick a smaller time step to reach :
+ ! integers of odt
+ Dt=dble(oi)*odt-t
+ END IF
+ ELSE
+ ! output at optimal computational intervals
+ 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
+
+ !------------------------------------------------------------------
+ ! 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
+
+ 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.
+ !
+ ! 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
+
+ !------------------------------------------------------------------
+ ! 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,rot)
+ REAL*8, INTENT(OUT) :: slip, x,y,z,strike,dip,rake
+ REAL*8, INTENT(IN) :: length,width,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
+
+END PROGRAM relax
diff -r 000000000000 -r 56a2cd733fb8 relax.sh
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/relax.sh Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,53 @@
+#!/bin/sh
+
+time ./relax <<EOF
+# grid size (sx1,sx2,sx3)
+256 256 256
+# sampling size & smoothing (dx1,dx2,dx3,beta)
+0.05 0.05 0.05 0.2
+# origin position
+0 0
+# observation depth
+0
+# output directory
+./output
+# elastic parameters (lambda,mu)
+1 1
+# integration time (t1)
+20 0.5
+# number of observation planes
+0
+# number of observation points
+0
+# number of prestress interfaces
+0
+# number of linear viscous interfaces
+2
+1 1.0 0 0.0
+2 9.0 0 0.0
+# number of powerlaw viscous interfaces
+2
+1 1.0 1e1 3.0 0.0
+2 9.0 1e1 3.0 0.0
+# number of friction faults
+0
+# number of interseismic loading stuff
+0
+0
+# number of coseismic events
+2
+# number of shear dislocations
+1
+# index slip x1 x2 x3 length width strike dip rake
+ 1 1 -1.0 0 0 1 0.8 0 90 0
+# number of tensile cracks
+0
+# time of second event
+10
+# number of shear dislocations
+1
+# index slip x1 x2 x3 length width strike dip rake
+ 1 0.02 0.0 0 0 1 0.8 0 90 0
+# number of tensile cracks
+0
+EOF
diff -r 000000000000 -r 56a2cd733fb8 run1.sh
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/run1.sh Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,63 @@
+#!/bin/sh
+
+time ./relax <<EOF
+# grid size (sx1,sx2,sx3)
+256 256 256
+# sampling size & smoothing (dx1,dx2,dx3,beta,nyquist)
+5 5 5 0.25 2
+# origin position, rotation, lon lat
+0 0 0
+# geographic origin (longitude, latitude and zone)
+-120 34 11 1000
+# observation depth
+0 0
+# output directory
+./output1
+# elastic parameters and gamma
+1 1 0
+# integration time (t1) and time steps
+0 -1
+# number of observation planes
+0
+# number of observation points
+0
+# number of prestress interfaces with depth
+0
+# number of linear viscous interfaces
+2
+# no x3 gammadot0 cohesion
+ 1 200 1 0
+ 2 300 1 0
+# number of ductile shear zone
+2
+# no dgammadot0 x1 x2 x3 length width thickness strike dip
+ 1 1 0 0 100 100 100 50 0 90
+ 2 1 0 0 100 100 200 50 40 70
+# number of nonlinear viscous interfaces
+0
+# number of fault creep interfaces
+0
+# no depth gamma0 (a-b)sigma friction cohesion
+# 1 15 1 5e-1 0.6 0
+# number of afterslip planes
+#1
+# no x1 x2 x3 length width strike dip
+# 1 -50 -5 15 90 15 -25.4 90
+# number interseismic shear disloc
+0
+# number interseismic tensile cracks
+0
+# number of coseismic events
+1
+# number of shear dislocations
+1
+# no slip x1 x2 x3 length width strike dip rake
+ 1 1 -100 0 0 2e2 1e2 0 90 90
+# number of tensile cracks
+0
+# number of dilatation sources
+0
+# number of surface tractions
+0
+EOF
+
diff -r 000000000000 -r 56a2cd733fb8 template.sh
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/template.sh Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,51 @@
+#!/bin/sh
+
+time ./relax <<EOF
+# grid size (sx1,sx2,sx3)
+512 512 512
+# sampling size & smoothing (dx1,dx2,dx3,beta)
+1.0 1.0 1.0 0.2
+# origin position and rotation
+0 0 0
+# observation depth
+0
+# output directory
+./output
+# elastic parameters (lambda,mu)
+3e1 3e1
+# integration time (t1)
+1000 10
+# number of observation points
+12
+# index name x1 x2 x3
+ 1 GPS1 25 10 0
+ 2 GPS2 25 20 0
+ 3 GPS3 25 30 0
+ 4 GPS4 25 40 0
+ 5 GPS5 25 50 0
+ 6 GPS6 25 60 0
+ 7 GPS7 50 10 0
+ 8 GPS8 50 20 0
+ 9 GPS9 50 30 0
+ 10 GP10 50 40 0
+ 11 GP11 50 50 0
+ 12 GP12 50 60 0
+# number of layers
+2
+# index depth lambda mu gammadot0
+ 1 0 1 1 0.0
+ 1 20 1 1 1.0
+# number of shear dislocations
+4
+# index slip x1 x2 x3 length width strike dip rake
+ 1 2 0 -40 0 80 5 90 90 0
+ 2 1 0 -40 5 80 5 90 90 0
+ 3 0.5 0 -40 10 80 5 90 90 0
+ 4 0.01 0 -40 15 80 5 90 90 0
+# number of tensile cracks
+1
+# index opening x1 x2 x3 length width strike dip
+ 1 -1 0 -40 5 80 40 90 40
+EOF
+
+
diff -r 000000000000 -r 56a2cd733fb8 viscoelastic3d.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/viscoelastic3d.f90 Thu Jan 06 15:36:19 2011 -0800
@@ -0,0 +1,283 @@
+!-----------------------------------------------------------------------
+! 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.
+ !
+ ! 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.)
+ !
+ ! sylvain barbot (08/30/08) - original form
+ !-----------------------------------------------------------------
+ SUBROUTINE viscouseigenstress(mu,structure,ductilezones,sig,sx1,sx2,sx3, &
+ dx1,dx2,dx3,moment,beta,maxwelltime,gamma)
+ REAL*8, INTENT(IN) :: mu,dx1,dx2,dx3,beta
+ TYPE(LAYER_STRUCT), DIMENSION(:), INTENT(IN) :: structure
+ TYPE(WEAK_STRUCT), DIMENSION(:), 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,x1,x2,x3,beta)
+
+ ! local fluidity structure
+ gammadot0=gammadot0+dg0
+
+ IF (1e-9 .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. 1e-9) 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).
+ !
+ ! sylvain barbot (3/29/10) - original form
+ !---------------------------------------------------------
+ REAL*8 FUNCTION dgammadot0(zones,x1,x2,x3,beta)
+ TYPE(WEAK_STRUCT), INTENT(IN), DIMENSION(:) :: 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 :: n,i
+
+ ! number of ductile zones
+ n=SIZE(zones,1)
+
+ ! 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 000000000000 -r 56a2cd733fb8 writegrd3.4.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/writegrd3.4.c Thu Jan 06 15:36:19 2011 -0800
@@ -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 000000000000 -r 56a2cd733fb8 writegrd4.2.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/writegrd4.2.c Thu Jan 06 15:36:19 2011 -0800
@@ -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); */
+
+ }
+
More information about the CIG-COMMITS
mailing list