Repository: geodynamics/seismic_cpml Branch: master Commit: 0d89aa3132f2 Files: 29 Total size: 1.3 MB Directory structure: gitextract_pzg7djl1/ ├── .gitignore ├── AUTHORS ├── LICENSE ├── Makefile ├── README ├── README_seismic_cpml.html ├── analytical_solution_viscoacoustic_Carcione_version1.f90 ├── analytical_solution_viscoelastic_2D_plane_strain_Carcione_correct_with_1_over_L.f90 ├── attenuation_model_with_SolvOpt.f90 ├── conversion_between_Qp_Qs_and_Qkappa_Qmu_from_Dahlen_Tromp_959_960_in_3D_and_in_2D_plane_strain.f90 ├── email_from_Youshan_Liu_about_bug_in_the_original_fourth_order_Runge_Kutta_scheme.txt ├── explanation_from_Youshan_Liu_about_bug_in_the_original_fourth_order_Runge_Kutta_scheme.docx ├── plotall_fit_is_perfect_for_viscoelastic_fourth_order.gnu ├── seismic_ADEPML_2D_elastic_RK4_eighth_order.f90 ├── seismic_ADEPML_2D_viscoelastic_RK4_eighth_order.f90 ├── seismic_CPML_2D_anisotropic.f90 ├── seismic_CPML_2D_isotropic_fourth_order.f90 ├── seismic_CPML_2D_isotropic_second_order.f90 ├── seismic_CPML_2D_poroelastic_fourth_order.f90 ├── seismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic.f90 ├── seismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic.f90 ├── seismic_CPML_2D_pressure_second_order.f90 ├── seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic.f90 ├── seismic_CPML_2D_velocity_and_stress_second_order_viscoelastic.f90 ├── seismic_CPML_3D_isotropic_MPI_OpenMP.f90 ├── seismic_CPML_3D_viscoelastic_MPI.f90 ├── seismic_PML_Collino_2D_anisotropic_fourth.f90 ├── seismic_PML_Collino_2D_isotropic.f90 └── seismic_PML_Collino_3D_isotropic_OpenMP.f90 ================================================ FILE CONTENTS ================================================ ================================================ FILE: .gitignore ================================================ # 2D xseismic_CPML_2D_isotropic_second_order xseismic_CPML_2D_isotropic_fourth_order xseismic_CPML_2D_anisotropic xseismic_PML_Collino_2D_isotropic xseismic_PML_Collino_2D_anisotropic_fourth xseismic_ADEPML_2D_elastic_RK4_eighth_order xseismic_ADEPML_2D_viscoelastic_RK4_eighth_order # 3D xseismic_CPML_3D_isotropic_MPI_OpenMP xseismic_CPML_2D_poroelastic_fourth_order xseismic_CPML_3D_viscoelastic_MPI xseismic_PML_Collino_3D_isotropic_OpenMP ================================================ FILE: AUTHORS ================================================ Main historical authors: Dimitri Komatitsch, CNRS / University of Marseille, France and Roland Martin, CNRS / University of Toulouse, France, but several other people have contributed since then, see the comments at the beginning of each of the Fortran source files. ================================================ FILE: LICENSE ================================================ GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. 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. Copyright (C) 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 . 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: Copyright (C) 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 . 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 . ================================================ FILE: Makefile ================================================ # # Makefile for SEISMIC_CPML Version 1.2, April 2015. # Dimitri Komatitsch, CNRS, France # SHELL=/bin/sh O = obj # the MEDIUM_MEMORY flag is for large 3D runs, which need more than 2 GB of memory # Portland #F90 = pgf90 #MPIF90 = mpif90 #FLAGS = -fast -Mnobounds -Minline -Mneginfo -Mdclchk -Knoieee -Minform=warn -fastsse -tp amd64e -Msmart #MEDIUM_MEMORY = -mcmodel=medium #OPEN_MP = -mp # Intel (leave option -ftz, which can be *critical* for performance) #F90 = ifort #MPIF90 = mpif90 #FLAGS = -O3 -xHost -vec-report0 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -ftz -stand f03 #FLAGS = -check all -debug -g -O0 -fp-stack-check -traceback -ftrapuv -vec-report0 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -ftz -stand f03 #MEDIUM_MEMORY = -mcmodel=medium #OPEN_MP = -openmp -openmp-report1 # IBM xlf #F90 = xlf_r #MPIF90 = mpxlf_r #FLAGS = -O3 -qfree=f90 -qhalt=w -qsave #MEDIUM_MEMORY = -q64 #OPEN_MP = -qsmp=omp # GNU gfortran F90 = gfortran MPIF90 = mpif90 FLAGS = -std=gnu -fimplicit-none -frange-check -O3 -fmax-errors=10 -pedantic -pedantic-errors -Waliasing -Wampersand -Wcharacter-truncation -Wline-truncation -Wsurprising -Wno-tabs -Wunderflow MEDIUM_MEMORY = -mcmodel=medium #OPEN_MP = -fopenmp default: clean seismic_CPML_2D_pressure_second_order seismic_CPML_2D_isotropic_second_order seismic_CPML_2D_isotropic_fourth_order seismic_CPML_2D_anisotropic seismic_PML_Collino_2D_isotropic seismic_PML_Collino_3D_isotropic_OpenMP seismic_CPML_3D_isotropic_MPI_OpenMP seismic_CPML_2D_poroelastic_fourth_order seismic_CPML_3D_viscoelastic_MPI seismic_PML_Collino_2D_anisotropic_fourth seismic_ADEPML_2D_elastic_RK4_eighth_order seismic_ADEPML_2D_viscoelastic_RK4_eighth_order seismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic seismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic seismic_CPML_2D_velocity_and_stress_second_order_viscoelastic all: default clean: /bin/rm -f *.o xseismic_CPML_2D_pressure_second_order xseismic_CPML_2D_isotropic_second_order xseismic_CPML_2D_isotropic_fourth_order xseismic_CPML_2D_anisotropic xseismic_PML_Collino_2D_isotropic xseismic_CPML_3D_isotropic_MPI_OpenMP xseismic_PML_Collino_3D_isotropic_OpenMP xseismic_CPML_2D_poroelastic_fourth_order xseismic_CPML_3D_viscoelastic_MPI xseismic_PML_Collino_2D_anisotropic_fourth xseismic_ADEPML_2D_elastic_RK4_eighth_order xseismic_ADEPML_2D_viscoelastic_RK4_eighth_order xseismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic xseismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic xseismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic xseismic_CPML_2D_velocity_and_stress_second_order_viscoelastic seismic_CPML_2D_velocity_and_stress_second_order_viscoelastic: $(F90) $(FLAGS) -o xseismic_CPML_2D_velocity_and_stress_second_order_viscoelastic seismic_CPML_2D_velocity_and_stress_second_order_viscoelastic.f90 seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic: $(F90) $(FLAGS) -o xseismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic.f90 seismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic: $(F90) $(FLAGS) -o xseismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic seismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic.f90 seismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic: $(F90) $(FLAGS) -o xseismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic seismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic.f90 seismic_ADEPML_2D_elastic_RK4_eighth_order: $(F90) $(FLAGS) -o xseismic_ADEPML_2D_elastic_RK4_eighth_order seismic_ADEPML_2D_elastic_RK4_eighth_order.f90 seismic_ADEPML_2D_viscoelastic_RK4_eighth_order: $(F90) $(FLAGS) -o xseismic_ADEPML_2D_viscoelastic_RK4_eighth_order seismic_ADEPML_2D_viscoelastic_RK4_eighth_order.f90 seismic_CPML_2D_poroelastic_fourth_order: $(F90) $(FLAGS) -o xseismic_CPML_2D_poroelastic_fourth_order seismic_CPML_2D_poroelastic_fourth_order.f90 seismic_CPML_2D_pressure_second_order: $(F90) $(FLAGS) -o xseismic_CPML_2D_pressure_second_order seismic_CPML_2D_pressure_second_order.f90 seismic_CPML_2D_isotropic_second_order: $(F90) $(FLAGS) -o xseismic_CPML_2D_isotropic_second_order seismic_CPML_2D_isotropic_second_order.f90 seismic_CPML_2D_isotropic_fourth_order: $(F90) $(FLAGS) -o xseismic_CPML_2D_isotropic_fourth_order seismic_CPML_2D_isotropic_fourth_order.f90 seismic_CPML_2D_anisotropic: $(F90) $(FLAGS) -o xseismic_CPML_2D_anisotropic seismic_CPML_2D_anisotropic.f90 seismic_PML_Collino_2D_isotropic: $(F90) $(FLAGS) -o xseismic_PML_Collino_2D_isotropic seismic_PML_Collino_2D_isotropic.f90 seismic_PML_Collino_2D_anisotropic_fourth: $(F90) $(FLAGS) -o xseismic_PML_Collino_2D_anisotropic_fourth seismic_PML_Collino_2D_anisotropic_fourth.f90 seismic_PML_Collino_3D_isotropic_OpenMP: $(F90) $(FLAGS) $(MEDIUM_MEMORY) $(OPEN_MP) -o xseismic_PML_Collino_3D_isotropic_OpenMP seismic_PML_Collino_3D_isotropic_OpenMP.f90 seismic_CPML_3D_isotropic_MPI_OpenMP: $(MPIF90) $(FLAGS) $(MEDIUM_MEMORY) $(OPEN_MP) -o xseismic_CPML_3D_isotropic_MPI_OpenMP seismic_CPML_3D_isotropic_MPI_OpenMP.f90 seismic_CPML_3D_viscoelastic_MPI: $(MPIF90) $(FLAGS) $(MEDIUM_MEMORY) $(OPEN_MP) -o xseismic_CPML_3D_viscoelastic_MPI seismic_CPML_3D_viscoelastic_MPI.f90 ================================================ FILE: README ================================================ seismic_cpml ============ SEISMIC_CPML is a set of twelve open-source Fortran90 programs to solve the two-dimensional or three-dimensional isotropic or anisotropic elastic, viscoelastic or poroelastic wave equation using a finite-difference method with Convolutional or Auxiliary Perfectly Matched Layer (C-PML or ADE-PML) conditions, developed by Dimitri Komatitsch and Roland Martin from CNRS, France. See README_seismic_cpml.html in this directory for more details. ================================================ FILE: README_seismic_cpml.html ================================================ The SEISMIC_CPML software package

Home page of Dimitri Komatitsch

 

SEISMIC_CPML is a set of fourteen open-source Fortran90 programs under the GNU GPL version 3 license to solve the two-dimensional or three-dimensional isotropic or anisotropic acoustic, elastic, viscoelastic or poroelastic wave equation using a finite-difference method with Convolutional or Auxiliary Perfectly Matched Layer (C-PML or ADE-PML) conditions, developed by Dimitri Komatitsch and Roland Martin from CNRS, France. Contributions by other authors have recently been added.

You can get the full source code of the programs at the official Web site: http://geodynamics.org/cig/software/seismic_cpml

The codes are then self-explanatory and very easy to use; to understand how to use them just edit the source codes and read the comments they contain.

The unsplit Convolutional Perfectly Matched Layer (C-PML) for the 3D elastic wave equation was introduced and is described in detail in:

Dimitri Komatitsch and Roland Martin, An unsplit convolutional Perfectly Matched Layer improved at grazing incidence for the seismic wave equation, Geophysics, vol. 72(5), p SM155-SM167, doi: 10.1190/1.2757586 (2007). Preprint BibTeX

It was originally developed for Maxwell's equations by Roden and Gedney (2000) (see reference below).

An extension to viscoelastic media is developed in:

Roland Martin and Dimitri Komatitsch, An unsplit convolutional perfectly matched layer technique improved at grazing incidence for the viscoelastic wave equation, Geophysical Journal International, vol. 179(1), p. 333-344, doi: 10.1111/j.1365-246X.2009.04278.x (2009). Preprint BibTeX

and the viscoelastic parameters of the Zener body model used to fit a constant-Q model are computed based upon:

Émilie Blanc, Dimitri Komatitsch, Emmanuel Chaljub, Bruno Lombard and Zhinan Xie, Highly-accurate stability-preserving optimization of the Zener viscoelastic model, with application to wave propagation in the presence of strong attenuation, Geophysical Journal International, vol. 205(1), p. 427-439, doi: 10.1093/gji/ggw024 (2016). Preprint BibTeX



An extension to poroelastic media is developed in:

Roland Martin, Dimitri Komatitsch and Abdelaâziz Ezziani, An unsplit convolutional Perfectly Matched Layer improved at grazing incidence for seismic wave propagation in poroelastic media, Geophysics, vol. 73(4), p T51-T61, doi: 10.1190/1.2939484 (2008). Preprint BibTeX

and a variational formulation is developed in:

Roland Martin, Dimitri Komatitsch and Stephen D. Gedney, A variational formulation of a stabilized unsplit convolutional perfectly matched layer for the isotropic or anisotropic seismic wave equation, Computer Modeling in Engineering and Sciences, vol. 37(3), p. 274-304 (2008). Preprint BibTeX

An extension to higher-order time schemes, called ADE-PML (Auxiliary Differential Equation - PML) is developed in:

Roland Martin, Dimitri Komatitsch, Stephen D. Gedney and Émilien Bruthiaux, A high-order time and space formulation of the unsplit perfectly matched layer for the seismic wave equation using Auxiliary Differential Equations (ADE-PML), Computer Modeling in Engineering and Sciences, vol. 56(1), p. 17-42 (2010). Preprint BibTeX

Note that in the case of an anisotropic medium the modification made is not strictly speaking perfectly matched any more, i.e., not a PML, but rather a “Modified PML / M-PML” based on Meza-Fajardo and Papageorgiou, Bulletin of the Seismological Society of America, vol. 98(4), p. 1811-1836 (2008). However, it works well in practice even if it is not perfectly matched any more from a mathematical point of view.

IMPORTANT: all of our codes are written in Fortran; if you have written or if you write a C or C++ version of some of these codes and want to make them open source (GNU GPL version 3) and part of the package, please do not hesitate to send them to us, we will add them to our tar file and will acknowledge you as the author.

This software is governed by the GNU GPL version 3 license.

If you use this code for your own research, please cite some (or all) of these articles:

@ARTICLE{BlKoChLoXi16,
title = {Highly accurate stability-preserving optimization of the {Z}ener viscoelastic model, with application to wave propagation in the presence of strong attenuation},
author = {\'Emilie Blanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard and Zhinan Xie},
journal = {Geophysical Journal International},
year = {2016},
number = {1},
pages = {427-439},
volume = {205},
doi = {10.1093/gji/ggw024}}

@ARTICLE{MaKo09,
author = {Roland Martin and Dimitri Komatitsch},
title = {An unsplit convolutional perfectly matched layer technique improved at grazing incidence for the viscoelastic wave equation},
journal = {Geophysical Journal International},
year = {2009},
volume = {179},
number = {1},
pages = {333-344},
doi = {10.1111/j.1365-246X.2009.04278.x}}

@ARTICLE{MaKoEz08,
author = {Roland Martin and Dimitri Komatitsch and Abdelaaziz Ezziani},
title = {An unsplit convolutional perfectly matched layer improved at grazing incidence for seismic wave equation in poroelastic media},
journal = {Geophysics},
year = {2008},
volume = {73},
pages = {T51-T61},
number = {4},
doi = {10.1190/1.2939484}}

@ARTICLE{MaKoGe08,
author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},
title = {A variational formulation of a stabilized unsplit convolutional perfectly matched layer for the isotropic or anisotropic seismic wave equation},
journal = {Computer Modeling in Engineering and Sciences},
year = {2008},
volume = {37},
pages = {274-304},
number = {3}}

@ARTICLE{MaKoGeBr10,
author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney and Emilien Bruthiaux},
title = {A high-order time and space formulation of the unsplit perfectly matched layer for the seismic wave equation using {Auxiliary Differential Equations (ADE-PML)}},
journal = {Computer Modeling in Engineering and Sciences},
year = {2010},
volume = {56},
pages = {17-42},
number = {1}}

@ARTICLE{KoMa07,
author = {Dimitri Komatitsch and Roland Martin},
title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved at grazing incidence for the seismic wave equation},
journal = {Geophysics},
year = {2007},
volume = {72},
number = {5},
pages = {SM155-SM167},
doi = {10.1190/1.2757586}}



Roden and Gedney's original article for Maxwell's equations is:


@ARTICLE{RoGe00,
author = {J. A. Roden and S. D. Gedney},
title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation of the {CFS}-{PML} for Arbitrary Media},
journal = {Microwave and Optical Technology Letters},
year = {2000},
volume = {27},
number = {5},
pages = {334-339},
doi = {10.1002/1098-2760(20001205)27:5<334::AID-MOP14>3.0.CO;2-A}}


The package is composed of the following fourteen programs:



seismic_CPML_2D_pressure_second_order.f90: 2D C-PML program for an acoustic medium using a second-order finite-difference spatial operator for the pressure equation written as a second-order system in time.

seismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic.f90: 2D C-PML program for a viscoacoustic medium using a second-order finite-difference spatial operator for the velocity and pressure equation written as a split first-order system in time.

seismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic.f90: 2D C-PML program for a viscoacoustic medium using a fourth-order finite-difference spatial operator for the velocity and pressure equation written as a split first-order system in time.

seismic_CPML_2D_isotropic_second_order.f90: 2D C-PML program for an elastic isotropic medium using a second-order finite-difference spatial operator.

seismic_CPML_2D_isotropic_fourth_order.f90: 2D C-PML program for an elastic isotropic medium using a fourth-order finite-difference spatial operator.

seismic_CPML_2D_anisotropic.f90: 2D C-PML program for an elastic anisotropic medium using a second-order finite-difference spatial operator. More precisely we implement a “Modified PML / M-PML” based on Meza-Fajardo and Papageorgiou, Bulletin of the Seismological Society of America, vol. 98(4), p. 1811-1836 (2008). Strictly speaking the layers are not perfectly matched any more from a mathematical point of view, but the code works well in practice.

seismic_CPML_2D_poroelastic_fourth_order.f90: 2D C-PML program for a poroelastic medium using a fourth-order finite-difference spatial operator.

seismic_ADEPML_2D_elastic_RK4_eighth_order.f90: 2D ADE-PML program for an isotropic elastic medium using an eighth-order finite-difference spatial operator and fourth-order Runge-Kutta implicit, semi implicit or explicit time scheme.

seismic_ADEPML_2D_viscoelastic_RK4_eighth_order.f90: 2D ADE-PML program for an isotropic viscoelastic medium using an eighth-order finite-difference spatial operator and fourth-order Runge-Kutta implicit, semi implicit or explicit time scheme.

seismic_PML_Collino_2D_isotropic.f90: 2D classical split PML program for an isotropic medium using a second-order finite-difference spatial operator, for comparison.

seismic_PML_Collino_2D_anisotropic_fourth.f90: 2D classical split PML program for an anisotropic medium using a fourth-order finite-difference spatial operator, for comparison.

seismic_CPML_3D_isotropic_MPI_OpenMP.f90: 3D C-PML program for an isotropic medium using a second-order finite-difference spatial operator. Parallel implementation based on both MPI and OpenMP.

seismic_PML_Collino_3D_isotropic_OpenMP.f90: 3D classical split PML program for an isotropic medium using a second-order finite-difference spatial operator, for comparison. Parallel implementation based on OpenMP.

seismic_CPML_3D_viscoelastic_MPI.f90: 3D C-PML program for a viscoelastic medium using a fourth-order finite-difference spatial operator. Parallel implementation based on MPI.

Makefile: a standard Makefile. You can type “make all” to compile all the codes.

For more details about the classical PML, see for instance Wikipedia about PML.

For more details about finite differences in the time domain (FDTD), see for instance Wikipedia about FDTD.

Home page of Dimitri Komatitsch

================================================ FILE: analytical_solution_viscoacoustic_Carcione_version1.f90 ================================================ program analytical_solution !! DK DK to compare to our finite-difference codes from SEISMIC_CPML or SOUNDVIEW, !! DK DK we divide the source by 4 * PI * cp^2 to get the right amplitude (our convention being to use a source of amplitude 1, !! DK DK while the convention used by Carcione in his 1988 paper is to use a source of amplitude 4 * PI * cp^2 ! this program implements the analytical solution for a viscoacoustic medium ! from Carcione et al., Wave propagation simulation in a linear viscoacoustic medium, ! Geophysical Journal, vol. 93, p. 393-407 (1988) !! DK DK Dimitri Komatitsch, CNRS Marseille, France, April 2017 !! DK DK adapted from a program written for the viscoelastic case by Jose' M. Carcione. implicit none ! compute the non-viscoacoustic case as a reference if needed, i.e. turn attenuation off logical, parameter :: TURN_ATTENUATION_OFF = .false. ! .true. !! DK DK Dimitri Komatitsch, CNRS Marseille, France, October 2015: !! DK DK by default I turned off the fix for attenuation causality (using the unrelaxed velocities !! DK DK as reference instead of the relaxed ones) because it is not useful any more, !! DK DK this modification was not consistent with the calculations of the tau values !! DK DK made by Carcione et al. 1988 and by Carcione 1993. !! Comment from Quentin Brissaud, March 2018: !! This flag will tell the code that the input velocities are the relaxed one (omega -> zero frequency) !! instead of the unrelaxed ones (by default omega -> + infinity) logical, parameter :: FIX_ATTENUATION_CAUSALITY = .true. integer, parameter :: iratio = 64 integer, parameter :: nfreq = 524288 integer, parameter :: nt = iratio * nfreq double precision, parameter :: freqmax = 1000.d0 ! 225.d0 !! DK DK to print the velocity if we want to display the curve of how velocity varies with frequency !! DK DK for instance to compute the unrelaxed velocity in the Zener model ! double precision, parameter :: freqmax = 20000.d0 double precision, parameter :: freqseuil = 0.00005d0 double precision, parameter :: pi = 3.141592653589793d0 ! for the solution in time domain integer it real wsave(4*nt+15) complex c(nt) !! DK DK for my slow inverse Discrete Fourier Transform using a double loop complex :: input(nt), i_imaginary_constant integer :: j,m ! density of the medium double precision, parameter :: rho = 2000.d0 ! definition position recepteur Carcione double precision x1,x2 ! Definition source Dimitri double precision, parameter :: f0 = 35.d0 double precision, parameter :: t0 = 1.2d0 / f0 ! Definition source Carcione ! double precision f0,t0,eta,epsil ! parameter(f0 = 50.d0) ! parameter(t0 = 0.06d0) ! parameter(epsil = 1.d0) ! parameter(eta = 0.5d0) ! number of Zener standard linear solids in parallel ! integer, parameter :: L_mech = 5 integer, parameter :: L_mech = 3 ! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform ! DK DK at some point, for verification, using a double loop. I keep it just in case. ! DK DK For large number of points it is extremely slow because of the double loop. ! DK DK Thus there is no reason to turn this flag on. logical, parameter :: USE_SLOW_FOURIER_TRANSFORM = .false. ! attenuation constants from Carcione 1988 GJI vol 95 p 604 double precision, dimension(L_mech) :: tau_epsilon_nu1, tau_sigma_nu1 ! this value comes from page 397 of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium, ! Geophysical Journal, vol. 93, p. 393-407 (1988) double precision, parameter :: vp = 2000.d0 double precision, parameter :: M_relaxed = rho*vp**2 integer :: ifreq,i_mech,iposition double precision :: deltafreq,freq,omega,omega0,deltat,time,a,sum_of_coefficients double complex :: comparg,sum_to_compute ! Fourier transform of the Ricker wavelet source double complex fomega(0:nfreq) ! real and imaginary parts double precision ra(0:nfreq),rb(0:nfreq) ! spectral amplitude double precision ampli(0:nfreq) ! analytical solution for the single scalar component (pressure) double complex phi1(-nfreq:nfreq) ! external functions double complex, external :: u1 ! modules elastiques double complex :: MC, V1 ! ********** end of variable declarations ************ !! DK DK July 2018: values computed to fit Q = 65 for the example I designed for the "SOUNDVIEW" finite-difference code tau_epsilon_nu1 = (/ 2.408158185805540d-002, 4.699608990946073d-003, 9.567997872679109d-004/) tau_sigma_nu1 = (/ 2.256014638685252d-002, 4.508471279793884d-003, 8.937876403997143d-004/) ! position of the receiver do iposition = 1,3 if (iposition == 1) then x1 = +200. x2 = +200. else if (iposition == 2) then x1 = +500. x2 = +500. else !!!!!!!! x1 = +800. !!!!!!!! x2 = +800. !! DK DK modified to fall exactly on a grid point x1 = +801. x2 = +801. endif print *,'Pressure source located at the origin (0,0)' print *,'Receiver located in (x,z) = ',x1,x2 if (TURN_ATTENUATION_OFF) then print *,'BEWARE: computing the acoustic reference solution (i.e., without attenuation) instead of the viscoacoustic solution' else print *,'Computing the viscoacoustic solution' endif ! step in frequency deltafreq = freqmax / dble(nfreq) ! define parameters for the Ricker source omega0 = 2.d0 * pi * f0 a = pi**2 * f0**2 deltat = 1.d0 / (freqmax*dble(iratio)) print *,'deltat = ',deltat ! define the spectrum of the source do ifreq=0,nfreq freq = deltafreq * dble(ifreq) omega = 2.d0 * pi * freq ! typo in equation (B10) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium, ! Geophysical Journal, vol. 93, p. 393-407 (1988), the exponential is of -i omega t0, ! fixed here by adding the minus sign comparg = dcmplx(0.d0,-omega*t0) ! definir le spectre du Ricker de Carcione avec cos() ! equation (B10) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium, ! Geophysical Journal, vol. 93, p. 393-407 (1988) ! fomega(ifreq) = pi * dsqrt(pi/eta) * (1.d0/omega0) * cdexp(comparg) * ( dexp(- (pi*pi/eta) * (epsil/2 - omega/omega0)**2) & ! + dexp(- (pi*pi/eta) * (epsil/2 + omega/omega0)**2) ) ! definir le spectre d'un Ricker classique (centre en t0) fomega(ifreq) = dsqrt(pi) * cdexp(comparg) * omega**2 * dexp(-omega**2/(4.d0*a)) / (2.d0 * dsqrt(a**3)) !! DK DK to compare to our finite-difference codes from SEISMIC_CPML or SOUNDVIEW, !! DK DK we divide the source by 4 * PI * cp^2 to get the right amplitude (our convention being to use a source of amplitude 1, !! DK DK while the convention used by Carcione in his 1988 paper is to use a source of amplitude 4 * PI * cp^2 fomega(ifreq) = fomega(ifreq) / (4.d0 * PI * vp**2) ra(ifreq) = dreal(fomega(ifreq)) rb(ifreq) = dimag(fomega(ifreq)) ! prendre le module de l'amplitude spectrale ampli(ifreq) = dsqrt(ra(ifreq)**2 + rb(ifreq)**2) enddo ! sauvegarde du spectre d'amplitude de la source en Hz au format Gnuplot open(unit=10,file='spectrum_of_the_source_used.gnu',status='unknown') do ifreq = 0,nfreq freq = deltafreq * dble(ifreq) write(10,*) sngl(freq),sngl(ampli(ifreq)) enddo close(10) ! ************** calcul solution analytique **************** ! d'apres Carcione GJI vol 95 p 611 (1988) do ifreq=0,nfreq freq = deltafreq * dble(ifreq) omega = 2.d0 * pi * freq ! critere ad-hoc pour eviter singularite en zero if (freq < freqseuil) omega = 2.d0 * pi * freqseuil ! equation (16) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium, ! Geophysical Journal, vol. 93, p. 393-407 (1988) sum_to_compute = dcmplx(0.d0,0.d0) do i_mech = 1,L_mech sum_to_compute = sum_to_compute + dcmplx(1.d0,omega*tau_epsilon_nu1(i_mech)) / dcmplx(1.d0,omega*tau_sigma_nu1(i_mech)) enddo !! DK DK Quentin Brissaud in March 2018 added the 1/L factor here (it is missing in Carcione's older papers) MC = M_relaxed * (1.d0 + (1./L_mech)*(-L_mech + sum_to_compute)) ! use more standard infinite frequency (unrelaxed) reference, ! in which waves slow down when attenuation is turned on, ! or use far less standard zero frequency (relaxed) reference, ! in which waves speed up when attenuation is turned on if (FIX_ATTENUATION_CAUSALITY) then sum_of_coefficients = 0.d0 do i_mech = 1,L_mech sum_of_coefficients = sum_of_coefficients + tau_epsilon_nu1(i_mech) / tau_sigma_nu1(i_mech) enddo !! DK DK Quentin Brissaud in March 2018 added the 1/L factor here (it is missing in Carcione's older papers) MC = MC / (1.d0 + (1./L_mech)*(-L_mech + sum_of_coefficients)) endif ! equation (18) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium, ! Geophysical Journal, vol. 93, p. 393-407 (1988) V1 = cdsqrt(MC / rho) ! compute the non-viscoacoustic case as a reference if needed, i.e. turn attenuation off if (TURN_ATTENUATION_OFF) V1 = cdsqrt(dcmplx(M_relaxed,0.d0) / rho) ! calcul de la solution analytique en frequence phi1(ifreq) = u1(omega,V1,x1,x2) * fomega(ifreq) enddo ! take the conjugate value for negative frequencies do ifreq=-nfreq,-1 phi1(ifreq) = dconjg(phi1(-ifreq)) enddo ! save the result in the frequency domain ! open(unit=11,file='cmplx_phi',status='unknown') ! do ifreq=-nfreq,nfreq ! freq = deltafreq * dble(ifreq) ! write(11,*) sngl(freq),sngl(dreal(phi1(ifreq))),sngl(dimag(phi1(ifreq))) ! enddo ! close(11) ! *************************************************************************** ! Calculation of the time domain solution (using routine "cfftb" from Netlib) ! *************************************************************************** ! **************** ! Compute pressure ! **************** ! initialize FFT arrays call cffti(nt,wsave) ! clear array of Fourier coefficients do it = 1,nt c(it) = cmplx(0.,0.) enddo ! use the Fourier values for pressure c(1) = cmplx(phi1(0)) do ifreq=1,nfreq-2 c(ifreq+1) = cmplx(phi1(ifreq)) c(nt+1-ifreq) = conjg(cmplx(phi1(ifreq))) enddo ! perform the inverse FFT for pressure if (.not. USE_SLOW_FOURIER_TRANSFORM) then call cfftb(nt,c,wsave) else ! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform here ! DK DK at some point, for verification, using a double loop. I keep it just in case. ! DK DK For large number of points it is extremely slow because of the double loop. input(:) = c(:) ! imaginary constant "i" i_imaginary_constant = (0.,1.) do it = 1,nt if (mod(it,1000) == 0) print *,'FFT inverse it = ',it,' out of ',nt j = it c(j) = cmplx(0.,0.) do m = 1,nt c(j) = c(j) + input(m) * exp(2.d0 * PI * i_imaginary_constant * dble((m-1) * (j-1)) / nt) enddo enddo endif ! in the inverse Discrete Fourier transform one needs to divide by N, the number of samples (number of time steps here) c(:) = c(:) / nt ! value of a time step deltat = 1.d0 / (freqmax*dble(iratio)) ! to get the amplitude right, we need to divide by the time step c(:) = c(:) / deltat ! save time result inverse FFT for pressure if (iposition == 1) then if (TURN_ATTENUATION_OFF) then open(unit=11,file='pressure_time_analytical_solution_acoustic_200.dat',status='unknown') else open(unit=11,file='pressure_time_analytical_solution_viscoacoustic_200.dat',status='unknown') endif else if (iposition == 2) then if (TURN_ATTENUATION_OFF) then open(unit=11,file='pressure_time_analytical_solution_acoustic_500.dat',status='unknown') else open(unit=11,file='pressure_time_analytical_solution_viscoacoustic_500.dat',status='unknown') endif else if (TURN_ATTENUATION_OFF) then open(unit=11,file='pressure_time_analytical_solution_acoustic_800.dat',status='unknown') else open(unit=11,file='pressure_time_analytical_solution_viscoacoustic_800.dat',status='unknown') endif endif do it=1,nt ! DK DK Dec 2011: subtract t0 to be consistent with the SPECFEM2D code time = dble(it-1)*deltat - t0 ! the seismograms are very long due to the very large number of FFT points used, ! thus keeping the useful part of the signal only (the first six seconds of the seismogram) if (time >= 0.d0 .and. time <= 6.d0) write(11,*) sngl(time),real(c(it)) enddo close(11) print *,'Maximum positive amplitude of the time-domain solution = ',maxval(real(c(:))) print * enddo ! of loop on the three positions of the receiver end ! ----------- double complex function u1(omega,v1,x1,x2) implicit none double precision omega double complex v1 double complex G1 external G1 double precision x1,x2,r ! source-receiver distance r = dsqrt(x1**2 + x2**2) ! equation (B8a) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium, ! Geophysical Journal, vol. 93, p. 393-407 (1988) u1 = G1(r,omega,v1) end ! ----------- double complex function G1(r,omega,v1) implicit none double precision r,omega double complex v1 double complex hankel0 external hankel0 double precision pi parameter (pi = 3.141592653589793d0) ! equation (B8a) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium, ! Geophysical Journal, vol. 93, p. 393-407 (1988) G1 = hankel0(omega*r/v1) * dcmplx(0.d0,-pi) end ! ----------- double complex function hankel0(z) implicit none double complex z ! on utilise la routine NAG appelee S17DLE (simple precision) integer ifail,nz complex result ifail = -1 call S17DLE(2,0.0,cmplx(z),1,'U',result,nz,ifail) if (ifail /= 0) stop 'S17DLE failed in hankel0' if (nz > 0) print *,nz,' termes mis a zero par underflow' hankel0 = dcmplx(result) end ! ***************** routine de FFT pour signal en temps **************** ! FFT routine taken from Netlib subroutine CFFTB (N,C,WSAVE) DIMENSION C(1) ,WSAVE(1) if (N == 1) return IW1 = N+N+1 IW2 = IW1+N+N CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) END subroutine CFFTB1 (N,C,CH,WA,IFAC) DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1) NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDOT = IDO+IDO IDL1 = IDOT*L1 if (IP /= 4) goto 103 IX2 = IW+IDOT IX3 = IX2+IDOT if (NA /= 0) goto 101 CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) goto 102 101 CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA goto 115 103 if (IP /= 2) goto 106 if (NA /= 0) goto 104 CALL PASSB2 (IDOT,L1,C,CH,WA(IW)) goto 105 104 CALL PASSB2 (IDOT,L1,CH,C,WA(IW)) 105 NA = 1-NA goto 115 106 if (IP /= 3) goto 109 IX2 = IW+IDOT if (NA /= 0) goto 107 CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) goto 108 107 CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA goto 115 109 if (IP /= 5) goto 112 IX2 = IW+IDOT IX3 = IX2+IDOT IX4 = IX3+IDOT if (NA /= 0) goto 110 CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) goto 111 110 CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA goto 115 112 if (NA /= 0) goto 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) goto 114 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 if (NAC /= 0) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDOT 116 continue if (NA == 0) return N2 = N+N DO 117 I=1,N2 C(I) = CH(I) 117 continue END subroutine PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1), & C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), & CH2(IDL1,IP) IDOT = IDO/2 NT = IP*IDL1 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO if (IDO < L1) goto 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 continue 102 continue 103 continue DO 105 K=1,L1 DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 continue 105 continue goto 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 continue 108 continue 109 continue DO 111 I=1,IDO DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 continue 111 continue 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = WA(IDL)*CH2(IK,IP) 113 continue IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC if (IDLJ > IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) 114 continue 115 continue 116 continue DO 118 J=2,IPPH DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 continue 118 continue DO 120 J=2,IPPH JC = IPP2-J DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 continue 120 continue NAC = 1 if (IDO == 2) return NAC = 0 DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 continue DO 123 J=2,IP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 continue 123 continue if (IDOT > L1) goto 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 DO 124 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 124 continue 125 continue 126 continue return 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ DO 128 I=4,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 128 continue 129 continue 130 continue END subroutine PASSB2 (IDO,L1,CC,CH,WA1) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2), & WA1(1) if (IDO > 2) goto 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 103 continue 104 continue END subroutine PASSB3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3), & WA1(1) ,WA2(1) DATA TAUR,TAUI /-.5,.866025403784439/ if (IDO /= 2) goto 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 103 continue 104 continue END subroutine PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4), & WA1(1) ,WA2(1) ,WA3(1) if (IDO /= 2) goto 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,4,K)-CC(2,2,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,2,K)-CC(1,4,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,4,K)-CC(I,2,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,2,K)-CC(I-1,4,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 103 continue 104 continue END subroutine PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5), & WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, & -.809016994374947,.587785252292473/ if (IDO /= 2) goto 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 103 continue 104 continue END subroutine CFFTI (N,WSAVE) DIMENSION WSAVE(1) if (N == 1) return IW1 = N+N+1 IW2 = IW1+N+N CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2)) END subroutine CFFTI1 (N,WA,IFAC) DIMENSION WA(1) ,IFAC(1) ,NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/ NL = N NF = 0 J = 0 101 J = J+1 if (J-4) 102,102,103 102 NTRY = NTRYH(J) goto 104 103 NTRY = NTRY+2 104 NQ = NL/NTRY NR = NL-NTRY*NQ if (NR) 101,105,101 105 NF = NF+1 IFAC(NF+2) = NTRY NL = NQ if (NTRY /= 2) goto 107 if (NF == 1) goto 107 DO 106 I=2,NF IB = NF-I+2 IFAC(IB+2) = IFAC(IB+1) 106 continue IFAC(3) = 2 107 if (NL /= 1) goto 104 IFAC(1) = N IFAC(2) = NF TPI = 6.28318530717959 ARGH = TPI/FLOAT(N) I = 2 L1 = 1 DO 110 K1=1,NF IP = IFAC(K1+2) LD = 0 L2 = L1*IP IDO = N/L2 IDOT = IDO+IDO+2 IPM = IP-1 DO 109 J=1,IPM I1 = I WA(I-1) = 1. WA(I) = 0. LD = LD+L1 FI = 0. ARGLD = FLOAT(LD)*ARGH DO 108 II=4,IDOT,2 I = I+2 FI = FI+1. ARG = FI*ARGLD WA(I-1) = COS(ARG) WA(I) = SIN(ARG) 108 continue if (IP <= 5) goto 109 WA(I1-1) = WA(I-1) WA(I1) = WA(I) 109 continue L1 = L2 110 continue END subroutine CFFTF (N,C,WSAVE) DIMENSION C(1) ,WSAVE(1) if (N == 1) return IW1 = N+N+1 IW2 = IW1+N+N CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) END subroutine CFFTF1 (N,C,CH,WA,IFAC) DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1) NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDOT = IDO+IDO IDL1 = IDOT*L1 if (IP /= 4) goto 103 IX2 = IW+IDOT IX3 = IX2+IDOT if (NA /= 0) goto 101 CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) goto 102 101 CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA goto 115 103 if (IP /= 2) goto 106 if (NA /= 0) goto 104 CALL PASSF2 (IDOT,L1,C,CH,WA(IW)) goto 105 104 CALL PASSF2 (IDOT,L1,CH,C,WA(IW)) 105 NA = 1-NA goto 115 106 if (IP /= 3) goto 109 IX2 = IW+IDOT if (NA /= 0) goto 107 CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) goto 108 107 CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA goto 115 109 if (IP /= 5) goto 112 IX2 = IW+IDOT IX3 = IX2+IDOT IX4 = IX3+IDOT if (NA /= 0) goto 110 CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) goto 111 110 CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA goto 115 112 if (NA /= 0) goto 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) goto 114 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 if (NAC /= 0) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDOT 116 continue if (NA == 0) return N2 = N+N DO 117 I=1,N2 C(I) = CH(I) 117 continue END subroutine PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1), & C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), & CH2(IDL1,IP) IDOT = IDO/2 NT = IP*IDL1 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO if (IDO < L1) goto 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 continue 102 continue 103 continue DO 105 K=1,L1 DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 continue 105 continue goto 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 continue 108 continue 109 continue DO 111 I=1,IDO DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 continue 111 continue 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = -WA(IDL)*CH2(IK,IP) 113 continue IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC if (IDLJ > IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) 114 continue 115 continue 116 continue DO 118 J=2,IPPH DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 continue 118 continue DO 120 J=2,IPPH JC = IPP2-J DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 continue 120 continue NAC = 1 if (IDO == 2) return NAC = 0 DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 continue DO 123 J=2,IP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 continue 123 continue if (IDOT > L1) goto 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 DO 124 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 124 continue 125 continue 126 continue return 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ DO 128 I=4,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 128 continue 129 continue 130 continue END subroutine PASSF2 (IDO,L1,CC,CH,WA1) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2), & WA1(1) if (IDO > 2) goto 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 103 continue 104 continue END subroutine PASSF3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3), & WA1(1) ,WA2(1) DATA TAUR,TAUI /-.5,-.866025403784439/ if (IDO /= 2) goto 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 103 continue 104 continue END subroutine PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4), & WA1(1) ,WA2(1) ,WA3(1) if (IDO /= 2) goto 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,2,K)-CC(2,4,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,4,K)-CC(1,2,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,2,K)-CC(I,4,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,4,K)-CC(I-1,2,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 103 continue 104 continue END subroutine PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5), & WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) DATA TR11,TI11,TR12,TI12 /.309016994374947,-.951056516295154, & -.809016994374947,-.587785252292473/ if (IDO /= 2) goto 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 103 continue 104 continue END ! DK DK march99 : routines sur le Cray (simple precision) subroutine ABZP01 ! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. ! ! Terminates execution when a hard failure occurs. ! ! ******************** IMPLEMENTATION NOTE ******************** ! The following STOP statement may be replaced by a call to an ! implementation-dependent routine to display a message and/or ! to abort the program. ! ************************************************************* ! .. Executable Statements .. STOP END subroutine DCYS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-785 (DEC 1989). ! ! Original name: CUNK2 ! ! DCYS18 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE ! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE ! UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) ! WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR ! -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT ! HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- ! ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. ! NZ=-1 MEANS AN OVERFLOW WILL OCCUR ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX AI, ARGD, ASUMD, BSUMD, C1, C2, CFN, CI, CK, & CONE, CR1, CR2, CRSC, CS, CSCL, CSGN, CSPN, & CZERO, DAI, PHID, RZ, S1, S2, ZB, ZETA1D, & ZETA2D, ZN, ZR REAL AARG, AIC, ANG, APHI, ASC, ASCLE, C2I, C2M, C2R, & CAR, CPN, FMR, FN, FNF, HPI, PI, RS1, SAR, SGN, & SPN, X, YY INTEGER I, IB, IC, IDUM, IFLAG, IFN, IL, IN, INU, IPARD, & IUF, J, K, KDFLG, KFLAG, KK, NAI, NDAI, NW ! .. Local Arrays .. COMPLEX ARG(2), ASUM(2), BSUM(2), CIP(4), CSR(3), & CSS(3), CY(2), PHI(2), ZETA1(2), ZETA2(2) REAL BRY(3) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEUS17, S17DGE, DGSS17, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, INT, LOG, & MAX, MOD, REAL, SIGN, SIN ! .. Data statements .. DATA CZERO, CONE, CI, CR1, CR2/(0.0E0,0.0E0), & (1.0E0,0.0E0), (0.0E0,1.0E0), & (1.0E0,1.73205080756887729E0), & (-0.5E0,-8.66025403784438647E-01)/ DATA HPI, PI, AIC/1.57079632679489662E+00, & 3.14159265358979324E+00, & 1.26551212348464539E+00/ DATA CIP(1), CIP(2), CIP(3), CIP(4)/(1.0E0,0.0E0), & (0.0E0,-1.0E0), (-1.0E0,0.0E0), (0.0E0,1.0E0)/ ! .. Executable Statements .. ! KDFLG = 1 NZ = 0 ! ------------------------------------------------------------------ ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN ! THE UNDERFLOW LIMIT ! ------------------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() X = REAL(Z) ZR = Z if (X < 0.0E0) ZR = -Z YY = AIMAG(ZR) ZN = -ZR*CI ZB = ZR INU = INT(FNU) FNF = FNU - INU ANG = -HPI*FNF CAR = COS(ANG) SAR = SIN(ANG) CPN = -HPI*CAR SPN = -HPI*SAR C2 = CMPLX(-SPN,CPN) KK = MOD(INU,4) + 1 CS = CR1*C2*CIP(KK) if (YY <= 0.0E0) then ZN = CONJG(-ZN) ZB = CONJG(ZB) endif ! ------------------------------------------------------------------ ! K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST ! QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY ! CONJUGATION SINCE THE K function IS REAL ON THE POSITIVE REAL AXIS ! ------------------------------------------------------------------ J = 2 DO 40 I = 1, N ! --------------------------------------------------------------- ! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J ! --------------------------------------------------------------- J = 3 - J FN = FNU + I - 1 CALL DEUS17(ZN,FN,0,TOL,PHI(J),ARG(J),ZETA1(J),ZETA2(J),ASUM(J) & ,BSUM(J),ELIM) if (KODE == 1) then S1 = ZETA1(J) - ZETA2(J) ELSE CFN = CMPLX(FN,0.0E0) S1 = ZETA1(J) - CFN*(CFN/(ZB+ZETA2(J))) endif ! --------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW ! --------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (KDFLG == 1) KFLAG = 2 if (ABS(RS1) >= ALIM) then ! --------------------------------------------------------- ! REFINE TEST AND SCALE ! --------------------------------------------------------- APHI = ABS(PHI(J)) AARG = ABS(ARG(J)) RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC if (ABS(RS1) > ELIM) then goto 20 ELSE if (KDFLG == 1) KFLAG = 1 if (RS1 >= 0.0E0) then if (KDFLG == 1) KFLAG = 3 endif endif endif ! ------------------------------------------------------------ ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES ! ------------------------------------------------------------ C2 = ARG(J)*CR2 IDUM = 1 ! S17DGE assumed not to fail, therefore IDUM set to one. CALL S17DGE('F',C2,'S',AI,NAI,IDUM) IDUM = 1 CALL S17DGE('D',C2,'S',DAI,NDAI,IDUM) S2 = CS*PHI(J)*(AI*ASUM(J)+CR2*DAI*BSUM(J)) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(KFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (KFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) goto 20 endif if (YY <= 0.0E0) S2 = CONJG(S2) CY(KDFLG) = S2 Y(I) = S2*CSR(KFLAG) CS = -CI*CS if (KDFLG == 2) then goto 60 ELSE KDFLG = 2 goto 40 endif endif 20 if (RS1 > 0.0E0) then goto 280 ! ------------------------------------------------------------ ! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW ! ------------------------------------------------------------ else if (X < 0.0E0) then goto 280 ELSE KDFLG = 1 Y(I) = CZERO CS = -CI*CS NZ = NZ + 1 if (I /= 1) then if (Y(I-1) /= CZERO) then Y(I-1) = CZERO NZ = NZ + 1 endif endif endif 40 continue I = N 60 RZ = CMPLX(2.0E0,0.0E0)/ZR CK = CMPLX(FN,0.0E0)*RZ IB = I + 1 if (N >= IB) then ! --------------------------------------------------------------- ! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ! ZERO ON UNDERFLOW ! --------------------------------------------------------------- FN = FNU + N - 1 IPARD = 1 if (MR /= 0) IPARD = 0 CALL DEUS17(ZN,FN,IPARD,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD, & BSUMD,ELIM) if (KODE == 1) then S1 = ZETA1D - ZETA2D ELSE CFN = CMPLX(FN,0.0E0) S1 = ZETA1D - CFN*(CFN/(ZB+ZETA2D)) endif RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (ABS(RS1) >= ALIM) then ! --------------------------------------------------------- ! REFINE ESTIMATE AND TEST ! --------------------------------------------------------- APHI = ABS(PHID) AARG = ABS(ARGD) RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC if (ABS(RS1) >= ELIM) goto 100 endif ! ------------------------------------------------------------ ! SCALED FORWARD RECURRENCE FOR REMAINDER OF THE SEQUENCE ! ------------------------------------------------------------ S1 = CY(1) S2 = CY(2) C1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 80 I = IB, N C2 = S2 S2 = CK*S2 + S1 S1 = C2 CK = CK + RZ C2 = S2*C1 Y(I) = C2 if (KFLAG < 3) then C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) C1 = CSR(KFLAG) endif endif 80 continue goto 140 endif 100 if (RS1 > 0.0E0) then goto 280 ! ------------------------------------------------------------ ! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW ! ------------------------------------------------------------ else if (X < 0.0E0) then goto 280 ELSE NZ = N DO 120 I = 1, N Y(I) = CZERO 120 continue return endif endif 140 if (MR == 0) then return ELSE ! --------------------------------------------------------------- ! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0 ! --------------------------------------------------------------- NZ = 0 FMR = MR SGN = -SIGN(PI,FMR) ! --------------------------------------------------------------- ! CSPN AND CSGN ARE COEFF OF K AND I functionS RESP. ! --------------------------------------------------------------- CSGN = CMPLX(0.0E0,SGN) if (YY <= 0.0E0) CSGN = CONJG(CSGN) IFN = INU + N - 1 ANG = FNF*SGN CPN = COS(ANG) SPN = SIN(ANG) CSPN = CMPLX(CPN,SPN) if (MOD(IFN,2) == 1) CSPN = -CSPN ! --------------------------------------------------------------- ! CS=COEFF OF THE J function TO GET THE I function. I(FNU,Z) IS ! COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE ! FIRST QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE ! COMPUTED BY CONJUGATION SINCE THE I function IS REAL ON THE ! POSITIVE REAL AXIS ! --------------------------------------------------------------- CS = CMPLX(CAR,-SAR)*CSGN IN = MOD(IFN,4) + 1 C2 = CIP(IN) CS = CS*CONJG(C2) ASC = BRY(1) KK = N KDFLG = 1 IB = IB - 1 IC = IB - 1 IUF = 0 DO 220 K = 1, N ! ------------------------------------------------------------ ! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K ! function ABOVE ! ------------------------------------------------------------ FN = FNU + KK - 1 if (N > 2) then if ((KK == N) .and. (IB < N)) then goto 160 else if ((KK /= IB) .and. (KK /= IC)) then CALL DEUS17(ZN,FN,0,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD, & BSUMD,ELIM) goto 160 endif endif PHID = PHI(J) ARGD = ARG(J) ZETA1D = ZETA1(J) ZETA2D = ZETA2(J) ASUMD = ASUM(J) BSUMD = BSUM(J) J = 3 - J 160 if (KODE == 1) then S1 = -ZETA1D + ZETA2D ELSE CFN = CMPLX(FN,0.0E0) S1 = -ZETA1D + CFN*(CFN/(ZB+ZETA2D)) endif ! ------------------------------------------------------------ ! TEST FOR UNDERFLOW AND OVERFLOW ! ------------------------------------------------------------ RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (KDFLG == 1) IFLAG = 2 if (ABS(RS1) >= ALIM) then ! ------------------------------------------------------ ! REFINE TEST AND SCALE ! ------------------------------------------------------ APHI = ABS(PHID) AARG = ABS(ARGD) RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC if (ABS(RS1) > ELIM) then goto 180 ELSE if (KDFLG == 1) IFLAG = 1 if (RS1 >= 0.0E0) then if (KDFLG == 1) IFLAG = 3 endif endif endif IDUM = 1 ! S17DGE assumed not to fail, therefore IDUM set to one. CALL S17DGE('F',ARGD,'S',AI,NAI,IDUM) IDUM = 1 CALL S17DGE('D',ARGD,'S',DAI,NDAI,IDUM) S2 = CS*PHID*(AI*ASUMD+DAI*BSUMD) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0) endif goto 200 endif 180 if (RS1 > 0.0E0) then goto 280 ELSE S2 = CZERO endif 200 if (YY <= 0.0E0) S2 = CONJG(S2) CY(KDFLG) = S2 C2 = S2 S2 = S2*CSR(IFLAG) ! ------------------------------------------------------------ ! ADD I AND K functionS, K SEQUENCE IN Y(I), I=1,N ! ------------------------------------------------------------ S1 = Y(KK) if (KODE /= 1) then CALL DGSS17(ZR,S1,S2,NW,ASC,ALIM,IUF) NZ = NZ + NW endif Y(KK) = S1*CSPN + S2 KK = KK - 1 CSPN = -CSPN CS = -CS*CI if (C2 == CZERO) then KDFLG = 1 else if (KDFLG == 2) then goto 240 ELSE KDFLG = 2 endif 220 continue K = N 240 IL = N - K if (IL /= 0) then ! ------------------------------------------------------------ ! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE ! K functionS, SCALING THE I SEQUENCE DURING RECURRENCE TO ! KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT ! EXTREMES. ! ------------------------------------------------------------ S1 = CY(1) S2 = CY(2) CS = CSR(IFLAG) ASCLE = BRY(IFLAG) FN = INU + IL DO 260 I = 1, IL C2 = S2 S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 S1 = C2 FN = FN - 1.0E0 C2 = S2*CS CK = C2 C1 = Y(KK) if (KODE /= 1) then CALL DGSS17(ZR,C1,C2,NW,ASC,ALIM,IUF) NZ = NZ + NW endif Y(KK) = C1*CSPN + C2 KK = KK - 1 CSPN = -CSPN if (IFLAG < 3) then C2R = REAL(CK) C2I = AIMAG(CK) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CS S2 = CK S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) CS = CSR(IFLAG) endif endif 260 continue endif return endif 280 NZ = -1 return END subroutine DCZS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-786 (DEC 1989). ! ! Original name: CUNK1 ! ! DCZS18 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE ! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE ! UNIFORM ASYMPTOTIC EXPANSION. ! MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. ! NZ=-1 MEANS AN OVERFLOW WILL OCCUR ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CFN, CK, CONE, CRSC, CS, CSCL, CSGN, & CSPN, CZERO, PHID, RZ, S1, S2, SUMD, ZETA1D, & ZETA2D, ZR REAL ANG, APHI, ASC, ASCLE, C2I, C2M, C2R, CPN, FMR, & FN, FNF, PI, RS1, SGN, SPN, X INTEGER I, IB, IC, IFLAG, IFN, IL, INITD, INU, IPARD, & IUF, J, K, KDFLG, KFLAG, KK, M, NW ! .. Local Arrays .. COMPLEX CSR(3), CSS(3), CWRK(16,3), CY(2), PHI(2), & SUM(2), ZETA1(2), ZETA2(2) REAL BRY(3) INTEGER INIT(2) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEWS17, DGSS17, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, LOG, MAX, MOD, & REAL, SIGN, SIN ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ DATA PI/3.14159265358979324E0/ ! .. Executable Statements .. ! KDFLG = 1 NZ = 0 ! ------------------------------------------------------------------ ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN ! THE UNDERFLOW LIMIT ! ------------------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() X = REAL(Z) ZR = Z if (X < 0.0E0) ZR = -Z J = 2 DO 40 I = 1, N ! --------------------------------------------------------------- ! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J ! --------------------------------------------------------------- J = 3 - J FN = FNU + I - 1 INIT(J) = 0 CALL DEWS17(ZR,FN,2,0,TOL,INIT(J),PHI(J),ZETA1(J),ZETA2(J), & SUM(J),CWRK(1,J),ELIM) if (KODE == 1) then S1 = ZETA1(J) - ZETA2(J) ELSE CFN = CMPLX(FN,0.0E0) S1 = ZETA1(J) - CFN*(CFN/(ZR+ZETA2(J))) endif ! --------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW ! --------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (KDFLG == 1) KFLAG = 2 if (ABS(RS1) >= ALIM) then ! --------------------------------------------------------- ! REFINE TEST AND SCALE ! --------------------------------------------------------- APHI = ABS(PHI(J)) RS1 = RS1 + LOG(APHI) if (ABS(RS1) > ELIM) then goto 20 ELSE if (KDFLG == 1) KFLAG = 1 if (RS1 >= 0.0E0) then if (KDFLG == 1) KFLAG = 3 endif endif endif ! ------------------------------------------------------------ ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES ! ------------------------------------------------------------ S2 = PHI(J)*SUM(J) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(KFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (KFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) goto 20 endif CY(KDFLG) = S2 Y(I) = S2*CSR(KFLAG) if (KDFLG == 2) then goto 60 ELSE KDFLG = 2 goto 40 endif endif 20 if (RS1 > 0.0E0) then goto 280 ! ------------------------------------------------------------ ! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW ! ------------------------------------------------------------ else if (X < 0.0E0) then goto 280 ELSE KDFLG = 1 Y(I) = CZERO NZ = NZ + 1 if (I /= 1) then if (Y(I-1) /= CZERO) then Y(I-1) = CZERO NZ = NZ + 1 endif endif endif 40 continue I = N 60 RZ = CMPLX(2.0E0,0.0E0)/ZR CK = CMPLX(FN,0.0E0)*RZ IB = I + 1 if (N >= IB) then ! --------------------------------------------------------------- ! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ! ZERO ON UNDERFLOW ! --------------------------------------------------------------- FN = FNU + N - 1 IPARD = 1 if (MR /= 0) IPARD = 0 INITD = 0 CALL DEWS17(ZR,FN,2,IPARD,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, & CWRK(1,3),ELIM) if (KODE == 1) then S1 = ZETA1D - ZETA2D ELSE CFN = CMPLX(FN,0.0E0) S1 = ZETA1D - CFN*(CFN/(ZR+ZETA2D)) endif RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (ABS(RS1) >= ALIM) then ! --------------------------------------------------------- ! REFINE ESTIMATE AND TEST ! --------------------------------------------------------- APHI = ABS(PHID) RS1 = RS1 + LOG(APHI) if (ABS(RS1) >= ELIM) goto 100 endif ! ------------------------------------------------------------ ! RECUR FORWARD FOR REMAINDER OF THE SEQUENCE ! ------------------------------------------------------------ S1 = CY(1) S2 = CY(2) C1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 80 I = IB, N C2 = S2 S2 = CK*S2 + S1 S1 = C2 CK = CK + RZ C2 = S2*C1 Y(I) = C2 if (KFLAG < 3) then C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) C1 = CSR(KFLAG) endif endif 80 continue goto 140 endif 100 if (RS1 > 0.0E0) then goto 280 ! ------------------------------------------------------------ ! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW ! ------------------------------------------------------------ else if (X < 0.0E0) then goto 280 ELSE NZ = N DO 120 I = 1, N Y(I) = CZERO 120 continue return endif endif 140 if (MR == 0) then return ELSE ! --------------------------------------------------------------- ! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0 ! --------------------------------------------------------------- NZ = 0 FMR = MR SGN = -SIGN(PI,FMR) ! --------------------------------------------------------------- ! CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. ! --------------------------------------------------------------- CSGN = CMPLX(0.0E0,SGN) INU = INT(FNU) FNF = FNU - INU IFN = INU + N - 1 ANG = FNF*SGN CPN = COS(ANG) SPN = SIN(ANG) CSPN = CMPLX(CPN,SPN) if (MOD(IFN,2) == 1) CSPN = -CSPN ASC = BRY(1) KK = N IUF = 0 KDFLG = 1 IB = IB - 1 IC = IB - 1 DO 220 K = 1, N FN = FNU + KK - 1 ! ------------------------------------------------------------ ! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K ! function ABOVE ! ------------------------------------------------------------ M = 3 if (N > 2) then if ((KK == N) .and. (IB < N)) then goto 160 else if ((KK /= IB) .and. (KK /= IC)) then INITD = 0 goto 160 endif endif INITD = INIT(J) PHID = PHI(J) ZETA1D = ZETA1(J) ZETA2D = ZETA2(J) SUMD = SUM(J) M = J J = 3 - J 160 CALL DEWS17(ZR,FN,1,0,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, & CWRK(1,M),ELIM) if (KODE == 1) then S1 = -ZETA1D + ZETA2D ELSE CFN = CMPLX(FN,0.0E0) S1 = -ZETA1D + CFN*(CFN/(ZR+ZETA2D)) endif ! ------------------------------------------------------------ ! TEST FOR UNDERFLOW AND OVERFLOW ! ------------------------------------------------------------ RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (KDFLG == 1) IFLAG = 2 if (ABS(RS1) >= ALIM) then ! ------------------------------------------------------ ! REFINE TEST AND SCALE ! ------------------------------------------------------ APHI = ABS(PHID) RS1 = RS1 + LOG(APHI) if (ABS(RS1) > ELIM) then goto 180 ELSE if (KDFLG == 1) IFLAG = 1 if (RS1 >= 0.0E0) then if (KDFLG == 1) IFLAG = 3 endif endif endif S2 = CSGN*PHID*SUMD C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0) endif goto 200 endif 180 if (RS1 > 0.0E0) then goto 280 ELSE S2 = CZERO endif 200 CY(KDFLG) = S2 C2 = S2 S2 = S2*CSR(IFLAG) ! ------------------------------------------------------------ ! ADD I AND K functionS, K SEQUENCE IN Y(I), I=1,N ! ------------------------------------------------------------ S1 = Y(KK) if (KODE /= 1) then CALL DGSS17(ZR,S1,S2,NW,ASC,ALIM,IUF) NZ = NZ + NW endif Y(KK) = S1*CSPN + S2 KK = KK - 1 CSPN = -CSPN if (C2 == CZERO) then KDFLG = 1 else if (KDFLG == 2) then goto 240 ELSE KDFLG = 2 endif 220 continue K = N 240 IL = N - K if (IL /= 0) then ! ------------------------------------------------------------ ! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE ! K functionS, SCALING THE I SEQUENCE DURING RECURRENCE TO ! KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT ! EXTREMES. ! ------------------------------------------------------------ S1 = CY(1) S2 = CY(2) CS = CSR(IFLAG) ASCLE = BRY(IFLAG) FN = INU + IL DO 260 I = 1, IL C2 = S2 S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 S1 = C2 FN = FN - 1.0E0 C2 = S2*CS CK = C2 C1 = Y(KK) if (KODE /= 1) then CALL DGSS17(ZR,C1,C2,NW,ASC,ALIM,IUF) NZ = NZ + NW endif Y(KK) = C1*CSPN + C2 KK = KK - 1 CSPN = -CSPN if (IFLAG < 3) then C2R = REAL(CK) C2I = AIMAG(CK) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CS S2 = CK S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) CS = CSR(IFLAG) endif endif 260 continue endif return endif 280 NZ = -1 return END subroutine DERS17(Z,FNU,N,CY,TOL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-761 (DEC 1989). ! ! Original name: CRATI ! ! DERS17 COMPUTES RATIOS OF I BESSEL functionS BY BACKWARD ! RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD ! RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, ! MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, ! BESSEL functionS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, ! BY D. J. SOOKNE. ! ! .. Scalar Arguments .. COMPLEX Z REAL FNU, TOL INTEGER N ! .. Array Arguments .. COMPLEX CY(N) ! .. Local Scalars .. COMPLEX CDFNU, CONE, CZERO, P1, P2, PT, RZ, T1 REAL AK, AMAGZ, AP1, AP2, ARG, AZ, DFNU, FDNU, FLAM, & FNUP, RAP1, RHO, TEST, TEST1 INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, INT, MAX, MIN, REAL, SQRT ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! AZ = ABS(Z) INU = INT(FNU) IDNU = INU + N - 1 FDNU = IDNU MAGZ = INT(AZ) AMAGZ = MAGZ + 1 FNUP = MAX(AMAGZ,FDNU) ID = IDNU - MAGZ - 1 ITIME = 1 K = 1 RZ = (CONE+CONE)/Z T1 = CMPLX(FNUP,0.0E0)*RZ P2 = -T1 P1 = CONE T1 = T1 + RZ if (ID > 0) ID = 0 AP2 = ABS(P2) AP1 = ABS(P1) ! ------------------------------------------------------------------ ! THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNX ! GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT ! P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR ! PREMATURELY. ! ------------------------------------------------------------------ ARG = (AP2+AP2)/(AP1*TOL) TEST1 = SQRT(ARG) TEST = TEST1 RAP1 = 1.0E0/AP1 P1 = P1*CMPLX(RAP1,0.0E0) P2 = P2*CMPLX(RAP1,0.0E0) AP2 = AP2*RAP1 20 continue K = K + 1 AP1 = AP2 PT = P2 P2 = P1 - T1*P2 P1 = PT T1 = T1 + RZ AP2 = ABS(P2) if (AP1 <= TEST) then goto 20 else if (ITIME /= 2) then AK = ABS(T1)*0.5E0 FLAM = AK + SQRT(AK*AK-1.0E0) RHO = MIN(AP2/AP1,FLAM) TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0E0)) ITIME = 2 goto 20 endif KK = K + 1 - ID AK = KK DFNU = FNU + N - 1 CDFNU = CMPLX(DFNU,0.0E0) T1 = CMPLX(AK,0.0E0) P1 = CMPLX(1.0E0/AP2,0.0E0) P2 = CZERO DO 40 I = 1, KK PT = P1 P1 = RZ*(CDFNU+T1)*P1 + P2 P2 = PT T1 = T1 - CONE 40 continue if (REAL(P1) == 0.0E0 .and. AIMAG(P1) == 0.0E0) P1 = CMPLX(TOL, & TOL) CY(N) = P2/P1 if (N /= 1) then K = N - 1 AK = K T1 = CMPLX(AK,0.0E0) CDFNU = CMPLX(FNU,0.0E0)*RZ DO 60 I = 2, N PT = CDFNU + T1*RZ + CY(K+1) if (REAL(PT) == 0.0E0 .and. AIMAG(PT) == 0.0E0) & PT = CMPLX(TOL,TOL) CY(K) = CONE/PT T1 = T1 - CONE K = K - 1 60 continue endif return END subroutine DESS17(ZR,FNU,KODE,N,Y,NZ,CW,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-762 (DEC 1989). ! ! Original name: CWRSK ! ! DESS17 COMPUTES THE I BESSEL function FOR RE(Z) >= 0.0 BY ! NORMALIZING THE I function RATIOS FROM DERS17 BY THE WRONSKIAN ! ! .. Scalar Arguments .. COMPLEX ZR REAL ALIM, ELIM, FNU, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX CW(2), Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CINU, CSCL, CT, RCT, ST REAL ACT, ACW, ASCLE, S1, S2, YY INTEGER I, NW ! .. External functions .. REAL X02AME EXTERNAL X02AME ! .. External subroutines .. EXTERNAL DERS17, DGXS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, SIN ! .. Executable Statements .. ! ------------------------------------------------------------------ ! I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS ! Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM DERS17 NORMALIZED BY THE ! WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM DGXS17. ! ------------------------------------------------------------------ NZ = 0 CALL DGXS17(ZR,FNU,KODE,2,CW,NW,TOL,ELIM,ALIM) if (NW /= 0) then NZ = -1 if (NW == (-2)) NZ = -2 if (NW == (-3)) NZ = -3 ELSE CALL DERS17(ZR,FNU,N,Y,TOL) ! --------------------------------------------------------------- ! RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), ! R(FNU+J-1,Z)=Y(J), J=1,...,N ! --------------------------------------------------------------- CINU = CMPLX(1.0E0,0.0E0) if (KODE /= 1) then YY = AIMAG(ZR) S1 = COS(YY) S2 = SIN(YY) CINU = CMPLX(S1,S2) endif ! --------------------------------------------------------------- ! ON LOW EXPONENT MACHINES THE K functionS CAN BE CLOSE TO BOTH ! THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE ! SCALED TO PREVENT OVER OR UNDERFLOW. DEVS17 HAS DETERMINED THAT ! THE RESULT IS ON SCALE. ! --------------------------------------------------------------- ACW = ABS(CW(2)) ASCLE = (1.0E+3*X02AME())/TOL CSCL = CMPLX(1.0E0,0.0E0) if (ACW > ASCLE) then ASCLE = 1.0E0/ASCLE if (ACW >= ASCLE) CSCL = CMPLX(TOL,0.0E0) ELSE CSCL = CMPLX(1.0E0/TOL,0.0E0) endif C1 = CW(1)*CSCL C2 = CW(2)*CSCL ST = Y(1) ! --------------------------------------------------------------- ! CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0E0/CABS(CT) PREVENTS ! UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) ! --------------------------------------------------------------- CT = ZR*(C2+ST*C1) ACT = ABS(CT) RCT = CMPLX(1.0E0/ACT,0.0E0) CT = CONJG(CT)*RCT CINU = CINU*RCT*CT Y(1) = CINU*CSCL if (N /= 1) then DO 20 I = 2, N CINU = ST*CINU ST = Y(I) Y(I) = CINU*CSCL 20 continue endif endif return END subroutine DETS17(Z,FNU,KODE,N,Y,NZ,NLAST,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-763 (DEC 1989). ! ! Original name: CUNI2 ! ! DETS17 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF ! UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I ! OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. ! ! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC ! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. ! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER ! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL. ! Y(I)=CZERO FOR I=NLAST+1,N ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, TOL INTEGER KODE, N, NLAST, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX AI, ARG, ASUM, BSUM, C1, C2, CFN, CI, CID, CONE, & CRSC, CSCL, CZERO, DAI, PHI, RZ, S1, S2, ZB, & ZETA1, ZETA2, ZN REAL AARG, AIC, ANG, APHI, ASCLE, AY, C2I, C2M, C2R, & CAR, FN, HPI, RS1, SAR, YY INTEGER I, IDUM, IFLAG, IN, INU, J, K, NAI, ND, NDAI, & NN, NUF, NW ! .. Local Arrays .. COMPLEX CIP(4), CSR(3), CSS(3), CY(2) REAL BRY(3) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEUS17, DEVS17, S17DGE, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, INT, LOG, & MAX, MIN, MOD, REAL, SIN ! .. Data statements .. DATA CZERO, CONE, CI/(0.0E0,0.0E0), (1.0E0,0.0E0), & (0.0E0,1.0E0)/ DATA CIP(1), CIP(2), CIP(3), CIP(4)/(1.0E0,0.0E0), & (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0)/ DATA HPI, AIC/1.57079632679489662E+00, & 1.265512123484645396E+00/ ! .. Executable Statements .. ! NZ = 0 ND = N NLAST = 0 ! ------------------------------------------------------------------ ! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- ! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, ! EXP(ALIM)=EXP(ELIM)*TOL ! ------------------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL YY = AIMAG(Z) ! ------------------------------------------------------------------ ! ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI ! ------------------------------------------------------------------ ZN = -Z*CI ZB = Z CID = -CI INU = INT(FNU) ANG = HPI*(FNU-INU) CAR = COS(ANG) SAR = SIN(ANG) C2 = CMPLX(CAR,SAR) IN = INU + N - 1 IN = MOD(IN,4) C2 = C2*CIP(IN+1) if (YY <= 0.0E0) then ZN = CONJG(-ZN) ZB = CONJG(ZB) CID = -CID C2 = CONJG(C2) endif ! ------------------------------------------------------------------ ! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER ! ------------------------------------------------------------------ FN = MAX(FNU,1.0E0) CALL DEUS17(ZN,FN,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM) if (KODE == 1) then S1 = -ZETA1 + ZETA2 ELSE CFN = CMPLX(FNU,0.0E0) S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) endif RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then 20 continue NN = MIN(2,ND) DO 40 I = 1, NN FN = FNU + ND - I CALL DEUS17(ZN,FN,0,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM) if (KODE == 1) then S1 = -ZETA1 + ZETA2 ELSE CFN = CMPLX(FN,0.0E0) AY = ABS(YY) S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + CMPLX(0.0E0,AY) endif ! ------------------------------------------------------------ ! TEST FOR UNDERFLOW AND OVERFLOW ! ------------------------------------------------------------ RS1 = REAL(S1) if (ABS(RS1) > ELIM) then goto 60 ELSE if (I == 1) IFLAG = 2 if (ABS(RS1) >= ALIM) then ! ------------------------------------------------------ ! REFINE TEST AND SCALE ! ------------------------------------------------------ ! ------------------------------------------------------ APHI = ABS(PHI) AARG = ABS(ARG) RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC if (ABS(RS1) > ELIM) then goto 60 ELSE if (I == 1) IFLAG = 1 if (RS1 >= 0.0E0) then if (I == 1) IFLAG = 3 endif endif endif ! --------------------------------------------------------- ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES ! --------------------------------------------------------- IDUM = 1 ! S17DGE assumed not to fail, therefore IDUM set to one. CALL S17DGE('F',ARG,'S',AI,NAI,IDUM) IDUM = 1 CALL S17DGE('D',ARG,'S',DAI,NDAI,IDUM) S2 = PHI*(AI*ASUM+DAI*BSUM) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) goto 60 endif if (YY <= 0.0E0) S2 = CONJG(S2) J = ND - I + 1 S2 = S2*C2 CY(I) = S2 Y(J) = S2*CSR(IFLAG) C2 = C2*CID endif 40 continue goto 80 60 if (RS1 > 0.0E0) then goto 160 ELSE ! ------------------------------------------------------------ ! SET UNDERFLOW AND UPDATE PARAMETERS ! ------------------------------------------------------------ Y(ND) = CZERO NZ = NZ + 1 ND = ND - 1 if (ND == 0) then return ELSE CALL DEVS17(Z,FNU,KODE,1,ND,Y,NUF,TOL,ELIM,ALIM) if (NUF < 0) then goto 160 ELSE ND = ND - NUF NZ = NZ + NUF if (ND == 0) then return ELSE FN = FNU + ND - 1 if (FN < FNUL) then goto 120 ELSE ! FN = AIMAG(CID) ! J = NUF + 1 ! K = MOD(J,4) + 1 ! S1 = CIP(K) ! if (FN < 0.0E0) S1 = CONJG(S1) ! C2 = C2*S1 ! The above 6 lines were replaced by the 5 below ! to fix a bug discovered during implementation ! on a Multics machine, whereby some results ! were returned wrongly scaled by sqrt(-1.0). MWP. C2 = CMPLX(CAR,SAR) IN = INU + ND - 1 IN = MOD(IN,4) + 1 C2 = C2*CIP(IN) if (YY <= 0.0E0) C2 = CONJG(C2) goto 20 endif endif endif endif endif 80 if (ND > 2) then RZ = CMPLX(2.0E0,0.0E0)/Z BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() S1 = CY(1) S2 = CY(2) C1 = CSR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = K DO 100 I = 3, ND C2 = S2 S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 S1 = C2 C2 = S2*C1 Y(K) = C2 K = K - 1 FN = FN - 1.0E0 if (IFLAG < 3) then C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) C1 = CSR(IFLAG) endif endif 100 continue endif return 120 NLAST = ND return else if (RS1 <= 0.0E0) then NZ = N DO 140 I = 1, N Y(I) = CZERO 140 continue return endif 160 NZ = -1 return END subroutine DEUS17(Z,FNU,IPMTR,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM, & ELIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-764 (DEC 1989). ! ! Original name: CUNHJ ! ! REFERENCES ! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ AND I.A. ! STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. ! ! ASYMPTOTICS AND SPECIAL functionS BY F.W.J. OLVER, ACADEMIC ! PRESS, N.Y., 1974, PAGE 420 ! ! ABSTRACT ! DEUS17 COMPUTES PARAMETERS FOR BESSEL functionS C(FNU,Z) = ! J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU ! BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION ! ! C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) ! ! FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS ! AN AIRY function AND DAIRY IS ITS DERIVATIVE. ! ! (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, ! ! ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING ! PURPOSES IN AIRY functionS FROM S17DGE OR S17DHE. ! ! MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND ! MUST BE SPECIFIED. IPMTR=0 returnS ALL PARAMETERS. IPMTR= ! 1 COMPUTES ALL EXCEPT ASUM AND BSUM. ! ! .. Scalar Arguments .. COMPLEX ARG, ASUM, BSUM, PHI, Z, ZETA1, ZETA2 REAL ELIM, FNU, TOL INTEGER IPMTR ! .. Local Scalars .. COMPLEX CFNU, CONE, CZERO, PRZTH, PTFN, RFN13, RTZTA, & RZTH, SUMA, SUMB, T2, TFN, W, W2, ZA, ZB, ZC, & ZETA, ZTH REAL ANG, ASUMI, ASUMR, ATOL, AW2, AZTH, BSUMI, & BSUMR, BTOL, EX1, EX2, FN13, FN23, HPI, PI, PP, & RFNU, RFNU2, TEST, THPI, TSTI, TSTR, WI, WR, & ZCI, ZCR, ZETAI, ZETAR, ZTHI, ZTHR INTEGER IAS, IBS, IS, J, JR, JU, K, KMAX, KP1, KS, L, & L1, L2, LR, LRP1, M ! .. Local Arrays .. COMPLEX CR(14), DR(14), P(30), UP(14) REAL ALFA(180), AP(30), AR(14), BETA(210), BR(14), & C(105), GAMA(30) ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, ATAN, CMPLX, COS, EXP, LOG, REAL, & SIN, SQRT ! .. Data statements .. DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), & AR(8), AR(9), AR(10), AR(11), AR(12), AR(13), & AR(14)/1.00000000000000000E+00, & 1.04166666666666667E-01, & 8.35503472222222222E-02, & 1.28226574556327160E-01, & 2.91849026464140464E-01, & 8.81627267443757652E-01, & 3.32140828186276754E+00, & 1.49957629868625547E+01, & 7.89230130115865181E+01, & 4.74451538868264323E+02, & 3.20749009089066193E+03, & 2.40865496408740049E+04, & 1.98923119169509794E+05, & 1.79190200777534383E+06/ DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), & BR(8), BR(9), BR(10), BR(11), BR(12), BR(13), & BR(14)/1.00000000000000000E+00, & -1.45833333333333333E-01, & -9.87413194444444444E-02, & -1.43312053915895062E-01, & -3.17227202678413548E-01, & -9.42429147957120249E-01, & -3.51120304082635426E+00, & -1.57272636203680451E+01, & -8.22814390971859444E+01, & -4.92355370523670524E+02, & -3.31621856854797251E+03, & -2.48276742452085896E+04, & -2.04526587315129788E+05, & -1.83844491706820990E+06/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), & C(9), C(10), C(11), C(12), C(13), C(14), C(15), & C(16)/1.00000000000000000E+00, & -2.08333333333333333E-01, & 1.25000000000000000E-01, & 3.34201388888888889E-01, & -4.01041666666666667E-01, & 7.03125000000000000E-02, & -1.02581259645061728E+00, & 1.84646267361111111E+00, & -8.91210937500000000E-01, & 7.32421875000000000E-02, & 4.66958442342624743E+00, & -1.12070026162229938E+01, & 8.78912353515625000E+00, & -2.36408691406250000E+00, & 1.12152099609375000E-01, & -2.82120725582002449E+01/ DATA C(17), C(18), C(19), C(20), C(21), C(22), C(23), & C(24)/8.46362176746007346E+01, & -9.18182415432400174E+01, & 4.25349987453884549E+01, & -7.36879435947963170E+00, & 2.27108001708984375E-01, & 2.12570130039217123E+02, & -7.65252468141181642E+02, & 1.05999045252799988E+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), & C(32), C(33), C(34), C(35), C(36), C(37), C(38), & C(39), C(40)/-6.99579627376132541E+02, & 2.18190511744211590E+02, & -2.64914304869515555E+01, & 5.72501420974731445E-01, & -1.91945766231840700E+03, & 8.06172218173730938E+03, & -1.35865500064341374E+04, & 1.16553933368645332E+04, & -5.30564697861340311E+03, & 1.20090291321635246E+03, & -1.08090919788394656E+02, & 1.72772750258445740E+00, & 2.02042913309661486E+04, & -9.69805983886375135E+04, & 1.92547001232531532E+05, & -2.03400177280415534E+05/ DATA C(41), C(42), C(43), C(44), C(45), C(46), C(47), & C(48)/1.22200464983017460E+05, & -4.11926549688975513E+04, & 7.10951430248936372E+03, & -4.93915304773088012E+02, & 6.07404200127348304E+00, & -2.42919187900551333E+05, & 1.31176361466297720E+06, & -2.99801591853810675E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), & C(56), C(57), C(58), C(59), C(60), C(61), C(62), & C(63), C(64)/3.76327129765640400E+06, & -2.81356322658653411E+06, & 1.26836527332162478E+06, & -3.31645172484563578E+05, & 4.52187689813627263E+04, & -2.49983048181120962E+03, & 2.43805296995560639E+01, & 3.28446985307203782E+06, & -1.97068191184322269E+07, & 5.09526024926646422E+07, & -7.41051482115326577E+07, & 6.63445122747290267E+07, & -3.75671766607633513E+07, & 1.32887671664218183E+07, & -2.78561812808645469E+06, & 3.08186404612662398E+05/ DATA C(65), C(66), C(67), C(68), C(69), C(70), C(71), & C(72)/-1.38860897537170405E+04, & 1.10017140269246738E+02, & -4.93292536645099620E+07, & 3.25573074185765749E+08, & -9.39462359681578403E+08, & 1.55359689957058006E+09, & -1.62108055210833708E+09, & 1.10684281682301447E+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), & C(80), C(81), C(82), C(83), C(84), C(85), C(86), & C(87), C(88)/-4.95889784275030309E+08, & 1.42062907797533095E+08, & -2.44740627257387285E+07, & 2.24376817792244943E+06, & -8.40054336030240853E+04, & 5.51335896122020586E+02, & 8.14789096118312115E+08, & -5.86648149205184723E+09, & 1.86882075092958249E+10, & -3.46320433881587779E+10, & 4.12801855797539740E+10, & -3.30265997498007231E+10, & 1.79542137311556001E+10, & -6.56329379261928433E+09, & 1.55927986487925751E+09, & -2.25105661889415278E+08/ DATA C(89), C(90), C(91), C(92), C(93), C(94), C(95), & C(96)/1.73951075539781645E+07, & -5.49842327572288687E+05, & 3.03809051092238427E+03, & -1.46792612476956167E+10, & 1.14498237732025810E+11, & -3.99096175224466498E+11, & 8.19218669548577329E+11, & -1.09837515608122331E+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), & C(103), C(104), C(105)/1.00815810686538209E+12, & -6.45364869245376503E+11, & 2.87900649906150589E+11, & -8.78670721780232657E+10, & 1.76347306068349694E+10, & -2.16716498322379509E+09, & 1.43157876718888981E+08, & -3.87183344257261262E+06, & 1.82577554742931747E+04/ DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), & ALFA(6), ALFA(7), ALFA(8), ALFA(9), ALFA(10), & ALFA(11), ALFA(12), ALFA(13), & ALFA(14)/-4.44444444444444444E-03, & -9.22077922077922078E-04, & -8.84892884892884893E-05, & 1.65927687832449737E-04, & 2.46691372741792910E-04, & 2.65995589346254780E-04, & 2.61824297061500945E-04, & 2.48730437344655609E-04, & 2.32721040083232098E-04, & 2.16362485712365082E-04, & 2.00738858762752355E-04, & 1.86267636637545172E-04, & 1.73060775917876493E-04, & 1.61091705929015752E-04/ DATA ALFA(15), ALFA(16), ALFA(17), ALFA(18), & ALFA(19), ALFA(20), ALFA(21), & ALFA(22)/1.50274774160908134E-04, & 1.40503497391269794E-04, & 1.31668816545922806E-04, & 1.23667445598253261E-04, & 1.16405271474737902E-04, & 1.09798298372713369E-04, & 1.03772410422992823E-04, & 9.82626078369363448E-05/ DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), & ALFA(27), ALFA(28), ALFA(29), ALFA(30), & ALFA(31), ALFA(32), ALFA(33), ALFA(34), & ALFA(35), ALFA(36)/9.32120517249503256E-05, & 8.85710852478711718E-05, & 8.42963105715700223E-05, & 8.03497548407791151E-05, & 7.66981345359207388E-05, & 7.33122157481777809E-05, & 7.01662625163141333E-05, & 6.72375633790160292E-05, & 6.93735541354588974E-04, & 2.32241745182921654E-04, & -1.41986273556691197E-05, & -1.16444931672048640E-04, & -1.50803558053048762E-04, & -1.55121924918096223E-04/ DATA ALFA(37), ALFA(38), ALFA(39), ALFA(40), & ALFA(41), ALFA(42), ALFA(43), & ALFA(44)/-1.46809756646465549E-04, & -1.33815503867491367E-04, & -1.19744975684254051E-04, & -1.06184319207974020E-04, & -9.37699549891194492E-05, & -8.26923045588193274E-05, & -7.29374348155221211E-05, & -6.44042357721016283E-05/ DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), & ALFA(49), ALFA(50), ALFA(51), ALFA(52), & ALFA(53), ALFA(54), ALFA(55), ALFA(56), & ALFA(57), ALFA(58)/-5.69611566009369048E-05, & -5.04731044303561628E-05, & -4.48134868008882786E-05, & -3.98688727717598864E-05, & -3.55400532972042498E-05, & -3.17414256609022480E-05, & -2.83996793904174811E-05, & -2.54522720634870566E-05, & -2.28459297164724555E-05, & -2.05352753106480604E-05, & -1.84816217627666085E-05, & -1.66519330021393806E-05, & -1.50179412980119482E-05, & -1.35554031379040526E-05/ DATA ALFA(59), ALFA(60), ALFA(61), ALFA(62), & ALFA(63), ALFA(64), ALFA(65), & ALFA(66)/-1.22434746473858131E-05, & -1.10641884811308169E-05, & -3.54211971457743841E-04, & -1.56161263945159416E-04, & 3.04465503594936410E-05, & 1.30198655773242693E-04, & 1.67471106699712269E-04, & 1.70222587683592569E-04/ DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), & ALFA(71), ALFA(72), ALFA(73), ALFA(74), & ALFA(75), ALFA(76), ALFA(77), ALFA(78), & ALFA(79), ALFA(80)/1.56501427608594704E-04, & 1.36339170977445120E-04, & 1.14886692029825128E-04, & 9.45869093034688111E-05, & 7.64498419250898258E-05, & 6.07570334965197354E-05, & 4.74394299290508799E-05, & 3.62757512005344297E-05, & 2.69939714979224901E-05, & 1.93210938247939253E-05, & 1.30056674793963203E-05, & 7.82620866744496661E-06, & 3.59257485819351583E-06, & 1.44040049814251817E-07/ DATA ALFA(81), ALFA(82), ALFA(83), ALFA(84), & ALFA(85), ALFA(86), ALFA(87), & ALFA(88)/-2.65396769697939116E-06, & -4.91346867098485910E-06, & -6.72739296091248287E-06, & -8.17269379678657923E-06, & -9.31304715093561232E-06, & -1.02011418798016441E-05, & -1.08805962510592880E-05, & -1.13875481509603555E-05/ DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), & ALFA(93), ALFA(94), ALFA(95), ALFA(96), & ALFA(97), ALFA(98), ALFA(99), ALFA(100), & ALFA(101), ALFA(102)/-1.17519675674556414E-05, & -1.19987364870944141E-05, & 3.78194199201772914E-04, & 2.02471952761816167E-04, & -6.37938506318862408E-05, & -2.38598230603005903E-04, & -3.10916256027361568E-04, & -3.13680115247576316E-04, & -2.78950273791323387E-04, & -2.28564082619141374E-04, & -1.75245280340846749E-04, & -1.25544063060690348E-04, & -8.22982872820208365E-05, & -4.62860730588116458E-05/ DATA ALFA(103), ALFA(104), ALFA(105), ALFA(106), & ALFA(107), ALFA(108), ALFA(109), & ALFA(110)/-1.72334302366962267E-05, & 5.60690482304602267E-06, & 2.31395443148286800E-05, & 3.62642745856793957E-05, & 4.58006124490188752E-05, & 5.24595294959114050E-05, & 5.68396208545815266E-05, & 5.94349820393104052E-05/ DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), & ALFA(115), ALFA(116), ALFA(117), ALFA(118), & ALFA(119), ALFA(120), ALFA(121), & ALFA(122)/6.06478527578421742E-05, & 6.08023907788436497E-05, & 6.01577894539460388E-05, & 5.89199657344698500E-05, & 5.72515823777593053E-05, & 5.52804375585852577E-05, & 5.31063773802880170E-05, & 5.08069302012325706E-05, & 4.84418647620094842E-05, & 4.60568581607475370E-05, & -6.91141397288294174E-04, & -4.29976633058871912E-04/ DATA ALFA(123), ALFA(124), ALFA(125), ALFA(126), & ALFA(127), ALFA(128), ALFA(129), & ALFA(130)/1.83067735980039018E-04, & 6.60088147542014144E-04, & 8.75964969951185931E-04, & 8.77335235958235514E-04, & 7.49369585378990637E-04, & 5.63832329756980918E-04, & 3.68059319971443156E-04, & 1.88464535514455599E-04/ DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), & ALFA(135), ALFA(136), ALFA(137), ALFA(138), & ALFA(139), ALFA(140), ALFA(141), & ALFA(142)/3.70663057664904149E-05, & -8.28520220232137023E-05, & -1.72751952869172998E-04, & -2.36314873605872983E-04, & -2.77966150694906658E-04, & -3.02079514155456919E-04, & -3.12594712643820127E-04, & -3.12872558758067163E-04, & -3.05678038466324377E-04, & -2.93226470614557331E-04, & -2.77255655582934777E-04, & -2.59103928467031709E-04/ DATA ALFA(143), ALFA(144), ALFA(145), ALFA(146), & ALFA(147), ALFA(148), ALFA(149), & ALFA(150)/-2.39784014396480342E-04, & -2.20048260045422848E-04, & -2.00443911094971498E-04, & -1.81358692210970687E-04, & -1.63057674478657464E-04, & -1.45712672175205844E-04, & -1.29425421983924587E-04, & -1.14245691942445952E-04/ DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), & ALFA(155), ALFA(156), ALFA(157), ALFA(158), & ALFA(159), ALFA(160), ALFA(161), & ALFA(162)/1.92821964248775885E-03, & 1.35592576302022234E-03, & -7.17858090421302995E-04, & -2.58084802575270346E-03, & -3.49271130826168475E-03, & -3.46986299340960628E-03, & -2.82285233351310182E-03, & -1.88103076404891354E-03, & -8.89531718383947600E-04, & 3.87912102631035228E-06, & 7.28688540119691412E-04, & 1.26566373053457758E-03/ DATA ALFA(163), ALFA(164), ALFA(165), ALFA(166), & ALFA(167), ALFA(168), ALFA(169), & ALFA(170)/1.62518158372674427E-03, & 1.83203153216373172E-03, & 1.91588388990527909E-03, & 1.90588846755546138E-03, & 1.82798982421825727E-03, & 1.70389506421121530E-03, & 1.55097127171097686E-03, & 1.38261421852276159E-03/ DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), & ALFA(175), ALFA(176), ALFA(177), ALFA(178), & ALFA(179), ALFA(180)/1.20881424230064774E-03, & 1.03676532638344962E-03, & 8.71437918068619115E-04, & 7.16080155297701002E-04, & 5.72637002558129372E-04, & 4.42089819465802277E-04, & 3.24724948503090564E-04, & 2.20342042730246599E-04, & 1.28412898401353882E-04, & 4.82005924552095464E-05/ DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), & BETA(6), BETA(7), BETA(8), BETA(9), BETA(10), & BETA(11), BETA(12), BETA(13), & BETA(14)/1.79988721413553309E-02, & 5.59964911064388073E-03, & 2.88501402231132779E-03, & 1.80096606761053941E-03, & 1.24753110589199202E-03, & 9.22878876572938311E-04, & 7.14430421727287357E-04, & 5.71787281789704872E-04, & 4.69431007606481533E-04, & 3.93232835462916638E-04, & 3.34818889318297664E-04, & 2.88952148495751517E-04, & 2.52211615549573284E-04, & 2.22280580798883327E-04/ DATA BETA(15), BETA(16), BETA(17), BETA(18), & BETA(19), BETA(20), BETA(21), & BETA(22)/1.97541838033062524E-04, & 1.76836855019718004E-04, & 1.59316899661821081E-04, & 1.44347930197333986E-04, & 1.31448068119965379E-04, & 1.20245444949302884E-04, & 1.10449144504599392E-04, & 1.01828770740567258E-04/ DATA BETA(23), BETA(24), BETA(25), BETA(26), & BETA(27), BETA(28), BETA(29), BETA(30), & BETA(31), BETA(32), BETA(33), BETA(34), & BETA(35), BETA(36)/9.41998224204237509E-05, & 8.74130545753834437E-05, & 8.13466262162801467E-05, & 7.59002269646219339E-05, & 7.09906300634153481E-05, & 6.65482874842468183E-05, & 6.25146958969275078E-05, & 5.88403394426251749E-05, & -1.49282953213429172E-03, & -8.78204709546389328E-04, & -5.02916549572034614E-04, & -2.94822138512746025E-04, & -1.75463996970782828E-04, & -1.04008550460816434E-04/ DATA BETA(37), BETA(38), BETA(39), BETA(40), & BETA(41), BETA(42), BETA(43), & BETA(44)/-5.96141953046457895E-05, & -3.12038929076098340E-05, & -1.26089735980230047E-05, & -2.42892608575730389E-07, & 8.05996165414273571E-06, & 1.36507009262147391E-05, & 1.73964125472926261E-05, & 1.98672978842133780E-05/ DATA BETA(45), BETA(46), BETA(47), BETA(48), & BETA(49), BETA(50), BETA(51), BETA(52), & BETA(53), BETA(54), BETA(55), BETA(56), & BETA(57), BETA(58)/2.14463263790822639E-05, & 2.23954659232456514E-05, & 2.28967783814712629E-05, & 2.30785389811177817E-05, & 2.30321976080909144E-05, & 2.28236073720348722E-05, & 2.25005881105292418E-05, & 2.20981015361991429E-05, & 2.16418427448103905E-05, & 2.11507649256220843E-05, & 2.06388749782170737E-05, & 2.01165241997081666E-05, & 1.95913450141179244E-05, & 1.90689367910436740E-05/ DATA BETA(59), BETA(60), BETA(61), BETA(62), & BETA(63), BETA(64), BETA(65), & BETA(66)/1.85533719641636667E-05, & 1.80475722259674218E-05, & 5.52213076721292790E-04, & 4.47932581552384646E-04, & 2.79520653992020589E-04, & 1.52468156198446602E-04, & 6.93271105657043598E-05, & 1.76258683069991397E-05/ DATA BETA(67), BETA(68), BETA(69), BETA(70), & BETA(71), BETA(72), BETA(73), BETA(74), & BETA(75), BETA(76), BETA(77), BETA(78), & BETA(79), BETA(80)/-1.35744996343269136E-05, & -3.17972413350427135E-05, & -4.18861861696693365E-05, & -4.69004889379141029E-05, & -4.87665447413787352E-05, & -4.87010031186735069E-05, & -4.74755620890086638E-05, & -4.55813058138628452E-05, & -4.33309644511266036E-05, & -4.09230193157750364E-05, & -3.84822638603221274E-05, & -3.60857167535410501E-05, & -3.37793306123367417E-05, & -3.15888560772109621E-05/ DATA BETA(81), BETA(82), BETA(83), BETA(84), & BETA(85), BETA(86), BETA(87), & BETA(88)/-2.95269561750807315E-05, & -2.75978914828335759E-05, & -2.58006174666883713E-05, & -2.41308356761280200E-05, & -2.25823509518346033E-05, & -2.11479656768912971E-05, & -1.98200638885294927E-05, & -1.85909870801065077E-05/ DATA BETA(89), BETA(90), BETA(91), BETA(92), & BETA(93), BETA(94), BETA(95), BETA(96), & BETA(97), BETA(98), BETA(99), BETA(100), & BETA(101), BETA(102)/-1.74532699844210224E-05, & -1.63997823854497997E-05, & -4.74617796559959808E-04, & -4.77864567147321487E-04, & -3.20390228067037603E-04, & -1.61105016119962282E-04, & -4.25778101285435204E-05, & 3.44571294294967503E-05, & 7.97092684075674924E-05, & 1.03138236708272200E-04, & 1.12466775262204158E-04, & 1.13103642108481389E-04, & 1.08651634848774268E-04, & 1.01437951597661973E-04/ DATA BETA(103), BETA(104), BETA(105), BETA(106), & BETA(107), BETA(108), BETA(109), & BETA(110)/9.29298396593363896E-05, & 8.40293133016089978E-05, & 7.52727991349134062E-05, & 6.69632521975730872E-05, & 5.92564547323194704E-05, & 5.22169308826975567E-05, & 4.58539485165360646E-05, & 4.01445513891486808E-05/ DATA BETA(111), BETA(112), BETA(113), BETA(114), & BETA(115), BETA(116), BETA(117), BETA(118), & BETA(119), BETA(120), BETA(121), & BETA(122)/3.50481730031328081E-05, & 3.05157995034346659E-05, & 2.64956119950516039E-05, & 2.29363633690998152E-05, & 1.97893056664021636E-05, & 1.70091984636412623E-05, & 1.45547428261524004E-05, & 1.23886640995878413E-05, & 1.04775876076583236E-05, & 8.79179954978479373E-06, & 7.36465810572578444E-04, & 8.72790805146193976E-04/ DATA BETA(123), BETA(124), BETA(125), BETA(126), & BETA(127), BETA(128), BETA(129), & BETA(130)/6.22614862573135066E-04, & 2.85998154194304147E-04, & 3.84737672879366102E-06, & -1.87906003636971558E-04, & -2.97603646594554535E-04, & -3.45998126832656348E-04, & -3.53382470916037712E-04, & -3.35715635775048757E-04/ DATA BETA(131), BETA(132), BETA(133), BETA(134), & BETA(135), BETA(136), BETA(137), BETA(138), & BETA(139), BETA(140), BETA(141), & BETA(142)/-3.04321124789039809E-04, & -2.66722723047612821E-04, & -2.27654214122819527E-04, & -1.89922611854562356E-04, & -1.55058918599093870E-04, & -1.23778240761873630E-04, & -9.62926147717644187E-05, & -7.25178327714425337E-05, & -5.22070028895633801E-05, & -3.50347750511900522E-05, & -2.06489761035551757E-05, & -8.70106096849767054E-06/ DATA BETA(143), BETA(144), BETA(145), BETA(146), & BETA(147), BETA(148), BETA(149), & BETA(150)/1.13698686675100290E-06, & 9.16426474122778849E-06, & 1.56477785428872620E-05, & 2.08223629482466847E-05, & 2.48923381004595156E-05, & 2.80340509574146325E-05, & 3.03987774629861915E-05, & 3.21156731406700616E-05/ DATA BETA(151), BETA(152), BETA(153), BETA(154), & BETA(155), BETA(156), BETA(157), BETA(158), & BETA(159), BETA(160), BETA(161), & BETA(162)/-1.80182191963885708E-03, & -2.43402962938042533E-03, & -1.83422663549856802E-03, & -7.62204596354009765E-04, & 2.39079475256927218E-04, & 9.49266117176881141E-04, & 1.34467449701540359E-03, & 1.48457495259449178E-03, & 1.44732339830617591E-03, & 1.30268261285657186E-03, & 1.10351597375642682E-03, & 8.86047440419791759E-04/ DATA BETA(163), BETA(164), BETA(165), BETA(166), & BETA(167), BETA(168), BETA(169), & BETA(170)/6.73073208165665473E-04, & 4.77603872856582378E-04, & 3.05991926358789362E-04, & 1.60315694594721630E-04, & 4.00749555270613286E-05, & -5.66607461635251611E-05, & -1.32506186772982638E-04, & -1.90296187989614057E-04/ DATA BETA(171), BETA(172), BETA(173), BETA(174), & BETA(175), BETA(176), BETA(177), BETA(178), & BETA(179), BETA(180), BETA(181), & BETA(182)/-2.32811450376937408E-04, & -2.62628811464668841E-04, & -2.82050469867598672E-04, & -2.93081563192861167E-04, & -2.97435962176316616E-04, & -2.96557334239348078E-04, & -2.91647363312090861E-04, & -2.83696203837734166E-04, & -2.73512317095673346E-04, & -2.61750155806768580E-04, & 6.38585891212050914E-03, & 9.62374215806377941E-03/ DATA BETA(183), BETA(184), BETA(185), BETA(186), & BETA(187), BETA(188), BETA(189), & BETA(190)/7.61878061207001043E-03, & 2.83219055545628054E-03, & -2.09841352012720090E-03, & -5.73826764216626498E-03, & -7.70804244495414620E-03, & -8.21011692264844401E-03, & -7.65824520346905413E-03, & -6.47209729391045177E-03/ DATA BETA(191), BETA(192), BETA(193), BETA(194), & BETA(195), BETA(196), BETA(197), BETA(198), & BETA(199), BETA(200), BETA(201), & BETA(202)/-4.99132412004966473E-03, & -3.45612289713133280E-03, & -2.01785580014170775E-03, & -7.59430686781961401E-04, & 2.84173631523859138E-04, & 1.10891667586337403E-03, & 1.72901493872728771E-03, & 2.16812590802684701E-03, & 2.45357710494539735E-03, & 2.61281821058334862E-03, & 2.67141039656276912E-03, & 2.65203073395980430E-03/ DATA BETA(203), BETA(204), BETA(205), BETA(206), & BETA(207), BETA(208), BETA(209), & BETA(210)/2.57411652877287315E-03, & 2.45389126236094427E-03, & 2.30460058071795494E-03, & 2.13684837686712662E-03, & 1.95896528478870911E-03, & 1.77737008679454412E-03, & 1.59690280765839059E-03, & 1.42111975664438546E-03/ DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), & GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), & GAMA(11), GAMA(12), GAMA(13), & GAMA(14)/6.29960524947436582E-01, & 2.51984209978974633E-01, & 1.54790300415655846E-01, & 1.10713062416159013E-01, & 8.57309395527394825E-02, & 6.97161316958684292E-02, & 5.86085671893713576E-02, & 5.04698873536310685E-02, & 4.42600580689154809E-02, & 3.93720661543509966E-02, & 3.54283195924455368E-02, & 3.21818857502098231E-02, & 2.94646240791157679E-02, & 2.71581677112934479E-02/ DATA GAMA(15), GAMA(16), GAMA(17), GAMA(18), & GAMA(19), GAMA(20), GAMA(21), & GAMA(22)/2.51768272973861779E-02, & 2.34570755306078891E-02, & 2.19508390134907203E-02, & 2.06210828235646240E-02, & 1.94388240897880846E-02, & 1.83810633800683158E-02, & 1.74293213231963172E-02, & 1.65685837786612353E-02/ DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), & GAMA(27), GAMA(28), GAMA(29), & GAMA(30)/1.57865285987918445E-02, & 1.50729501494095594E-02, & 1.44193250839954639E-02, & 1.38184805735341786E-02, & 1.32643378994276568E-02, & 1.27517121970498651E-02, & 1.22761545318762767E-02, & 1.18338262398482403E-02/ DATA EX1, EX2, HPI, PI, THPI/3.33333333333333333E-01, & 6.66666666666666667E-01, & 1.57079632679489662E+00, & 3.14159265358979324E+00, & 4.71238898038468986E+00/ DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! RFNU = 1.0E0/FNU TSTR = REAL(Z) TSTI = AIMAG(Z) TEST = FNU*EXP(-ELIM) if (ABS(TSTR) < TEST) TSTR = 0.0E0 if (ABS(TSTI) < TEST) TSTI = 0.0E0 if (TSTR == 0.0E0 .and. TSTI == 0.0E0) then ZETA1 = CMPLX(ELIM+ELIM+FNU,0.0E0) ZETA2 = CMPLX(FNU,0.0E0) PHI = CONE ARG = CONE return endif ZB = CMPLX(TSTR,TSTI)*CMPLX(RFNU,0.0E0) RFNU2 = RFNU*RFNU ! ------------------------------------------------------------------ ! COMPUTE IN THE FOURTH QUADRANT ! ------------------------------------------------------------------ FN13 = FNU**EX1 FN23 = FN13*FN13 RFN13 = CMPLX(1.0E0/FN13,0.0E0) W2 = CONE - ZB*ZB AW2 = ABS(W2) if (AW2 > 0.25E0) then ! --------------------------------------------------------------- ! CABS(W2)>0.25E0 ! --------------------------------------------------------------- W = SQRT(W2) WR = REAL(W) WI = AIMAG(W) if (WR < 0.0E0) WR = 0.0E0 if (WI < 0.0E0) WI = 0.0E0 W = CMPLX(WR,WI) ZA = (CONE+W)/ZB ZC = LOG(ZA) ZCR = REAL(ZC) ZCI = AIMAG(ZC) if (ZCI < 0.0E0) ZCI = 0.0E0 if (ZCI > HPI) ZCI = HPI if (ZCR < 0.0E0) ZCR = 0.0E0 ZC = CMPLX(ZCR,ZCI) ZTH = (ZC-W)*CMPLX(1.5E0,0.0E0) CFNU = CMPLX(FNU,0.0E0) ZETA1 = ZC*CFNU ZETA2 = W*CFNU AZTH = ABS(ZTH) ZTHR = REAL(ZTH) ZTHI = AIMAG(ZTH) ANG = THPI if (ZTHR < 0.0E0 .or. ZTHI >= 0.0E0) then ANG = HPI if (ZTHR /= 0.0E0) then ANG = ATAN(ZTHI/ZTHR) if (ZTHR < 0.0E0) ANG = ANG + PI endif endif PP = AZTH**EX2 ANG = ANG*EX2 ZETAR = PP*COS(ANG) ZETAI = PP*SIN(ANG) if (ZETAI < 0.0E0) ZETAI = 0.0E0 ZETA = CMPLX(ZETAR,ZETAI) ARG = ZETA*CMPLX(FN23,0.0E0) RTZTA = ZTH/ZETA ZA = RTZTA/W PHI = SQRT(ZA+ZA)*RFN13 if (IPMTR /= 1) then TFN = CMPLX(RFNU,0.0E0)/W RZTH = CMPLX(RFNU,0.0E0)/ZTH ZC = RZTH*CMPLX(AR(2),0.0E0) T2 = CONE/W2 UP(2) = (T2*CMPLX(C(2),0.0E0)+CMPLX(C(3),0.0E0))*TFN BSUM = UP(2) + ZC ASUM = CZERO if (RFNU >= TOL) then PRZTH = RZTH PTFN = TFN UP(1) = CONE PP = 1.0E0 BSUMR = REAL(BSUM) BSUMI = AIMAG(BSUM) BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) KS = 0 KP1 = 2 L = 3 IAS = 0 IBS = 0 DO 100 LR = 2, 12, 2 LRP1 = LR + 1 ! ------------------------------------------------------ ! COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE ! TERMS IN NEXT SUMA AND SUMB ! ------------------------------------------------------ DO 40 K = LR, LRP1 KS = KS + 1 KP1 = KP1 + 1 L = L + 1 ZA = CMPLX(C(L),0.0E0) DO 20 J = 2, KP1 L = L + 1 ZA = ZA*T2 + CMPLX(C(L),0.0E0) 20 continue PTFN = PTFN*TFN UP(KP1) = PTFN*ZA CR(KS) = PRZTH*CMPLX(BR(KS+1),0.0E0) PRZTH = PRZTH*RZTH DR(KS) = PRZTH*CMPLX(AR(KS+2),0.0E0) 40 continue PP = PP*RFNU2 if (IAS /= 1) then SUMA = UP(LRP1) JU = LRP1 DO 60 JR = 1, LR JU = JU - 1 SUMA = SUMA + CR(JR)*UP(JU) 60 continue ASUM = ASUM + SUMA ASUMR = REAL(ASUM) ASUMI = AIMAG(ASUM) TEST = ABS(ASUMR) + ABS(ASUMI) if (PP < TOL .and. TEST < TOL) IAS = 1 endif if (IBS /= 1) then SUMB = UP(LR+2) + UP(LRP1)*ZC JU = LRP1 DO 80 JR = 1, LR JU = JU - 1 SUMB = SUMB + DR(JR)*UP(JU) 80 continue BSUM = BSUM + SUMB BSUMR = REAL(BSUM) BSUMI = AIMAG(BSUM) TEST = ABS(BSUMR) + ABS(BSUMI) if (PP < BTOL .and. TEST < TOL) IBS = 1 endif if (IAS == 1 .and. IBS == 1) goto 120 100 continue endif 120 ASUM = ASUM + CONE BSUM = -BSUM*RFN13/RTZTA endif ELSE ! --------------------------------------------------------------- ! POWER SERIES FOR CABS(W2) <= 0.25E0 ! --------------------------------------------------------------- K = 1 P(1) = CONE SUMA = CMPLX(GAMA(1),0.0E0) AP(1) = 1.0E0 if (AW2 >= TOL) then DO 140 K = 2, 30 P(K) = P(K-1)*W2 SUMA = SUMA + P(K)*CMPLX(GAMA(K),0.0E0) AP(K) = AP(K-1)*AW2 if (AP(K) < TOL) goto 160 140 continue K = 30 endif 160 KMAX = K ZETA = W2*SUMA ARG = ZETA*CMPLX(FN23,0.0E0) ZA = SQRT(SUMA) ZETA2 = SQRT(W2)*CMPLX(FNU,0.0E0) ZETA1 = ZETA2*(CONE+ZETA*ZA*CMPLX(EX2,0.0E0)) ZA = ZA + ZA PHI = SQRT(ZA)*RFN13 if (IPMTR /= 1) then ! ------------------------------------------------------------ ! SUM SERIES FOR ASUM AND BSUM ! ------------------------------------------------------------ SUMB = CZERO DO 180 K = 1, KMAX SUMB = SUMB + P(K)*CMPLX(BETA(K),0.0E0) 180 continue ASUM = CZERO BSUM = SUMB L1 = 0 L2 = 30 BTOL = TOL*ABS(BSUM) ATOL = TOL PP = 1.0E0 IAS = 0 IBS = 0 if (RFNU2 >= TOL) then DO 280 IS = 2, 7 ATOL = ATOL/RFNU2 PP = PP*RFNU2 if (IAS /= 1) then SUMA = CZERO DO 200 K = 1, KMAX M = L1 + K SUMA = SUMA + P(K)*CMPLX(ALFA(M),0.0E0) if (AP(K) < ATOL) goto 220 200 continue 220 ASUM = ASUM + SUMA*CMPLX(PP,0.0E0) if (PP < TOL) IAS = 1 endif if (IBS /= 1) then SUMB = CZERO DO 240 K = 1, KMAX M = L2 + K SUMB = SUMB + P(K)*CMPLX(BETA(M),0.0E0) if (AP(K) < ATOL) goto 260 240 continue 260 BSUM = BSUM + SUMB*CMPLX(PP,0.0E0) if (PP < BTOL) IBS = 1 endif if (IAS == 1 .and. IBS == 1) then goto 300 ELSE L1 = L1 + 30 L2 = L2 + 30 endif 280 continue endif 300 ASUM = ASUM + CONE PP = RFNU*REAL(RFN13) BSUM = BSUM*CMPLX(PP,0.0E0) endif endif return END subroutine DEVS17(Z,FNU,KODE,IKFLG,N,Y,NUF,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-765 (DEC 1989). ! ! Original name: CUOIK ! ! DEVS17 COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC ! EXPANSIONS FOR THE I AND K functionS AND COMPARES THEM ! (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW ! WHERE ALIM < ELIM. IF THE MAGNITUDE, BASED ON THE LEADING ! EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN ! THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER ! MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE ! EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= ! EXP(-ELIM)/TOL ! ! IKFLG=1 MEANS THE I SEQUENCE IS TESTED ! =2 MEANS THE K SEQUENCE IS TESTED ! NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE ! =-1 MEANS AN OVERFLOW WOULD OCCUR ! IKFLG=1 AND NUF>0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO ! THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE ! IKFLG=2 AND NUF==N MEANS ALL Y VALUES WERE SET TO ZERO ! IKFLG=2 AND 0 < NUF < N NOT CONSIDERED. Y MUST BE SET BY ! ANOTHER ROUTINE ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER IKFLG, KODE, N, NUF ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX ARG, ASUM, BSUM, CZ, CZERO, PHI, SUM, ZB, ZETA1, & ZETA2, ZN, ZR REAL AARG, AIC, APHI, ASCLE, AX, AY, FNN, GNN, GNU, & RCZ, X, YY INTEGER I, IFORM, INIT, NN, NW ! .. Local Arrays .. COMPLEX CWRK(16) ! .. External functions .. REAL X02AME EXTERNAL X02AME ! .. External subroutines .. EXTERNAL DEUS17, DEWS17, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, LOG, MAX, & REAL, SIN ! .. Data statements .. DATA CZERO/(0.0E0,0.0E0)/ DATA AIC/1.265512123484645396E+00/ ! .. Executable Statements .. ! NUF = 0 NN = N X = REAL(Z) ZR = Z if (X < 0.0E0) ZR = -Z ZB = ZR YY = AIMAG(ZR) AX = ABS(X)*1.7321E0 AY = ABS(YY) IFORM = 1 if (AY > AX) IFORM = 2 GNU = MAX(FNU,1.0E0) if (IKFLG /= 1) then FNN = NN GNN = FNU + FNN - 1.0E0 GNU = MAX(GNN,FNN) endif ! ------------------------------------------------------------------ ! ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE ! REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET ! THE SIGN OF THE IMAGINARY PART CORRECT. ! ------------------------------------------------------------------ if (IFORM == 2) then ZN = -ZR*CMPLX(0.0E0,1.0E0) if (YY <= 0.0E0) ZN = CONJG(-ZN) CALL DEUS17(ZN,GNU,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM) CZ = -ZETA1 + ZETA2 AARG = ABS(ARG) ELSE INIT = 0 CALL DEWS17(ZR,GNU,IKFLG,1,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK, & ELIM) CZ = -ZETA1 + ZETA2 endif if (KODE == 2) CZ = CZ - ZB if (IKFLG == 2) CZ = -CZ APHI = ABS(PHI) RCZ = REAL(CZ) ! ------------------------------------------------------------------ ! OVERFLOW TEST ! ------------------------------------------------------------------ if (RCZ <= ELIM) then if (RCZ < ALIM) then ! ------------------------------------------------------------ ! UNDERFLOW TEST ! ------------------------------------------------------------ if (RCZ >= (-ELIM)) then if (RCZ > (-ALIM)) then goto 40 ELSE RCZ = RCZ + LOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC if (RCZ > (-ELIM)) then ASCLE = (1.0E+3*X02AME())/TOL CZ = CZ + LOG(PHI) if (IFORM /= 1) CZ = CZ - CMPLX(0.25E0,0.0E0) & *LOG(ARG) - CMPLX(AIC,0.0E0) AX = EXP(RCZ)/TOL AY = AIMAG(CZ) CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) CALL DGVS17(CZ,NW,ASCLE,TOL) if (NW /= 1) goto 40 endif endif endif DO 20 I = 1, NN Y(I) = CZERO 20 continue NUF = NN return ELSE RCZ = RCZ + LOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC if (RCZ > ELIM) goto 80 endif 40 if (IKFLG /= 2) then if (N /= 1) then 60 continue ! --------------------------------------------------------- ! SET UNDERFLOWS ON I SEQUENCE ! --------------------------------------------------------- GNU = FNU + NN - 1 if (IFORM == 2) then CALL DEUS17(ZN,GNU,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM, & BSUM,ELIM) CZ = -ZETA1 + ZETA2 AARG = ABS(ARG) ELSE INIT = 0 CALL DEWS17(ZR,GNU,IKFLG,1,TOL,INIT,PHI,ZETA1,ZETA2, & SUM,CWRK,ELIM) CZ = -ZETA1 + ZETA2 endif if (KODE == 2) CZ = CZ - ZB APHI = ABS(PHI) RCZ = REAL(CZ) if (RCZ >= (-ELIM)) then if (RCZ > (-ALIM)) then return ELSE RCZ = RCZ + LOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC if (RCZ > (-ELIM)) then ASCLE = (1.0E+3*X02AME())/TOL CZ = CZ + LOG(PHI) if (IFORM /= 1) CZ = CZ - CMPLX(0.25E0,0.0E0) & *LOG(ARG) - CMPLX(AIC, & 0.0E0) AX = EXP(RCZ)/TOL AY = AIMAG(CZ) CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) CALL DGVS17(CZ,NW,ASCLE,TOL) if (NW /= 1) return endif endif endif Y(NN) = CZERO NN = NN - 1 NUF = NUF + 1 if (NN /= 0) goto 60 endif endif return endif 80 NUF = -1 return END subroutine DEWS17(ZR,FNU,IKFLG,IPMTR,TOL,INIT,PHI,ZETA1,ZETA2,SUM, & CWRK,ELIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-766 (DEC 1989). ! ! Original name: CUNIK ! ! DEWS17 COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC ! EXPANSIONS OF THE I AND K functionS ON IKFLG= 1 OR 2 ! RESPECTIVELY BY ! ! W(FNU,ZR) = PHI*EXP(ZETA)*SUM ! ! WHERE ZETA=-ZETA1 + ZETA2 OR ! ZETA1 - ZETA2 ! ! THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE ! SAME ZR AND FNU WILL return THE I OR K function ON IKFLG= ! 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK ! ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, ! ZETA1,ZETA2. ! ! .. Scalar Arguments .. COMPLEX PHI, SUM, ZETA1, ZETA2, ZR REAL ELIM, FNU, TOL INTEGER IKFLG, INIT, IPMTR ! .. Array Arguments .. COMPLEX CWRK(16) ! .. Local Scalars .. COMPLEX CFN, CONE, CRFN, CZERO, S, SR, T, T2, ZN REAL AC, RFN, TEST, TSTI, TSTR INTEGER I, J, K, L ! .. Local Arrays .. COMPLEX CON(2) REAL C(120) !bc ! .. external functions .. real x02ane external x02ane ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, EXP, LOG, REAL, SQRT ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ DATA CON(1), CON(2)/(3.98942280401432678E-01,0.0E0), & (1.25331413731550025E+00,0.0E0)/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), & C(9), C(10), C(11), C(12), C(13), C(14), C(15), & C(16)/1.00000000000000000E+00, & -2.08333333333333333E-01, & 1.25000000000000000E-01, & 3.34201388888888889E-01, & -4.01041666666666667E-01, & 7.03125000000000000E-02, & -1.02581259645061728E+00, & 1.84646267361111111E+00, & -8.91210937500000000E-01, & 7.32421875000000000E-02, & 4.66958442342624743E+00, & -1.12070026162229938E+01, & 8.78912353515625000E+00, & -2.36408691406250000E+00, & 1.12152099609375000E-01, & -2.82120725582002449E+01/ DATA C(17), C(18), C(19), C(20), C(21), C(22), C(23), & C(24)/8.46362176746007346E+01, & -9.18182415432400174E+01, & 4.25349987453884549E+01, & -7.36879435947963170E+00, & 2.27108001708984375E-01, & 2.12570130039217123E+02, & -7.65252468141181642E+02, & 1.05999045252799988E+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), & C(32), C(33), C(34), C(35), C(36), C(37), C(38), & C(39), C(40)/-6.99579627376132541E+02, & 2.18190511744211590E+02, & -2.64914304869515555E+01, & 5.72501420974731445E-01, & -1.91945766231840700E+03, & 8.06172218173730938E+03, & -1.35865500064341374E+04, & 1.16553933368645332E+04, & -5.30564697861340311E+03, & 1.20090291321635246E+03, & -1.08090919788394656E+02, & 1.72772750258445740E+00, & 2.02042913309661486E+04, & -9.69805983886375135E+04, & 1.92547001232531532E+05, & -2.03400177280415534E+05/ DATA C(41), C(42), C(43), C(44), C(45), C(46), C(47), & C(48)/1.22200464983017460E+05, & -4.11926549688975513E+04, & 7.10951430248936372E+03, & -4.93915304773088012E+02, & 6.07404200127348304E+00, & -2.42919187900551333E+05, & 1.31176361466297720E+06, & -2.99801591853810675E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), & C(56), C(57), C(58), C(59), C(60), C(61), C(62), & C(63), C(64)/3.76327129765640400E+06, & -2.81356322658653411E+06, & 1.26836527332162478E+06, & -3.31645172484563578E+05, & 4.52187689813627263E+04, & -2.49983048181120962E+03, & 2.43805296995560639E+01, & 3.28446985307203782E+06, & -1.97068191184322269E+07, & 5.09526024926646422E+07, & -7.41051482115326577E+07, & 6.63445122747290267E+07, & -3.75671766607633513E+07, & 1.32887671664218183E+07, & -2.78561812808645469E+06, & 3.08186404612662398E+05/ DATA C(65), C(66), C(67), C(68), C(69), C(70), C(71), & C(72)/-1.38860897537170405E+04, & 1.10017140269246738E+02, & -4.93292536645099620E+07, & 3.25573074185765749E+08, & -9.39462359681578403E+08, & 1.55359689957058006E+09, & -1.62108055210833708E+09, & 1.10684281682301447E+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), & C(80), C(81), C(82), C(83), C(84), C(85), C(86), & C(87), C(88)/-4.95889784275030309E+08, & 1.42062907797533095E+08, & -2.44740627257387285E+07, & 2.24376817792244943E+06, & -8.40054336030240853E+04, & 5.51335896122020586E+02, & 8.14789096118312115E+08, & -5.86648149205184723E+09, & 1.86882075092958249E+10, & -3.46320433881587779E+10, & 4.12801855797539740E+10, & -3.30265997498007231E+10, & 1.79542137311556001E+10, & -6.56329379261928433E+09, & 1.55927986487925751E+09, & -2.25105661889415278E+08/ DATA C(89), C(90), C(91), C(92), C(93), C(94), C(95), & C(96)/1.73951075539781645E+07, & -5.49842327572288687E+05, & 3.03809051092238427E+03, & -1.46792612476956167E+10, & 1.14498237732025810E+11, & -3.99096175224466498E+11, & 8.19218669548577329E+11, & -1.09837515608122331E+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), & C(103), C(104), C(105), C(106), C(107), C(108), & C(109), C(110)/1.00815810686538209E+12, & -6.45364869245376503E+11, & 2.87900649906150589E+11, & -8.78670721780232657E+10, & 1.76347306068349694E+10, & -2.16716498322379509E+09, & 1.43157876718888981E+08, & -3.87183344257261262E+06, & 1.82577554742931747E+04, & 2.86464035717679043E+11, & -2.40629790002850396E+12, & 9.10934118523989896E+12, & -2.05168994109344374E+13, & 3.05651255199353206E+13/ DATA C(111), C(112), C(113), C(114), C(115), C(116), & C(117), C(118), C(119), & C(120)/-3.16670885847851584E+13, & 2.33483640445818409E+13, & -1.23204913055982872E+13, & 4.61272578084913197E+12, & -1.19655288019618160E+12, & 2.05914503232410016E+11, & -2.18229277575292237E+10, & 1.24700929351271032E+09, & -2.91883881222208134E+07, & 1.18838426256783253E+05/ ! .. Executable Statements .. ! if (INIT == 0) then ! --------------------------------------------------------------- ! INITIALIZE ALL VARIABLES ! --------------------------------------------------------------- RFN = 1.0E0/FNU CRFN = CMPLX(RFN,0.0E0) TSTR = REAL(ZR) TSTI = AIMAG(ZR) TEST = FNU*EXP(-ELIM) if (ABS(TSTR) < TEST) TSTR = 0.0E0 if (ABS(TSTI) < TEST) TSTI = 0.0E0 !bc if (TSTR==0.0E0 .and. TSTI==0.0E0) then if (abs(tstr) <= x02ane() .and. abs(tsti) <= x02ane()) then ZETA1 = CMPLX(ELIM+ELIM+FNU,0.0E0) ZETA2 = CMPLX(FNU,0.0E0) PHI = CONE return endif T = CMPLX(TSTR,TSTI)*CRFN S = CONE + T*T SR = SQRT(S) CFN = CMPLX(FNU,0.0E0) ZN = (CONE+SR)/T ZETA1 = CFN*LOG(ZN) ZETA2 = CFN*SR T = CONE/SR SR = T*CRFN CWRK(16) = SQRT(SR) PHI = CWRK(16)*CON(IKFLG) if (IPMTR /= 0) then return ELSE T2 = CONE/S CWRK(1) = CONE CRFN = CONE AC = 1.0E0 L = 1 DO 40 K = 2, 15 S = CZERO DO 20 J = 1, K L = L + 1 S = S*T2 + CMPLX(C(L),0.0E0) 20 continue CRFN = CRFN*SR CWRK(K) = CRFN*S AC = AC*RFN TSTR = REAL(CWRK(K)) TSTI = AIMAG(CWRK(K)) TEST = ABS(TSTR) + ABS(TSTI) if (AC < TOL .and. TEST < TOL) goto 60 40 continue K = 15 60 INIT = K endif endif if (IKFLG == 2) then ! --------------------------------------------------------------- ! COMPUTE SUM FOR THE K function ! --------------------------------------------------------------- S = CZERO T = CONE DO 80 I = 1, INIT S = S + T*CWRK(I) T = -T 80 continue SUM = S PHI = CWRK(16)*CON(2) ELSE ! --------------------------------------------------------------- ! COMPUTE SUM FOR THE I function ! --------------------------------------------------------------- S = CZERO DO 100 I = 1, INIT S = S + CWRK(I) 100 continue SUM = S PHI = CWRK(16)*CON(1) endif return END subroutine DEXS17(Z,FNU,KODE,N,Y,NZ,NLAST,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-767 (DEC 1989). ! ! Original name: CUNI1 ! ! DEXS17 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC ! EXPANSION FOR I(FNU,Z) IN -PI/3 <= ARG Z <= PI/3. ! ! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC ! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. ! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER ! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL. ! Y(I)=CZERO FOR I=NLAST+1,N ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, TOL INTEGER KODE, N, NLAST, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CFN, CONE, CRSC, CSCL, CZERO, PHI, RZ, & S1, S2, SUM, ZETA1, ZETA2 REAL APHI, ASCLE, C2I, C2M, C2R, FN, RS1, YY INTEGER I, IFLAG, INIT, K, M, ND, NN, NUF, NW ! .. Local Arrays .. COMPLEX CSR(3), CSS(3), CWRK(16), CY(2) REAL BRY(3) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEVS17, DEWS17, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MAX, MIN, & REAL, SIN ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 ND = N NLAST = 0 ! ------------------------------------------------------------------ ! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- ! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, ! EXP(ALIM)=EXP(ELIM)*TOL ! ------------------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL ! ------------------------------------------------------------------ ! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER ! ------------------------------------------------------------------ FN = MAX(FNU,1.0E0) INIT = 0 CALL DEWS17(Z,FN,1,1,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK,ELIM) if (KODE == 1) then S1 = -ZETA1 + ZETA2 ELSE CFN = CMPLX(FN,0.0E0) S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) endif RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then 20 continue NN = MIN(2,ND) DO 40 I = 1, NN FN = FNU + ND - I INIT = 0 CALL DEWS17(Z,FN,1,0,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK,ELIM) if (KODE == 1) then S1 = -ZETA1 + ZETA2 ELSE CFN = CMPLX(FN,0.0E0) YY = AIMAG(Z) S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + CMPLX(0.0E0,YY) endif ! ------------------------------------------------------------ ! TEST FOR UNDERFLOW AND OVERFLOW ! ------------------------------------------------------------ RS1 = REAL(S1) if (ABS(RS1) > ELIM) then goto 60 ELSE if (I == 1) IFLAG = 2 if (ABS(RS1) >= ALIM) then ! ------------------------------------------------------ ! REFINE TEST AND SCALE ! ------------------------------------------------------ APHI = ABS(PHI) RS1 = RS1 + LOG(APHI) if (ABS(RS1) > ELIM) then goto 60 ELSE if (I == 1) IFLAG = 1 if (RS1 >= 0.0E0) then if (I == 1) IFLAG = 3 endif endif endif ! --------------------------------------------------------- ! SCALE S1 IF CABS(S1) < ASCLE ! --------------------------------------------------------- S2 = PHI*SUM C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) goto 60 endif M = ND - I + 1 CY(I) = S2 Y(M) = S2*CSR(IFLAG) endif 40 continue goto 80 ! --------------------------------------------------------------- ! SET UNDERFLOW AND UPDATE PARAMETERS ! --------------------------------------------------------------- 60 continue if (RS1 > 0.0E0) then goto 160 ELSE Y(ND) = CZERO NZ = NZ + 1 ND = ND - 1 if (ND == 0) then return ELSE CALL DEVS17(Z,FNU,KODE,1,ND,Y,NUF,TOL,ELIM,ALIM) if (NUF < 0) then goto 160 ELSE ND = ND - NUF NZ = NZ + NUF if (ND == 0) then return ELSE FN = FNU + ND - 1 if (FN >= FNUL) then goto 20 ELSE goto 120 endif endif endif endif endif 80 if (ND > 2) then RZ = CMPLX(2.0E0,0.0E0)/Z BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() S1 = CY(1) S2 = CY(2) C1 = CSR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = K DO 100 I = 3, ND C2 = S2 S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 S1 = C2 C2 = S2*C1 Y(K) = C2 K = K - 1 FN = FN - 1.0E0 if (IFLAG < 3) then C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) C1 = CSR(IFLAG) endif endif 100 continue endif return 120 NLAST = ND return else if (RS1 <= 0.0E0) then NZ = N DO 140 I = 1, N Y(I) = CZERO 140 continue return endif 160 NZ = -1 return END subroutine DEYS17(Z,FNU,KODE,N,Y,NZ,NUI,NLAST,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-768 (DEC 1989). ! ! Original name: CBUNI ! ! DEYS17 COMPUTES THE I BESSEL function FOR LARGE CABS(Z)> ! FNUL AND FNU+N-1 < FNUL. THE ORDER IS INCREASED FROM ! FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING ! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) ! ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, TOL INTEGER KODE, N, NLAST, NUI, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX CSCL, CSCR, RZ, S1, S2, ST REAL ASCLE, AX, AY, DFNU, FNUI, GNU, STI, STM, STR, & XX, YY INTEGER I, IFLAG, IFORM, K, NL, NW ! .. Local Arrays .. COMPLEX CY(2) REAL BRY(3) ! .. External functions .. REAL X02AME EXTERNAL X02AME ! .. External subroutines .. EXTERNAL DETS17, DEXS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, MAX, REAL ! .. Executable Statements .. ! NZ = 0 XX = REAL(Z) YY = AIMAG(Z) AX = ABS(XX)*1.7321E0 AY = ABS(YY) IFORM = 1 if (AY > AX) IFORM = 2 if (NUI == 0) then if (IFORM == 2) then ! ------------------------------------------------------------ ! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 ! ------------------------------------------------------------ CALL DETS17(Z,FNU,KODE,N,Y,NW,NLAST,FNUL,TOL,ELIM,ALIM) ELSE ! ------------------------------------------------------------ ! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 ! ------------------------------------------------------------ CALL DEXS17(Z,FNU,KODE,N,Y,NW,NLAST,FNUL,TOL,ELIM,ALIM) endif if (NW >= 0) then NZ = NW return endif ELSE FNUI = NUI DFNU = FNU + N - 1 GNU = DFNU + FNUI if (IFORM == 2) then ! ------------------------------------------------------------ ! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 ! ------------------------------------------------------------ CALL DETS17(Z,GNU,KODE,2,CY,NW,NLAST,FNUL,TOL,ELIM,ALIM) ELSE ! ------------------------------------------------------------ ! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 ! ------------------------------------------------------------ CALL DEXS17(Z,GNU,KODE,2,CY,NW,NLAST,FNUL,TOL,ELIM,ALIM) endif if (NW >= 0) then if (NW /= 0) then NLAST = N ELSE AY = ABS(CY(1)) ! --------------------------------------------------------- ! SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER ! USED ! --------------------------------------------------------- BRY(1) = (1.0E+3*X02AME())/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = BRY(2) IFLAG = 2 ASCLE = BRY(2) AX = 1.0E0 CSCL = CMPLX(AX,0.0E0) if (AY <= BRY(1)) then IFLAG = 1 ASCLE = BRY(1) AX = 1.0E0/TOL CSCL = CMPLX(AX,0.0E0) else if (AY >= BRY(2)) then IFLAG = 3 ASCLE = BRY(3) AX = TOL CSCL = CMPLX(AX,0.0E0) endif AY = 1.0E0/AX CSCR = CMPLX(AY,0.0E0) S1 = CY(2)*CSCL S2 = CY(1)*CSCL RZ = CMPLX(2.0E0,0.0E0)/Z DO 20 I = 1, NUI ST = S2 S2 = CMPLX(DFNU+FNUI,0.0E0)*RZ*S2 + S1 S1 = ST FNUI = FNUI - 1.0E0 if (IFLAG < 3) then ST = S2*CSCR STR = REAL(ST) STI = AIMAG(ST) STR = ABS(STR) STI = ABS(STI) STM = MAX(STR,STI) if (STM > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CSCR S2 = ST AX = AX*TOL AY = 1.0E0/AX CSCL = CMPLX(AX,0.0E0) CSCR = CMPLX(AY,0.0E0) S1 = S1*CSCL S2 = S2*CSCL endif endif 20 continue Y(N) = S2*CSCR if (N /= 1) then NL = N - 1 FNUI = NL K = NL DO 40 I = 1, NL ST = S2 S2 = CMPLX(FNU+FNUI,0.0E0)*RZ*S2 + S1 S1 = ST ST = S2*CSCR Y(K) = ST FNUI = FNUI - 1.0E0 K = K - 1 if (IFLAG < 3) then STR = REAL(ST) STI = AIMAG(ST) STR = ABS(STR) STI = ABS(STI) STM = MAX(STR,STI) if (STM > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CSCR S2 = ST AX = AX*TOL AY = 1.0E0/AX CSCL = CMPLX(AX,0.0E0) CSCR = CMPLX(AY,0.0E0) S1 = S1*CSCL S2 = S2*CSCL endif endif 40 continue endif endif return endif endif NZ = -1 if (NW == (-2)) NZ = -2 return END subroutine DEZS17(Z,FNU,KODE,N,CY,NZ,RL,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-769 (DEC 1989). ! ! Original name: CBINU ! ! DEZS17 COMPUTES THE I function IN THE RIGHT HALF Z PLANE ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, RL, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX CY(N) ! .. Local Scalars .. COMPLEX CZERO REAL AZ, DFNU INTEGER I, INW, NLAST, NN, NUI, NW ! .. Local Arrays .. COMPLEX CW(2) ! .. External subroutines .. EXTERNAL DESS17, DEVS17, DEYS17, DGRS17, DGTS17, DGYS17 ! .. Intrinsic functions .. INTRINSIC ABS, INT, MAX ! .. Data statements .. DATA CZERO/(0.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 AZ = ABS(Z) NN = N DFNU = FNU + N - 1 if (AZ > 2.0E0) then if (AZ*AZ*0.25E0 > DFNU+1.0E0) goto 20 endif ! ------------------------------------------------------------------ ! POWER SERIES ! ------------------------------------------------------------------ CALL DGRS17(Z,FNU,KODE,NN,CY,NW,TOL,ELIM,ALIM) INW = ABS(NW) NZ = NZ + INW NN = NN - INW if (NN == 0) then return else if (NW >= 0) then return ELSE DFNU = FNU + NN - 1 endif 20 if (AZ >= RL) then if (DFNU > 1.0E0) then if (AZ+AZ < DFNU*DFNU) goto 40 endif ! --------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR LARGE Z ! --------------------------------------------------------------- CALL DGYS17(Z,FNU,KODE,NN,CY,NW,RL,TOL,ELIM,ALIM) if (NW < 0) then goto 120 ELSE return endif else if (DFNU <= 1.0E0) then goto 100 endif ! ------------------------------------------------------------------ ! OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM ! ------------------------------------------------------------------ 40 CALL DEVS17(Z,FNU,KODE,1,NN,CY,NW,TOL,ELIM,ALIM) if (NW < 0) then goto 120 ELSE NZ = NZ + NW NN = NN - NW if (NN == 0) then return ELSE DFNU = FNU + NN - 1 if (DFNU <= FNUL) then if (AZ <= FNUL) goto 60 endif ! ------------------------------------------------------------ ! INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD ! ------------------------------------------------------------ NUI = INT(FNUL-DFNU) + 1 NUI = MAX(NUI,0) CALL DEYS17(Z,FNU,KODE,NN,CY,NW,NUI,NLAST,FNUL,TOL,ELIM, & ALIM) if (NW < 0) then goto 120 ELSE NZ = NZ + NW if (NLAST == 0) then return ELSE NN = NLAST endif endif 60 if (AZ > RL) then ! --------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN ! --------------------------------------------------------- ! --------------------------------------------------------- ! OVERFLOW TEST ON K functionS USED IN WRONSKIAN ! --------------------------------------------------------- CALL DEVS17(Z,FNU,KODE,2,2,CW,NW,TOL,ELIM,ALIM) if (NW < 0) then NZ = NN DO 80 I = 1, NN CY(I) = CZERO 80 continue return else if (NW > 0) then goto 120 ELSE CALL DESS17(Z,FNU,KODE,NN,CY,NW,CW,TOL,ELIM,ALIM) if (NW < 0) then goto 120 ELSE return endif endif endif endif endif ! ------------------------------------------------------------------ ! MILLER ALGORITHM NORMALIZED BY THE SERIES ! ------------------------------------------------------------------ 100 CALL DGTS17(Z,FNU,KODE,NN,CY,NW,TOL) if (NW >= 0) return 120 NZ = -1 if (NW == (-2)) NZ = -2 if (NW == (-3)) NZ = -3 return END subroutine DGRS17(Z,FNU,KODE,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-771 (DEC 1989). ! ! Original name: CSERI ! ! DGRS17 COMPUTES THE I BESSEL function FOR REAL(Z) >= 0.0 BY ! MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE ! REGION CABS(Z) <= 2*SQRT(FNU+1). NZ=0 IS A NORMAL return. ! NZ>0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO ! DUE TO UNDERFLOW. NZ < 0 MEANS UNDERFLOW OCCURRED, BUT THE ! CONDITION CABS(Z) <= 2*SQRT(FNU+1) WAS VIOLATED AND THE ! COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX AK1, CK, COEF, CONE, CRSC, CZ, CZERO, HZ, RZ, & S1, S2 REAL AA, ACZ, AK, ARM, ASCLE, ATOL, AZ, DFNU, FNUP, & RAK1, RS, RTR1, S, SS, X INTEGER I, IB, IDUM, IFLAG, IL, K, L, M, NN, NW ! .. Local Arrays .. COMPLEX W(2) ! .. External functions .. REAL S14ABE, X02AME EXTERNAL S14ABE, X02AME ! .. External subroutines .. EXTERNAL DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, REAL, & SIN, SQRT ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 AZ = ABS(Z) if (AZ /= 0.0E0) then X = REAL(Z) ARM = 1.0E+3*X02AME() RTR1 = SQRT(ARM) CRSC = CMPLX(1.0E0,0.0E0) IFLAG = 0 if (AZ < ARM) then NZ = N if (FNU == 0.0E0) NZ = NZ - 1 ELSE HZ = Z*CMPLX(0.5E0,0.0E0) CZ = CZERO if (AZ > RTR1) CZ = HZ*HZ ACZ = ABS(CZ) NN = N CK = LOG(HZ) 20 continue DFNU = FNU + NN - 1 FNUP = DFNU + 1.0E0 ! ------------------------------------------------------------ ! UNDERFLOW TEST ! ------------------------------------------------------------ AK1 = CK*CMPLX(DFNU,0.0E0) IDUM = 0 ! S14ABE assumed not to fail, therefore IDUM set to zero. AK = S14ABE(FNUP,IDUM) AK1 = AK1 - CMPLX(AK,0.0E0) if (KODE == 2) AK1 = AK1 - CMPLX(X,0.0E0) RAK1 = REAL(AK1) if (RAK1 > (-ELIM)) then if (RAK1 <= (-ALIM)) then IFLAG = 1 SS = 1.0E0/TOL CRSC = CMPLX(TOL,0.0E0) ASCLE = ARM*SS endif AK = AIMAG(AK1) AA = EXP(RAK1) if (IFLAG == 1) AA = AA*SS COEF = CMPLX(AA,0.0E0)*CMPLX(COS(AK),SIN(AK)) ATOL = TOL*ACZ/FNUP IL = MIN(2,NN) DO 60 I = 1, IL DFNU = FNU + NN - I FNUP = DFNU + 1.0E0 S1 = CONE if (ACZ >= TOL*FNUP) then AK1 = CONE AK = FNUP + 2.0E0 S = FNUP AA = 2.0E0 40 continue RS = 1.0E0/S AK1 = AK1*CZ*CMPLX(RS,0.0E0) S1 = S1 + AK1 S = S + AK AK = AK + 2.0E0 AA = AA*ACZ*RS if (AA > ATOL) goto 40 endif M = NN - I + 1 S2 = S1*COEF W(I) = S2 if (IFLAG /= 0) then CALL DGVS17(S2,NW,ASCLE,TOL) if (NW /= 0) goto 80 endif Y(M) = S2*CRSC if (I /= IL) COEF = COEF*CMPLX(DFNU,0.0E0)/HZ 60 continue goto 100 endif 80 NZ = NZ + 1 Y(NN) = CZERO if (ACZ > DFNU) then goto 180 ELSE NN = NN - 1 if (NN == 0) then return ELSE goto 20 endif endif 100 if (NN > 2) then K = NN - 2 AK = K RZ = (CONE+CONE)/Z if (IFLAG == 1) then ! ------------------------------------------------------ ! RECUR BACKWARD WITH SCALED VALUES ! ------------------------------------------------------ ! ------------------------------------------------------ ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE ! THE UNDERFLOW LIMIT = ASCLE = X02AME()*CSCL*1.0E+3 ! ------------------------------------------------------ S1 = W(1) S2 = W(2) DO 120 L = 3, NN CK = S2 S2 = S1 + CMPLX(AK+FNU,0.0E0)*RZ*S2 S1 = CK CK = S2*CRSC Y(K) = CK AK = AK - 1.0E0 K = K - 1 if (ABS(CK) > ASCLE) goto 140 120 continue return 140 IB = L + 1 if (IB > NN) return ELSE IB = 3 endif DO 160 I = IB, NN Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) AK = AK - 1.0E0 K = K - 1 160 continue endif return ! ------------------------------------------------------------ ! return WITH NZ < 0 IF CABS(Z*Z/4)>FNU+N-NZ-1 COMPLETE ! THE CALCULATION IN DEZS17 WITH N=N-IABS(NZ) ! ------------------------------------------------------------ 180 continue NZ = -NZ return endif endif Y(1) = CZERO if (FNU == 0.0E0) Y(1) = CONE if (N /= 1) then DO 200 I = 2, N Y(I) = CZERO 200 continue endif return END subroutine DGSS17(ZR,S1,S2,NZ,ASCLE,ALIM,IUF) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-772 (DEC 1989). ! ! Original name: CS1S2 ! ! DGSS17 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE ! ADDITION OF THE I AND K functionS IN THE ANALYTIC CON- ! TINUATION FORMULA WHERE S1=K function AND S2=I function. ! ON KODE=1 THE I AND K functionS ARE DIFFERENT ORDERS OF ! MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER ! OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE ! PRECISION ABOVE THE UNDERFLOW LIMIT. ! ! .. Scalar Arguments .. COMPLEX S1, S2, ZR REAL ALIM, ASCLE INTEGER IUF, NZ ! .. Local Scalars .. COMPLEX C1, CZERO, S1D REAL AA, ALN, AS1, AS2, XX INTEGER IF1 ! .. External functions .. COMPLEX S01EAE EXTERNAL S01EAE ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, LOG, MAX, REAL ! .. Data statements .. DATA CZERO/(0.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 AS1 = ABS(S1) AS2 = ABS(S2) AA = REAL(S1) ALN = AIMAG(S1) if (AA /= 0.0E0 .or. ALN /= 0.0E0) then if (AS1 /= 0.0E0) then XX = REAL(ZR) ALN = -XX - XX + LOG(AS1) S1D = S1 S1 = CZERO AS1 = 0.0E0 if (ALN >= (-ALIM)) then C1 = LOG(S1D) - ZR - ZR ! S1 = EXP(C1) IF1 = 1 S1 = S01EAE(C1,IF1) AS1 = ABS(S1) IUF = IUF + 1 endif endif endif AA = MAX(AS1,AS2) if (AA <= ASCLE) then S1 = CZERO S2 = CZERO NZ = 1 IUF = 0 endif return END subroutine DGTS17(Z,FNU,KODE,N,Y,NZ,TOL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-773 (DEC 1989). ! Mark 17 REVISED. IER-1703 (JUN 1995). ! ! Original name: CMLRI ! ! DGTS17 COMPUTES THE I BESSEL function FOR RE(Z) >= 0.0 BY THE ! MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. ! ! .. Scalar Arguments .. COMPLEX Z REAL FNU, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX CK, CNORM, CONE, CTWO, CZERO, P1, P2, PT, RZ, & SUM REAL ACK, AK, AP, AT, AZ, BK, FKAP, FKK, FLAM, FNF, & RHO, RHO2, SCLE, TFNF, TST, X INTEGER I, IAZ, IDUM, IFL, IFNU, INU, ITIME, K, KK, KM, & M ! .. External functions .. COMPLEX S01EAE REAL S14ABE, X02ANE EXTERNAL S14ABE, S01EAE, X02ANE ! .. Intrinsic functions .. INTRINSIC ABS, CMPLX, CONJG, EXP, INT, LOG, MAX, MIN, & REAL, SQRT ! .. Data statements .. DATA CZERO, CONE, CTWO/(0.0E0,0.0E0), (1.0E0,0.0E0), & (2.0E0,0.0E0)/ ! .. Executable Statements .. ! SCLE = (1.0E+3*X02ANE())/TOL NZ = 0 AZ = ABS(Z) X = REAL(Z) IAZ = INT(AZ) IFNU = INT(FNU) INU = IFNU + N - 1 AT = IAZ + 1.0E0 CK = CMPLX(AT,0.0E0)/Z RZ = CTWO/Z P1 = CZERO P2 = CONE ACK = (AT+1.0E0)/AZ RHO = ACK + SQRT(ACK*ACK-1.0E0) RHO2 = RHO*RHO TST = (RHO2+RHO2)/((RHO2-1.0E0)*(RHO-1.0E0)) TST = TST/TOL ! ------------------------------------------------------------------ ! COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES ! ------------------------------------------------------------------ AK = AT DO 20 I = 1, 80 PT = P2 P2 = P1 - CK*P2 P1 = PT CK = CK + RZ AP = ABS(P2) if (AP > TST*AK*AK) then goto 40 ELSE AK = AK + 1.0E0 endif 20 continue goto 180 40 I = I + 1 K = 0 if (INU >= IAZ) then ! --------------------------------------------------------------- ! COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS ! --------------------------------------------------------------- P1 = CZERO P2 = CONE AT = INU + 1.0E0 CK = CMPLX(AT,0.0E0)/Z ACK = AT/AZ TST = SQRT(ACK/TOL) ITIME = 1 DO 60 K = 1, 80 PT = P2 P2 = P1 - CK*P2 P1 = PT CK = CK + RZ AP = ABS(P2) if (AP >= TST) then if (ITIME == 2) then goto 80 ELSE ACK = ABS(CK) FLAM = ACK + SQRT(ACK*ACK-1.0E0) FKAP = AP/ABS(P1) RHO = MIN(FLAM,FKAP) TST = TST*SQRT(RHO/(RHO*RHO-1.0E0)) ITIME = 2 endif endif 60 continue goto 180 endif ! ------------------------------------------------------------------ ! BACKWARD RECURRENCE AND SUM NORMALIZING RELATION ! ------------------------------------------------------------------ 80 K = K + 1 KK = MAX(I+IAZ,K+INU) FKK = KK P1 = CZERO ! ------------------------------------------------------------------ ! SCALE P2 AND SUM BY SCLE ! ------------------------------------------------------------------ P2 = CMPLX(SCLE,0.0E0) FNF = FNU - IFNU TFNF = FNF + FNF IDUM = 0 ! S14ABE assumed not to fail, therefore IDUM set to zero. BK = S14ABE(FKK+TFNF+1.0E0,IDUM) - S14ABE(FKK+1.0E0,IDUM) - & S14ABE(TFNF+1.0E0,IDUM) BK = EXP(BK) SUM = CZERO KM = KK - INU DO 100 I = 1, KM PT = P2 P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 P1 = PT AK = 1.0E0 - TFNF/(FKK+TFNF) ACK = BK*AK SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 BK = ACK FKK = FKK - 1.0E0 100 continue Y(N) = P2 if (N /= 1) then DO 120 I = 2, N PT = P2 P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 P1 = PT AK = 1.0E0 - TFNF/(FKK+TFNF) ACK = BK*AK SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 BK = ACK FKK = FKK - 1.0E0 M = N - I + 1 Y(M) = P2 120 continue endif if (IFNU > 0) then DO 140 I = 1, IFNU PT = P2 P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 P1 = PT AK = 1.0E0 - TFNF/(FKK+TFNF) ACK = BK*AK SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 BK = ACK FKK = FKK - 1.0E0 140 continue endif PT = Z if (KODE == 2) PT = PT - CMPLX(X,0.0E0) P1 = -CMPLX(FNF,0.0E0)*LOG(RZ) + PT IDUM = 0 ! S14ABE assumed not to fail, therefore IDUM set to zero. AP = S14ABE(1.0E0+FNF,IDUM) PT = P1 - CMPLX(AP,0.0E0) ! ------------------------------------------------------------------ ! THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW ! IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES ! ------------------------------------------------------------------ P2 = P2 + SUM AP = ABS(P2) P1 = CMPLX(1.0E0/AP,0.0E0) ! CK = EXP(PT)*P1 IFL = 1 CK = S01EAE(PT,IFL)*P1 if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 200 PT = CONJG(P2)*P1 CNORM = CK*PT DO 160 I = 1, N Y(I) = Y(I)*CNORM 160 continue return 180 NZ = -2 return 200 NZ = -3 return END subroutine DGUS17(Z,CSH,CCH) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-774 (DEC 1989). ! ! Original name: CSHCH ! ! DGUS17 COMPUTES THE COMPLEX HYPERBOLIC functionS CSH=SINH(X+I*Y) ! AND CCH=COSH(X+I*Y), WHERE I**2=-1. ! ! .. Scalar Arguments .. COMPLEX CCH, CSH, Z ! .. Local Scalars .. REAL CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y ! .. Intrinsic functions .. INTRINSIC AIMAG, CMPLX, COS, COSH, REAL, SIN, SINH ! .. Executable Statements .. ! X = REAL(Z) Y = AIMAG(Z) SH = SINH(X) CH = COSH(X) SN = SIN(Y) CN = COS(Y) CSHR = SH*CN CSHI = CH*SN CSH = CMPLX(CSHR,CSHI) CCHR = CH*CN CCHI = SH*SN CCH = CMPLX(CCHR,CCHI) return END subroutine DGVS17(Y,NZ,ASCLE,TOL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-775 (DEC 1989). ! ! Original name: CUCHK ! ! Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN ! EXP(-ALIM)=ASCLE=1.0E+3*X02AME()/TOL. THE TEST IS MADE TO SEE ! IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW ! WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED ! IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE ! OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE ! ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. ! ! .. Scalar Arguments .. COMPLEX Y REAL ASCLE, TOL INTEGER NZ ! .. Local Scalars .. REAL SS, ST, YI, YR ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, MAX, MIN, REAL ! .. Executable Statements .. ! NZ = 0 YR = REAL(Y) YI = AIMAG(Y) YR = ABS(YR) YI = ABS(YI) ST = MIN(YR,YI) if (ST <= ASCLE) then SS = MAX(YR,YI) ST = ST/TOL if (SS < ST) NZ = 1 endif return END subroutine DGWS17(ZR,FNU,N,Y,NZ,RZ,ASCLE,TOL,ELIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-776 (DEC 1989). ! ! Original name: CKSCL ! ! SET K functionS TO ZERO ON UNDERFLOW, continue RECURRENCE ! ON SCALED functionS UNTIL TWO MEMBERS COME ON SCALE, THEN ! return WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. ! ! .. Scalar Arguments .. COMPLEX RZ, ZR REAL ASCLE, ELIM, FNU, TOL INTEGER N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX CELM, CK, CS, CZERO, S1, S2, ZD REAL AA, ACS, ALAS, AS, CSI, CSR, ELM, FN, HELIM, XX, & ZRI INTEGER I, IC, K, KK, NN, NW ! .. Local Arrays .. COMPLEX CY(2) ! .. External subroutines .. EXTERNAL DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, REAL, SIN ! .. Data statements .. DATA CZERO/(0.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 IC = 0 XX = REAL(ZR) NN = MIN(2,N) DO 20 I = 1, NN S1 = Y(I) CY(I) = S1 AS = ABS(S1) ACS = -XX + LOG(AS) NZ = NZ + 1 Y(I) = CZERO if (ACS >= (-ELIM)) then CS = -ZR + LOG(S1) CSR = REAL(CS) CSI = AIMAG(CS) AA = EXP(CSR)/TOL CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) CALL DGVS17(CS,NW,ASCLE,TOL) if (NW == 0) then Y(I) = CS NZ = NZ - 1 IC = I endif endif 20 continue if (N /= 1) then if (IC <= 1) then Y(1) = CZERO NZ = 2 endif if (N /= 2) then if (NZ /= 0) then FN = FNU + 1.0E0 CK = CMPLX(FN,0.0E0)*RZ S1 = CY(1) S2 = CY(2) HELIM = 0.5E0*ELIM ELM = EXP(-ELIM) CELM = CMPLX(ELM,0.0E0) ZRI = AIMAG(ZR) ZD = ZR ! ! FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE ! RECURRENCE IF S2 GETS LARGER THAN EXP(ELIM/2) ! DO 40 I = 3, N KK = I CS = S2 S2 = CK*S2 + S1 S1 = CS CK = CK + RZ AS = ABS(S2) ALAS = LOG(AS) ACS = -XX + ALAS NZ = NZ + 1 Y(I) = CZERO if (ACS >= (-ELIM)) then CS = -ZD + LOG(S2) CSR = REAL(CS) CSI = AIMAG(CS) AA = EXP(CSR)/TOL CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) CALL DGVS17(CS,NW,ASCLE,TOL) if (NW == 0) then Y(I) = CS NZ = NZ - 1 if (IC == (KK-1)) then goto 60 ELSE IC = KK goto 40 endif endif endif if (ALAS >= HELIM) then XX = XX - ELIM S1 = S1*CELM S2 = S2*CELM ZD = CMPLX(XX,ZRI) endif 40 continue NZ = N if (IC == N) NZ = N - 1 goto 80 60 NZ = KK - 2 80 DO 100 K = 1, NZ Y(K) = CZERO 100 continue endif endif endif return END subroutine DGXS17(Z,FNU,KODE,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-777 (DEC 1989). ! ! Original name: CBKNU ! ! DGXS17 COMPUTES THE K BESSEL function IN THE RIGHT HALF Z PLANE ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX CCH, CELM, CK, COEF, CONE, CRSC, CS, CSCL, CSH, & CTWO, CZ, CZERO, F, FMU, P, P1, P2, PT, Q, RZ, & S1, S2, SMU, ST, ZD REAL A1, A2, AA, AK, ALAS, AS, ASCLE, BB, BK, CAZ, & DNU, DNU2, ELM, ETEST, FC, FHS, FK, FKS, FPI, & G1, G2, HELIM, HPI, P2I, P2M, P2R, PI, R1, RK, & RTHPI, S, SPI, T1, T2, TM, TTH, XD, XX, YD, YY INTEGER I, IC, IDUM, IFL, IFLAG, INU, INUB, J, K, KFLAG, & KK, KMAX, KODED, NW ! .. Local Arrays .. COMPLEX CSR(3), CSS(3), CY(2) REAL BRY(3), CC(8) ! .. External functions .. COMPLEX S01EAE REAL S14ABE, X02AME, X02ALE INTEGER X02BHE, X02BJE EXTERNAL S14ABE, S01EAE, X02AME, X02ALE, X02BHE, X02BJE ! .. External subroutines .. EXTERNAL DGUS17, DGVS17, DGWS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, ATAN, CMPLX, CONJG, COS, EXP, INT, & LOG, LOG10, MAX, MIN, REAL, SIN, SQRT ! .. Data statements .. ! ! ! DATA KMAX/30/ DATA R1/2.0E0/ DATA CZERO, CONE, CTWO/(0.0E0,0.0E0), (1.0E0,0.0E0), & (2.0E0,0.0E0)/ DATA PI, RTHPI, SPI, HPI, FPI, & TTH/3.14159265358979324E0, & 1.25331413731550025E0, 1.90985931710274403E0, & 1.57079632679489662E0, 1.89769999331517738E0, & 6.66666666666666666E-01/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), & CC(8)/5.77215664901532861E-01, & -4.20026350340952355E-02, & -4.21977345555443367E-02, & 7.21894324666309954E-03, & -2.15241674114950973E-04, & -2.01348547807882387E-05, & 1.13302723198169588E-06, & 6.11609510448141582E-09/ ! .. Executable Statements .. ! XX = REAL(Z) YY = AIMAG(Z) CAZ = ABS(Z) CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() NZ = 0 IFLAG = 0 KODED = KODE RZ = CTWO/Z INU = INT(FNU+0.5E0) DNU = FNU - INU if (ABS(DNU) /= 0.5E0) then DNU2 = 0.0E0 if (ABS(DNU) > TOL) DNU2 = DNU*DNU if (CAZ <= R1) then ! ------------------------------------------------------------ ! SERIES FOR CABS(Z) <= R1 ! ------------------------------------------------------------ FC = 1.0E0 SMU = LOG(RZ) FMU = SMU*CMPLX(DNU,0.0E0) CALL DGUS17(FMU,CSH,CCH) if (DNU /= 0.0E0) then FC = DNU*PI FC = FC/SIN(FC) SMU = CSH*CMPLX(1.0E0/DNU,0.0E0) endif A2 = 1.0E0 + DNU ! ------------------------------------------------------------ ! GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), ! T2=1/GAM(1+DNU) ! ------------------------------------------------------------ IDUM = 0 ! S14ABE assumed not to fail, therefore IDUM set to zero. T2 = EXP(-S14ABE(A2,IDUM)) T1 = 1.0E0/(T2*FC) if (ABS(DNU) > 0.1E0) then G1 = (T1-T2)/(DNU+DNU) ELSE ! --------------------------------------------------------- ! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) ! --------------------------------------------------------- AK = 1.0E0 S = CC(1) DO 20 K = 2, 8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM if (ABS(TM) < TOL) goto 40 20 continue 40 G1 = -S endif G2 = 0.5E0*(T1+T2)*FC G1 = G1*FC F = CMPLX(G1,0.0E0)*CCH + SMU*CMPLX(G2,0.0E0) IFL = 1 PT = S01EAE(FMU,IFL) if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320 P = CMPLX(0.5E0/T2,0.0E0)*PT Q = CMPLX(0.5E0/T1,0.0E0)/PT S1 = F S2 = P AK = 1.0E0 A1 = 1.0E0 CK = CONE BK = 1.0E0 - DNU2 if (INU > 0 .or. N > 1) then ! --------------------------------------------------------- ! GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE ! --------------------------------------------------------- if (CAZ >= TOL) then CZ = Z*Z*CMPLX(0.25E0,0.0E0) T1 = 0.25E0*CAZ*CAZ 60 continue F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) RK = 1.0E0/AK CK = CK*CZ*CMPLX(RK,0.0E0) S1 = S1 + CK*F S2 = S2 + CK*(P-F*CMPLX(AK,0.0E0)) A1 = A1*T1*RK BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 if (A1 > TOL) goto 60 endif KFLAG = 2 BK = REAL(SMU) A1 = FNU + 1.0E0 AK = A1*ABS(BK) if (AK > ALIM) KFLAG = 3 P2 = S2*CSS(KFLAG) S2 = P2*RZ S1 = S1*CSS(KFLAG) if (KODED /= 1) then ! F = EXP(Z) IFL = 1 F = S01EAE(Z,IFL) if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320 S1 = S1*F S2 = S2*F endif goto 160 ELSE ! --------------------------------------------------------- ! GENERATE K(FNU,Z), 0.0D0 <= FNU < 0.5D0 AND N=1 ! --------------------------------------------------------- if (CAZ >= TOL) then CZ = Z*Z*CMPLX(0.25E0,0.0E0) T1 = 0.25E0*CAZ*CAZ 80 continue F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) RK = 1.0E0/AK CK = CK*CZ*CMPLX(RK,0.0E0) S1 = S1 + CK*F A1 = A1*T1*RK BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 if (A1 > TOL) goto 80 endif Y(1) = S1 ! if (KODED /= 1) Y(1) = S1*EXP(Z) if (KODED /= 1) then IFL = 1 Y(1) = S01EAE(Z,IFL) if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320 Y(1) = S1*Y(1) endif return endif endif endif ! ------------------------------------------------------------------ ! IFLAG=0 MEANS NO UNDERFLOW OCCURRED ! IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH ! KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD ! RECURSION ! ------------------------------------------------------------------ COEF = CMPLX(RTHPI,0.0E0)/SQRT(Z) KFLAG = 2 if (KODED /= 2) then if (XX > ALIM) then ! ------------------------------------------------------------ ! SCALE BY EXP(Z), IFLAG = 1 CASES ! ------------------------------------------------------------ KODED = 2 IFLAG = 1 KFLAG = 2 ELSE ! BLANK LINE ! A1 = EXP(-XX)*REAL(CSS(KFLAG)) ! PT = CMPLX(A1,0.0E0)*CMPLX(COS(YY),-SIN(YY)) IFL = 1 PT = S01EAE(CMPLX(-XX,-YY),IFL) if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320 PT = PT*REAL(CSS(KFLAG)) COEF = COEF*PT endif endif if (ABS(DNU) /= 0.5E0) then ! --------------------------------------------------------------- ! MILLER ALGORITHM FOR CABS(Z)>R1 ! --------------------------------------------------------------- AK = COS(PI*DNU) AK = ABS(AK) if (AK /= 0.0E0) then FHS = ABS(0.25E0-DNU2) if (FHS /= 0.0E0) then ! --------------------------------------------------------- ! COMPUTE R2=F(E). IF CABS(Z) >= R2, USE FORWARD RECURRENCE ! TO DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT ! LINE ON 12 <= E <= 60. E IS COMPUTED FROM ! 2**(-E)=B**(1-X02BJE())=TOL WHERE B IS THE BASE OF THE ! ARITHMETIC. ! --------------------------------------------------------- T1 = (X02BJE()-1)*LOG10(REAL(X02BHE()))*3.321928094E0 T1 = MAX(T1,12.0E0) T1 = MIN(T1,60.0E0) T2 = TTH*T1 - 6.0E0 if (XX /= 0.0E0) then T1 = ATAN(YY/XX) T1 = ABS(T1) ELSE T1 = HPI endif if (T2 > CAZ) then ! ------------------------------------------------------ ! COMPUTE BACKWARD INDEX K FOR CABS(Z) < R2 ! ------------------------------------------------------ A2 = SQRT(CAZ) AK = FPI*AK/(TOL*SQRT(A2)) AA = 3.0E0*T1/(1.0E0+CAZ) BB = 14.7E0*T1/(28.0E0+CAZ) AK = (LOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB) FK = 0.12125E0*AK*AK/CAZ + 1.5E0 ELSE ! ------------------------------------------------------ ! FORWARD RECURRENCE LOOP WHEN CABS(Z) >= R2 ! ------------------------------------------------------ ETEST = AK/(PI*CAZ*TOL) FK = 1.0E0 if (ETEST >= 1.0E0) then FKS = 2.0E0 RK = CAZ + CAZ + 2.0E0 A1 = 0.0E0 A2 = 1.0E0 DO 100 I = 1, KMAX AK = FHS/FKS BK = RK/(FK+1.0E0) TM = A2 A2 = BK*A2 - AK*A1 A1 = TM RK = RK + 2.0E0 FKS = FKS + FK + FK + 2.0E0 FHS = FHS + FK + FK FK = FK + 1.0E0 TM = ABS(A2)*FK if (ETEST < TM) goto 120 100 continue NZ = -2 return 120 FK = FK + SPI*T1*SQRT(T2/CAZ) FHS = ABS(0.25E0-DNU2) endif endif K = INT(FK) ! --------------------------------------------------------- ! BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM ! --------------------------------------------------------- FK = K FKS = FK*FK P1 = CZERO P2 = CMPLX(TOL,0.0E0) CS = P2 DO 140 I = 1, K A1 = FKS - FK A2 = (FKS+FK)/(A1+FHS) RK = 2.0E0/(FK+1.0E0) T1 = (FK+XX)*RK T2 = YY*RK PT = P2 P2 = (P2*CMPLX(T1,T2)-P1)*CMPLX(A2,0.0E0) P1 = PT CS = CS + P2 FKS = A1 - FK + 1.0E0 FK = FK - 1.0E0 140 continue ! --------------------------------------------------------- ! COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR ! BETTER SCALING ! --------------------------------------------------------- TM = ABS(CS) PT = CMPLX(1.0E0/TM,0.0E0) S1 = PT*P2 CS = CONJG(CS)*PT S1 = COEF*S1*CS if (INU > 0 .or. N > 1) then ! ------------------------------------------------------ ! COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR ! SCALING ! ------------------------------------------------------ TM = ABS(P2) PT = CMPLX(1.0E0/TM,0.0E0) P1 = PT*P1 P2 = CONJG(P2)*PT PT = P1*P2 S2 = S1*(CONE+(CMPLX(DNU+0.5E0,0.0E0)-PT)/Z) goto 160 ELSE ZD = Z if (IFLAG == 1) then goto 240 ELSE goto 260 endif endif endif endif endif ! ------------------------------------------------------------------ ! FNU=HALF ODD INTEGER CASE, DNU=-0.5 ! ------------------------------------------------------------------ S1 = COEF S2 = COEF ! ------------------------------------------------------------------ ! FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH ! SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 ! ------------------------------------------------------------------ 160 continue CK = CMPLX(DNU+1.0E0,0.0E0)*RZ if (N == 1) INU = INU - 1 if (INU > 0) then INUB = 1 if (IFLAG == 1) then ! ------------------------------------------------------------ ! IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON ! UNDERFLOW ! ------------------------------------------------------------ HELIM = 0.5E0*ELIM ELM = EXP(-ELIM) CELM = CMPLX(ELM,0.0E0) ASCLE = BRY(1) ZD = Z XD = XX YD = YY IC = -1 J = 2 DO 180 I = 1, INU ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RZ AS = ABS(S2) ALAS = LOG(AS) P2R = -XD + ALAS if (P2R >= (-ELIM)) then P2 = -ZD + LOG(S2) P2R = REAL(P2) P2I = AIMAG(P2) P2M = EXP(P2R)/TOL P1 = CMPLX(P2M,0.0E0)*CMPLX(COS(P2I),SIN(P2I)) CALL DGVS17(P1,NW,ASCLE,TOL) if (NW == 0) then J = 3 - J CY(J) = P1 if (IC == (I-1)) then goto 200 ELSE IC = I goto 180 endif endif endif if (ALAS >= HELIM) then XD = XD - ELIM S1 = S1*CELM S2 = S2*CELM ZD = CMPLX(XD,YD) endif 180 continue if (N == 1) S1 = S2 goto 240 200 KFLAG = 1 INUB = I + 1 S2 = CY(J) J = 3 - J S1 = CY(J) if (INUB > INU) then if (N == 1) S1 = S2 goto 260 endif endif P1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 220 I = INUB, INU ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RZ if (KFLAG < 3) then P2 = S2*P1 P2R = REAL(P2) P2I = AIMAG(P2) P2R = ABS(P2R) P2I = ABS(P2I) P2M = MAX(P2R,P2I) if (P2M > ASCLE) then KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*P1 S2 = P2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) P1 = CSR(KFLAG) endif endif 220 continue if (N == 1) S1 = S2 goto 260 ELSE if (N == 1) S1 = S2 ZD = Z if (IFLAG /= 1) goto 260 endif 240 Y(1) = S1 if (N /= 1) Y(2) = S2 ASCLE = BRY(1) CALL DGWS17(ZD,FNU,N,Y,NZ,RZ,ASCLE,TOL,ELIM) INU = N - NZ if (INU <= 0) then return ELSE KK = NZ + 1 S1 = Y(KK) Y(KK) = S1*CSR(1) if (INU == 1) then return ELSE KK = NZ + 2 S2 = Y(KK) Y(KK) = S2*CSR(1) if (INU == 2) then return ELSE T2 = FNU + KK - 1 CK = CMPLX(T2,0.0E0)*RZ KFLAG = 1 goto 280 endif endif endif 260 Y(1) = S1*CSR(KFLAG) if (N == 1) then return ELSE Y(2) = S2*CSR(KFLAG) if (N == 2) then return ELSE KK = 2 endif endif 280 KK = KK + 1 if (KK <= N) then P1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 300 I = KK, N P2 = S2 S2 = CK*S2 + S1 S1 = P2 CK = CK + RZ P2 = S2*P1 Y(I) = P2 if (KFLAG < 3) then P2R = REAL(P2) P2I = AIMAG(P2) P2R = ABS(P2R) P2I = ABS(P2I) P2M = MAX(P2R,P2I) if (P2M > ASCLE) then KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*P1 S2 = P2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) P1 = CSR(KFLAG) endif endif 300 continue endif return 320 NZ = -3 return END subroutine DGYS17(Z,FNU,KODE,N,Y,NZ,RL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-778 (DEC 1989). ! ! Original name: CASYI ! ! DGYS17 COMPUTES THE I BESSEL function FOR REAL(Z) >= 0.0 BY ! MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE ! REGION CABS(Z)>MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL return. ! NZ < 0 INDICATES AN OVERFLOW ON KODE=1. ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, RL, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, & RZ, S2 REAL AA, ACZ, AEZ, AK, ARG, ARM, ATOL, AZ, BB, BK, & DFNU, DNU2, FDN, PI, RTPI, RTR1, S, SGN, SQK, X, & YY INTEGER I, IB, IERR1, IL, INU, J, JL, K, KODED, M, NN ! .. External functions .. COMPLEX S01EAE REAL X02AME EXTERNAL S01EAE, X02AME ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, MIN, MOD, & REAL, SIN, SQRT ! .. Data statements .. DATA PI, RTPI/3.14159265358979324E0, & 0.159154943091895336E0/ DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 AZ = ABS(Z) X = REAL(Z) ARM = 1.0E+3*X02AME() RTR1 = SQRT(ARM) IL = MIN(2,N) DFNU = FNU + N - IL ! ------------------------------------------------------------------ ! OVERFLOW TEST ! ------------------------------------------------------------------ AK1 = CMPLX(RTPI,0.0E0)/Z AK1 = SQRT(AK1) CZ = Z if (KODE == 2) CZ = Z - CMPLX(X,0.0E0) ACZ = REAL(CZ) if (ABS(ACZ) > ELIM) then NZ = -1 ELSE DNU2 = DFNU + DFNU KODED = 1 if ((ABS(ACZ) <= ALIM) .or. (N <= 2)) then KODED = 0 IERR1 = 1 AK1 = AK1*S01EAE(CZ,IERR1) ! Allow reduced precision from S01EAE, but disallow other errors. if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) goto 140 endif FDN = 0.0E0 if (DNU2 > RTR1) FDN = DNU2*DNU2 EZ = Z*CMPLX(8.0E0,0.0E0) ! --------------------------------------------------------------- ! WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO ! THE FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF ! THE EXPANSION FOR THE IMAGINARY PART. ! --------------------------------------------------------------- AEZ = 8.0E0*AZ S = TOL/AEZ JL = INT(RL+RL) + 2 YY = AIMAG(Z) P1 = CZERO if (YY /= 0.0E0) then ! ------------------------------------------------------------ ! CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF ! SIGNIFICANCE WHEN FNU OR N IS LARGE ! ------------------------------------------------------------ INU = INT(FNU) ARG = (FNU-INU)*PI INU = INU + N - IL AK = -SIN(ARG) BK = COS(ARG) if (YY < 0.0E0) BK = -BK P1 = CMPLX(AK,BK) if (MOD(INU,2) == 1) P1 = -P1 endif DO 60 K = 1, IL SQK = FDN - 1.0E0 ATOL = S*ABS(SQK) SGN = 1.0E0 CS1 = CONE CS2 = CONE CK = CONE AK = 0.0E0 AA = 1.0E0 BB = AEZ DK = EZ DO 20 J = 1, JL CK = CK*CMPLX(SQK,0.0E0)/DK CS2 = CS2 + CK SGN = -SGN CS1 = CS1 + CK*CMPLX(SGN,0.0E0) DK = DK + EZ AA = AA*ABS(SQK)/BB BB = BB + AEZ AK = AK + 8.0E0 SQK = SQK - AK if (AA <= ATOL) goto 40 20 continue goto 120 40 S2 = CS1 if (X+X < ELIM) then IERR1 = 1 S2 = S2 + P1*CS2*S01EAE(-Z-Z,IERR1) if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) & goto 140 endif FDN = FDN + 8.0E0*DFNU + 4.0E0 P1 = -P1 M = N - IL + K Y(M) = S2*AK1 60 continue if (N > 2) then NN = N K = NN - 2 AK = K RZ = (CONE+CONE)/Z IB = 3 DO 80 I = IB, NN Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) AK = AK - 1.0E0 K = K - 1 80 continue if (KODED /= 0) then IERR1 = 1 CK = S01EAE(CZ,IERR1) if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) & goto 140 DO 100 I = 1, NN Y(I) = Y(I)*CK 100 continue endif endif return 120 NZ = -2 return 140 NZ = -3 endif return END subroutine DGZS17(Z,FNU,KODE,MR,N,Y,NZ,RL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-779 (DEC 1989). ! ! Original name: CACAI ! ! DGZS17 APPLIES THE ANALYTIC CONTINUATION FORMULA ! ! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) ! MP=PI*MR*CMPLX(0.0,1.0) ! ! TO continue THE K function FROM THE RIGHT HALF TO THE LEFT ! HALF Z PLANE FOR USE WITH S17DGE WHERE FNU=1/3 OR 2/3 AND N=1. ! DGZS17 IS THE SAME AS DLZS17 WITH THE PARTS FOR LARGER ORDERS AND ! RECURRENCE REMOVED. A RECURSIVE CALL TO DLZS17 CAN RESULT IF S17DL ! IS CALLED FROM S17DGE. ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, RL, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CSGN, CSPN, ZN REAL ARG, ASCLE, AZ, CPN, DFNU, FMR, PI, SGN, SPN, YY INTEGER INU, IUF, NN, NW ! .. Local Arrays .. COMPLEX CY(2) ! .. External functions .. REAL X02AME EXTERNAL X02AME ! .. External subroutines .. EXTERNAL DGRS17, DGSS17, DGTS17, DGXS17, DGYS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, INT, MOD, SIGN, SIN ! .. Data statements .. DATA PI/3.14159265358979324E0/ ! .. Executable Statements .. ! NZ = 0 ZN = -Z AZ = ABS(Z) NN = N DFNU = FNU + N - 1 if (AZ > 2.0E0) then if (AZ*AZ*0.25E0 > DFNU+1.0E0) then if (AZ < RL) then ! --------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I ! function ! --------------------------------------------------------- CALL DGTS17(ZN,FNU,KODE,NN,Y,NW,TOL) if (NW < 0) then goto 40 ELSE goto 20 endif ELSE ! --------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I function ! --------------------------------------------------------- CALL DGYS17(ZN,FNU,KODE,NN,Y,NW,RL,TOL,ELIM,ALIM) if (NW < 0) then goto 40 ELSE goto 20 endif endif endif endif ! ------------------------------------------------------------------ ! POWER SERIES FOR THE I function ! ------------------------------------------------------------------ CALL DGRS17(ZN,FNU,KODE,NN,Y,NW,TOL,ELIM,ALIM) ! ------------------------------------------------------------------ ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K function ! ------------------------------------------------------------------ 20 CALL DGXS17(ZN,FNU,KODE,1,CY,NW,TOL,ELIM,ALIM) if (NW == 0) then FMR = MR SGN = -SIGN(PI,FMR) CSGN = CMPLX(0.0E0,SGN) if (KODE /= 1) then YY = -AIMAG(ZN) CPN = COS(YY) SPN = SIN(YY) CSGN = CSGN*CMPLX(CPN,SPN) endif ! --------------------------------------------------------------- ! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE ! --------------------------------------------------------------- INU = INT(FNU) ARG = (FNU-INU)*SGN CPN = COS(ARG) SPN = SIN(ARG) CSPN = CMPLX(CPN,SPN) if (MOD(INU,2) == 1) CSPN = -CSPN C1 = CY(1) C2 = Y(1) if (KODE /= 1) then IUF = 0 ASCLE = (1.0E+3*X02AME())/TOL CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF) NZ = NZ + NW endif Y(1) = CSPN*C1 + CSGN*C2 return endif 40 NZ = -1 if (NW == (-2)) NZ = -2 if (NW == (-3)) NZ = -3 return END subroutine DLYS17(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-782 (DEC 1989). ! ! Original name: CBUNK ! ! DLYS17 COMPUTES THE K BESSEL function FOR FNU>FNUL. ! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) ! IN DCZS18 AND THE EXPANSION FOR H(2,FNU,Z) IN DCYS18 ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. REAL AX, AY, XX, YY ! .. External subroutines .. EXTERNAL DCYS18, DCZS18 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, REAL ! .. Executable Statements .. ! NZ = 0 XX = REAL(Z) YY = AIMAG(Z) AX = ABS(XX)*1.7321E0 AY = ABS(YY) if (AY > AX) then ! --------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 ! --------------------------------------------------------------- CALL DCYS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) ELSE ! --------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 ! --------------------------------------------------------------- CALL DCZS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) endif return END subroutine DLZS17(Z,FNU,KODE,MR,N,Y,NZ,RL,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-783 (DEC 1989). ! ! Original name: CACON ! ! DLZS17 APPLIES THE ANALYTIC CONTINUATION FORMULA ! ! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) ! MP=PI*MR*CMPLX(0.0,1.0) ! ! TO continue THE K function FROM THE RIGHT HALF TO THE LEFT ! HALF Z PLANE ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, RL, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, & RZ, S1, S2, SC1, SC2, ST, ZN REAL ARG, AS2, ASCLE, BSCLE, C1I, C1M, C1R, CPN, FMR, & PI, SGN, SPN, YY INTEGER I, INU, IUF, KFLAG, NN, NW ! .. Local Arrays .. COMPLEX CSR(3), CSS(3), CY(2) REAL BRY(3) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEZS17, DGSS17, DGXS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, INT, MAX, MIN, MOD, & REAL, SIGN, SIN ! .. Data statements .. DATA PI/3.14159265358979324E0/ DATA CONE/(1.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 ZN = -Z NN = N CALL DEZS17(ZN,FNU,KODE,NN,Y,NW,RL,FNUL,TOL,ELIM,ALIM) if (NW >= 0) then ! --------------------------------------------------------------- ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K function ! --------------------------------------------------------------- NN = MIN(2,N) CALL DGXS17(ZN,FNU,KODE,NN,CY,NW,TOL,ELIM,ALIM) if (NW == 0) then S1 = CY(1) FMR = MR SGN = -SIGN(PI,FMR) CSGN = CMPLX(0.0E0,SGN) if (KODE /= 1) then YY = -AIMAG(ZN) CPN = COS(YY) SPN = SIN(YY) CSGN = CSGN*CMPLX(CPN,SPN) endif ! ------------------------------------------------------------ ! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF ! SIGNIFICANCE WHEN FNU IS LARGE ! ------------------------------------------------------------ INU = INT(FNU) ARG = (FNU-INU)*SGN CPN = COS(ARG) SPN = SIN(ARG) CSPN = CMPLX(CPN,SPN) if (MOD(INU,2) == 1) CSPN = -CSPN IUF = 0 C1 = S1 C2 = Y(1) ASCLE = (1.0E+3*X02AME())/TOL if (KODE /= 1) then CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF) NZ = NZ + NW SC1 = C1 endif Y(1) = CSPN*C1 + CSGN*C2 if (N /= 1) then CSPN = -CSPN S2 = CY(2) C1 = S2 C2 = Y(2) if (KODE /= 1) then CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF) NZ = NZ + NW SC2 = C1 endif Y(2) = CSPN*C1 + CSGN*C2 if (N /= 2) then CSPN = -CSPN RZ = CMPLX(2.0E0,0.0E0)/ZN CK = CMPLX(FNU+1.0E0,0.0E0)*RZ ! ------------------------------------------------------ ! SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON ! K functionS ! ------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CSCR = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CSCR CSR(1) = CSCR CSR(2) = CONE CSR(3) = CSCL BRY(1) = ASCLE BRY(2) = 1.0E0/ASCLE BRY(3) = X02ALE() AS2 = ABS(S2) KFLAG = 2 if (AS2 <= BRY(1)) then KFLAG = 1 else if (AS2 >= BRY(2)) then KFLAG = 3 endif BSCLE = BRY(KFLAG) S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) CS = CSR(KFLAG) DO 20 I = 3, N ST = S2 S2 = CK*S2 + S1 S1 = ST C1 = S2*CS ST = C1 C2 = Y(I) if (KODE /= 1) then if (IUF >= 0) then CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF) NZ = NZ + NW SC1 = SC2 SC2 = C1 if (IUF == 3) then IUF = -4 S1 = SC1*CSS(KFLAG) S2 = SC2*CSS(KFLAG) ST = SC2 endif endif endif Y(I) = CSPN*C1 + CSGN*C2 CK = CK + RZ CSPN = -CSPN if (KFLAG < 3) then C1R = REAL(C1) C1I = AIMAG(C1) C1R = ABS(C1R) C1I = ABS(C1I) C1M = MAX(C1R,C1I) if (C1M > BSCLE) then KFLAG = KFLAG + 1 BSCLE = BRY(KFLAG) S1 = S1*CS S2 = ST S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) CS = CSR(KFLAG) endif endif 20 continue endif endif return endif endif NZ = -1 if (NW == (-2)) NZ = -2 if (NW == (-3)) NZ = -3 return END INTEGER function P01ABE(IFAIL,IERROR,SRNAME,NREC,REC) ! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. ! MARK 13 REVISED. IER-621 (APR 1988). ! MARK 13B REVISED. IER-668 (AUG 1988). ! ! P01ABE is the error-handling routine for the NAG Library. ! ! P01ABE either returns the value of IERROR through the routine ! name (soft failure), or terminates execution of the program ! (hard failure). Diagnostic messages may be output. ! ! If IERROR = 0 (successful exit from the calling routine), ! the value 0 is returned through the routine name, and no ! message is output ! ! If IERROR is non-zero (abnormal exit from the calling routine), ! the action taken depends on the value of IFAIL. ! ! IFAIL = 1: soft failure, silent exit (i.e. no messages are ! output) ! IFAIL = -1: soft failure, noisy exit (i.e. messages are output) ! IFAIL =-13: soft failure, noisy exit but standard messages from ! P01ABE are suppressed ! IFAIL = 0: hard failure, noisy exit ! ! For compatibility with certain routines included before Mark 12 ! P01ABE also allows an alternative specification of IFAIL in which ! it is regarded as a decimal integer with least significant digits ! cba. Then ! ! a = 0: hard failure a = 1: soft failure ! b = 0: silent exit b = 1: noisy exit ! ! except that hard failure now always implies a noisy exit. ! ! S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. ! ! .. Scalar Arguments .. INTEGER IERROR, IFAIL, NREC CHARACTER*(*) SRNAME ! .. Array Arguments .. CHARACTER*(*) REC(*) ! .. Local Scalars .. INTEGER I, NERR CHARACTER*72 MESS ! .. External subroutines .. EXTERNAL ABZP01, X04AAE, X04BAE ! .. Intrinsic functions .. INTRINSIC ABS, MOD ! .. Executable Statements .. if (IERROR /= 0) then ! Abnormal exit from calling routine if (IFAIL == -1 .or. IFAIL == 0 .or. IFAIL == -13 .or. & (IFAIL > 0 .and. MOD(IFAIL/10,10) /= 0)) then ! Noisy exit CALL X04AAE(0,NERR) DO 20 I = 1, NREC CALL X04BAE(NERR,REC(I)) 20 continue if (IFAIL /= -13) then WRITE (MESS,FMT=99999) SRNAME, IERROR CALL X04BAE(NERR,MESS) if (ABS(MOD(IFAIL,10)) /= 1) then ! Hard failure CALL X04BAE(NERR, & ' ** NAG hard failure - execution terminated' & ) CALL ABZP01 ELSE ! Soft failure CALL X04BAE(NERR, & ' ** NAG soft failure - control returned') endif endif endif endif P01ABE = IERROR return ! 99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', & ' =',I6) END COMPLEX function S01EAE(Z,IFAIL) ! MARK 14 RELEASE. NAG COPYRIGHT 1989. ! returns exp(Z) for complex Z. ! .. Parameters .. REAL ONE, ZERO PARAMETER (ONE=1.0E0,ZERO=0.0E0) CHARACTER*6 SRNAME PARAMETER (SRNAME='S01EAE') ! .. Scalar Arguments .. COMPLEX Z INTEGER IFAIL ! .. Local Scalars .. REAL COSY, EXPX, LNSAFE, RECEPS, RESI, RESR, & RTSAFS, SAFE, SAFSIN, SINY, X, XPLNCY, & XPLNSY, Y INTEGER IER, NREC LOGICAL FIRST ! .. Local Arrays .. CHARACTER*80 REC(2) ! .. External functions .. REAL X02AHE, X02AJE, X02AME INTEGER P01ABE EXTERNAL X02AHE, X02AJE, X02AME, P01ABE ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, & REAL, SIGN, SIN, SQRT ! .. Save statement .. SAVE SAFE, LNSAFE, SAFSIN, RTSAFS, FIRST ! .. Data statements .. DATA FIRST/.true./ ! .. Executable Statements .. if (FIRST) then FIRST = .false. SAFE = ONE/X02AME() LNSAFE = LOG(SAFE) RECEPS = ONE/X02AJE() SAFSIN = MIN(X02AHE(ONE),RECEPS) if (SAFSIN < RECEPS**0.75E0) then ! Assume that SAFSIN is approximately sqrt(RECEPS), in which ! case IFAIL=4 cannot occur. RTSAFS = SAFSIN ELSE ! Set RTSAFS to the argument above which SINE and COSINE will ! return results of less than half precision, assuming that ! SAFSIN is approximately equal to RECEPS. RTSAFS = SQRT(SAFSIN) endif endif NREC = 0 IER = 0 X = REAL(Z) Y = AIMAG(Z) if (ABS(Y) > SAFSIN) then IER = 5 NREC = 2 WRITE (REC,FMT=99995) Z S01EAE = ZERO ELSE COSY = COS(Y) SINY = SIN(Y) if (X > LNSAFE) then if (COSY == ZERO) then RESR = ZERO ELSE XPLNCY = X + LOG(ABS(COSY)) if (XPLNCY > LNSAFE) then IER = 1 RESR = SIGN(SAFE,COSY) ELSE RESR = SIGN(EXP(XPLNCY),COSY) endif endif if (SINY == ZERO) then RESI = ZERO ELSE XPLNSY = X + LOG(ABS(SINY)) if (XPLNSY > LNSAFE) then IER = IER + 2 RESI = SIGN(SAFE,SINY) ELSE RESI = SIGN(EXP(XPLNSY),SINY) endif endif ELSE EXPX = EXP(X) RESR = EXPX*COSY RESI = EXPX*SINY endif S01EAE = CMPLX(RESR,RESI) if (IER == 3) then NREC = 2 WRITE (REC,FMT=99997) Z else if (ABS(Y) > RTSAFS) then IER = 4 NREC = 2 WRITE (REC,FMT=99996) Z else if (IER == 1) then NREC = 2 WRITE (REC,FMT=99999) Z else if (IER == 2) then NREC = 2 WRITE (REC,FMT=99998) Z endif endif IFAIL = P01ABE(IFAIL,IER,SRNAME,NREC,REC) return ! 99999 FORMAT (1X,'** Argument Z causes overflow in real part of result:' & ,/4X,'Z = (',1P,E13.5,',',E13.5,')') 99998 FORMAT (1X,'** Argument Z causes overflow in imaginary part of r', & 'esult:',/4X,'Z = (',1P,E13.5,',',E13.5,')') 99997 FORMAT (1X,'** Argument Z causes overflow in both real and imagi', & 'nary parts of result:',/4X,'Z = (',1P,E13.5,',',E13.5,')') 99996 FORMAT (1X,'** The imaginary part of argument Z is so large that', & ' the result is',/4X,'accurate to less than half precisio', & 'n: Z = (',1P,E13.5,',',E13.5,')') 99995 FORMAT (1X,'** The imaginary part of argument Z is so large that', & ' the result has no',/4X,'precision: Z = (',1P,E13.5,',', & E13.5,')') END REAL function S14ABE(X,IFAIL) ! MARK 8 RELEASE. NAG COPYRIGHT 1979. ! MARK 11.5(F77) REVISED. (SEPT 1985.) ! LNGAMMA(X) function ! ABRAMOWITZ AND STEGUN CH.6 ! ! ************************************************************** ! ! TO EXTRACT THE CORRECT CODE FOR A PARTICULAR MACHINE-RANGE, ! ACTIVATE THE STATEMENTS CONTAINED IN COMMENTS BEGINNING CDD , ! WHERE DD IS THE APPROXIMATE NUMBER OF SIGNIFICANT DECIMAL ! DIGITS REPRESENTED BY THE MACHINE ! DELETE THE ILLEGAL DUMMY STATEMENTS OF THE FORM ! * EXPANSION (NNNN) * ! ! ALSO INSERT APPROPRIATE DATA STATEMENTS TO DEFINE CONSTANTS ! WHICH DEPEND ON THE RANGE OF NUMBERS REPRESENTED BY THE ! MACHINE, RATHER THAN THE PRECISION (SUITABLE STATEMENTS FOR ! SOME MACHINES ARE CONTAINED IN COMMENTS BEGINNING CRD WHERE ! D IS A DIGIT WHICH SIMPLY DISTINGUISHES A GROUP OF MACHINES). ! DELETE THE ILLEGAL DUMMY DATA STATEMENTS WITH VALUES WRITTEN ! *VALUE* ! ! ************************************************************** ! ! IMPLEMENTATION DEPENDENT CONSTANTS ! ! if (X < XSMALL)GAMMA(X)=1/X ! I.E. XSMALL*EULGAM <= XRELPR ! LNGAM(XVBIG)=GBIG <= XOVFLO ! LNR2PI=LN(SQRT(2*PI)) ! if (X>XBIG)LNGAM(X)=(X-0.5)LN(X)-X+LNR2PI ! ! .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='S14ABE') ! .. Scalar Arguments .. REAL X INTEGER IFAIL ! .. Local Scalars .. REAL G, GBIG, LNR2PI, T, XBIG, XSMALL, XVBIG, Y INTEGER I, M ! .. Local Arrays .. CHARACTER*1 P01REC(1) ! .. External functions .. INTEGER P01ABE EXTERNAL P01ABE ! .. Intrinsic functions .. INTRINSIC LOG, REAL ! .. Data statements .. !08 DATA XSMALL,XBIG,LNR2PI/ !08 *1.0E-8,1.2E+3,9.18938533E-1/ !09 DATA XSMALL,XBIG,LNR2PI/ !09 *1.0E-9,4.8E+3,9.189385332E-1/ !12 DATA XSMALL,XBIG,LNR2PI/ !12 *1.0E-12,3.7E+5,9.189385332047E-1/ DATA XSMALL,XBIG,LNR2PI/ & 1.0E-15,6.8E+6,9.189385332046727E-1/ !17 DATA XSMALL,XBIG,LNR2PI/ !17 *1.0E-17,7.7E+7,9.18938533204672742E-1/ !19 DATA XSMALL,XBIG,LNR2PI/ !19 *1.0E-19,3.1E+8,9.189385332046727418E-1/ ! ! RANGE DEPENDENT CONSTANTS ! DK DK DATA XVBIG,GBIG/4.81E+2461,2.72E+2465/ DATA XVBIG,GBIG/4.08E+36,3.40E+38/ ! FOR IEEE SINGLE PRECISION !R0 DATA XVBIG,GBIG/4.08E+36,3.40E+38/ ! FOR IBM 360/370 AND SIMILAR MACHINES !R1 DATA XVBIG,GBIG/4.29E+73,7.231E+75/ ! FOR DEC10, HONEYWELL, UNIVAC 1100 (S.P.) !R2 DATA XVBIG,GBIG/2.05E36,1.69E38/ ! FOR ICL 1900 !R3 DATA XVBIG,GBIG/3.39E+74,5.784E+76/ ! FOR CDC 7600/CYBER !R4 DATA XVBIG,GBIG/1.72E+319,1.26E+322/ ! FOR UNIVAC 1100 (D.P.) !R5 DATA XVBIG,GBIG/1.28E305,8.98E+307/ ! FOR IEEE DOUBLE PRECISION !R7 DATA XVBIG,GBIG/2.54D+305,1.79D+308/ ! .. Executable Statements .. if (X > XSMALL) goto 20 ! VERY SMALL RANGE if (X <= 0.0) goto 160 IFAIL = 0 S14ABE = -LOG(X) goto 200 ! 20 if (X > 15.0) goto 120 ! MAIN SMALL X RANGE M = X T = X - FLOAT(M) M = M - 1 G = 1.0 if (M) 40, 100, 60 40 G = G/X goto 100 60 DO 80 I = 1, M G = (X-FLOAT(I))*G 80 continue 100 T = 2.0*T - 1.0 ! ! * EXPANSION (0026) * ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 08E.09 !08 Y = (((((((((((+1.88278283E-6*T-5.48272091E-6)*T+1.03144033E-5) !08 * *T-3.13088821E-5)*T+1.01593694E-4)*T-2.98340924E-4) !08 * *T+9.15547391E-4)*T-2.42216251E-3)*T+9.04037536E-3) !08 * *T-1.34119055E-2)*T+1.03703361E-1)*T+1.61692007E-2)*T + !08 * 8.86226925E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 09E.10 !09 Y = ((((((((((((-6.463247484E-7*T+1.882782826E-6) !09 * *T-3.382165478E-6)*T+1.031440334E-5)*T-3.393457634E-5) !09 * *T+1.015936944E-4)*T-2.967655076E-4)*T+9.155473906E-4) !09 * *T-2.422622002E-3)*T+9.040375355E-3)*T-1.341184808E-2) !09 * *T+1.037033609E-1)*T+1.616919866E-2)*T + 8.862269255E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 12E.13 !12 Y = ((((((((((((((((-8.965837291520E-9*T+2.612707393536E-8) !12 * *T-3.802866827264E-8)*T+1.173294768947E-7) !12 * *T-4.275076254106E-7)*T+1.276176602829E-6) !12 * *T-3.748495971011E-6)*T+1.123829871408E-5) !12 * *T-3.364018663166E-5)*T+1.009331480887E-4) !12 * *T-2.968895120407E-4)*T+9.157850115110E-4) !12 * *T-2.422595461409E-3)*T+9.040335037321E-3) !12 * *T-1.341185056618E-2)*T+1.037033634184E-1) !12 * *T+1.616919872437E-2)*T + 8.862269254528E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 15E.16 Y = (((((((((((((((-1.243191705600000E-10*T+ & 3.622882508800000E-10)*T-4.030909644800000E-10) & *T+1.265236705280000E-9)*T-5.419466096640000E-9) & *T+1.613133578240000E-8)*T-4.620920340480000E-8) & *T+1.387603440435200E-7)*T-4.179652784537600E-7) & *T+1.253148247777280E-6)*T-3.754930502328320E-6) & *T+1.125234962812416E-5)*T-3.363759801664768E-5) & *T+1.009281733953869E-4)*T-2.968901194293069E-4) & *T+9.157859942174304E-4)*T-2.422595384546340E-3 Y = ((((Y*T+9.040334940477911E-3)*T-1.341185057058971E-2) & *T+1.037033634220705E-1)*T+1.616919872444243E-2)*T + & 8.862269254527580E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 17E.18 !17 Y = (((((((((((((((-1.46381209600000000E-11*T+ !17 * 4.26560716800000000E-11)*T-4.01499750400000000E-11) !17 * *T+1.27679856640000000E-10)*T-6.13513953280000000E-10) !17 * *T+1.82243164160000000E-9)*T-5.11961333760000000E-9) !17 * *T+1.53835215257600000E-8)*T-4.64774927155200000E-8) !17 * *T+1.39383522590720000E-7)*T-4.17808776355840000E-7) !17 * *T+1.25281466396672000E-6)*T-3.75499034136576000E-6) !17 * *T+1.12524642975590400E-5)*T-3.36375833240268800E-5) !17 * *T+1.00928148823365120E-4)*T-2.96890121633200000E-4 !17 Y = ((((((Y*T+9.15785997288933120E-4)*T-2.42259538436268176E-3) !17 * *T+9.04033494028101968E-3)*T-1.34118505705967765E-2) !17 * *T+1.03703363422075456E-1)*T+1.61691987244425092E-2)*T + !17 * 8.86226925452758013E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 19E.19 !19 Y = (((((((((((((((+6.710886400000000000E-13*T- !19 * 1.677721600000000000E-12)*T+6.710886400000000000E-13) !19 * *T-4.152360960000000000E-12)*T+2.499805184000000000E-11) !19 * *T-6.898581504000000000E-11)*T+1.859597107200000000E-10) !19 * *T-5.676387532800000000E-10)*T+1.725556326400000000E-9) !19 * *T-5.166307737600000000E-9)*T+1.548131827712000000E-8) !19 * *T-4.644574052352000000E-8)*T+1.393195837030400000E-7) !19 * *T-4.178233990758400000E-7)*T+1.252842254950400000E-6) !19 * *T-3.754985815285760000E-6)*T+1.125245651030528000E-5 !19 Y = (((((((((Y*T-3.363758423922688000E-5) !19 * *T+1.009281502108083200E-4) !19 * *T-2.968901215188000000E-4)*T+9.157859971435078400E-4) !19 * *T-2.422595384370689760E-3)*T+9.040334940288877920E-3) !19 * *T-1.341185057059651648E-2)*T+1.037033634220752902E-1) !19 * *T+1.616919872444250674E-2)*T + 8.862269254527580137E-1 ! S14ABE = LOG(Y*G) IFAIL = 0 goto 200 ! 120 if (X > XBIG) goto 140 ! MAIN LARGE X RANGE T = 450.0/(X*X) - 1.0 ! ! * EXPANSION (0059) * ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 08E.09 !08 Y = (+3.89980902E-9*T-6.16502533E-6)*T + 8.33271644E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 09E.10 !09 Y = (+3.899809019E-9*T-6.165025333E-6)*T + 8.332716441E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 12E.13 !12 Y = ((-6.451144077930E-12*T+3.899809018958E-9) !12 * *T-6.165020494506E-6)*T + 8.332716440658E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 15E.16 Y = (((+2.002019273379824E-14*T-6.451144077929628E-12) & *T+3.899788998764847E-9)*T-6.165020494506090E-6)*T + & 8.332716440657866E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 17E.18 !17 Y = ((((-9.94561064728159347E-17*T+2.00201927337982364E-14) !17 * *T-6.45101975779653651E-12)*T+3.89978899876484712E-9) !17 * *T-6.16502049453716986E-6)*T + 8.33271644065786580E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 19E.19 !19 Y = (((((+7.196406678180202240E-19*T-9.945610647281593472E-17) !19 * *T+2.001911327279650935E-14)*T-6.451019757796536510E-12) !19 * *T+3.899788999169644998E-9)*T-6.165020494537169862E-6)*T + !19 * 8.332716440657865795E-2 ! S14ABE = (X-0.5)*LOG(X) - X + LNR2PI + Y/X IFAIL = 0 goto 200 ! 140 if (X > XVBIG) goto 180 ! ASYMPTOTIC LARGE X RANGE S14ABE = (X-0.5)*LOG(X) - X + LNR2PI IFAIL = 0 goto 200 ! ! FAILURE EXITS 160 IFAIL = P01ABE(IFAIL,1,SRNAME,0,P01REC) S14ABE = 0.0 goto 200 180 IFAIL = P01ABE(IFAIL,2,SRNAME,0,P01REC) S14ABE = GBIG ! 200 return ! END subroutine S17DGE(DERIV,Z,SCALE,AI,NZ,IFAIL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-770 (DEC 1989). ! ! Original name: CAIRY ! ! PURPOSE TO COMPUTE AIRY functionS AI(Z) AND DAI(Z) FOR COMPLEX Z ! ! DESCRIPTION ! =========== ! ! ON SCALE='U', S17DGE COMPUTES THE COMPLEX AIRY function AI(Z) ! OR ITS DERIVATIVE DAI(Z)/DZ ON DERIV='F' OR DERIV='D' ! RESPECTIVELY. ON SCALE='S', A SCALING OPTION ! CEXP(ZTA)*AI(Z) OR CEXP(ZTA)*DAI(Z)/DZ IS PROVIDED TO REMOVE ! THE EXPONENTIAL DECAY IN -PI/3 < ARG(Z) < PI/3 AND THE ! EXPONENTIAL GROWTH IN PI/3 < ABS(ARG(Z)) < PI WHERE ! ZTA=(2/3)*Z*CSQRT(Z) ! ! WHILE THE AIRY functionS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN ! THE WHOLE Z PLANE, THE CORRESPONDING SCALED functionS DEFINED ! FOR SCALE='S' HAVE A CUT ALONG THE NEGATIVE REAL AXIS. ! DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF ! MATHEMATICAL functionS (REF. 1). ! ! INPUT ! Z - Z=CMPLX(X,Y) ! DERIV - return function (DERIV='F') OR DERIVATIVE ! (DERIV='D') ! SCALE - A PARAMETER TO INDICATE THE SCALING OPTION ! SCALE = 'U' OR 'u' returnS ! AI=AI(Z) ON DERIV='F' OR ! AI=DAI(Z)/DZ ON DERIV='D' ! SCALE = 'S' OR 's' returnS ! AI=CEXP(ZTA)*AI(Z) ON DERIV='F' OR ! AI=CEXP(ZTA)*DAI(Z)/DZ ON DERIV='D' WHERE ! ZTA=(2/3)*Z*CSQRT(Z) ! ! OUTPUT ! AI - COMPLEX ANSWER DEPENDING ON THE CHOICES FOR DERIV ! AND SCALE ! NZ - UNDERFLOW INDICATOR ! NZ= 0 , NORMAL return ! NZ= 1 , AI=CMPLX(0.0,0.0) DUE TO UNDERFLOW IN ! -PI/3 < ARG(Z) < PI/3 ON SCALE='U' ! IFAIL - ERROR FLAG ! IFAIL=0, NORMAL return - COMPUTATION COMPLETED ! IFAIL=1, INPUT ERROR - NO COMPUTATION ! IFAIL=2, OVERFLOW - NO COMPUTATION, REAL(ZTA) ! TOO LARGE WITH SCALE = 'U' ! IFAIL=3, CABS(Z) LARGE - COMPUTATION COMPLETED ! LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION ! PRODUCE LESS THAN HALF OF MACHINE ACCURACY ! IFAIL=4, CABS(Z) TOO LARGE - NO COMPUTATION ! COMPLETE LOSS OF ACCURACY BY ARGUMENT ! REDUCTION ! IFAIL=5, ERROR - NO COMPUTATION, ! ALGORITHM TERMINATION CONDITION NOT MET ! ! LONG DESCRIPTION ! ================ ! ! AI AND DAI ARE COMPUTED FOR CABS(Z)>1.0 FROM THE K BESSEL ! functionS BY ! ! AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA) ! C=1.0/(PI*SQRT(3.0)) ! ZTA=(2/3)*Z**(3/2) ! ! WITH THE POWER SERIES FOR CABS(Z) <= 1.0. ! ! IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- ! MENTARY functionS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES ! OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF ! THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), ! THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR ! FLAG IFAIL=3 IS TRIGGERED WHERE UR=X02AJE()=UNIT ROUNDOFF. ! ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN ! ALL SIGNIFICANCE IS LOST AND IFAIL=4. IN ORDER TO USE THE INT ! function, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE ! LARGEST INTEGER, U3=X02BBE(). THUS, THE MAGNITUDE OF ZETA ! MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, ! AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE ! PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE ! PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- ! ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- ! NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN ! DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN ! EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, ! NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE ! PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER ! MACHINES. ! ! THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX ! BESSEL function CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT ! ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- ! SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE ! ELEMENTARY functionS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), ! ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF ! CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY ! HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN ! ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY ! SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER ! THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, ! 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS ! THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER ! COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY ! BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER ! COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE ! MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, ! THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, ! OR -PI/2+P. ! ! REFERENCES ! ========== ! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ ! AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF ! COMMERCE, 1955. ! ! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT ! AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 ! ! A subroutine PACKAGE FOR BESSEL functionS OF A COMPLEX ! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- ! 1018, MAY, 1985 ! ! A PORTABLE PACKAGE FOR BESSEL functionS OF A COMPLEX ! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. ! MATH. SOFTWARE, 1986 ! ! DATE WRITTEN 830501 (YYMMDD) ! REVISION DATE 830501 (YYMMDD) ! AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES ! ! .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='S17DGE') ! .. Scalar Arguments .. COMPLEX AI, Z INTEGER IFAIL, NZ CHARACTER DERIV, SCALE ! .. Local Scalars .. COMPLEX CONE, CSQ, S1, S2, TRM1, TRM2, Z3, ZTA REAL AA, AD, AK, ALAZ, ALIM, ATRM, AZ, AZ3, BB, BK, & C1, C2, CK, COEF, D1, D2, DIG, DK, ELIM, FID, & FNU, R1M5, RL, SAVAA, SFAC, TOL, TTH, Z3I, Z3R, & ZI, ZR INTEGER ID, IERR, IFL, IFLAG, K, K1, K2, KODE, MR, NN, & NREC ! .. Local Arrays .. COMPLEX CY(1) CHARACTER*80 REC(1) ! .. External functions .. COMPLEX S01EAE REAL X02AHE, X02AJE, X02AME INTEGER P01ABE, X02BBE, X02BHE, X02BJE, X02BKE, X02BLE EXTERNAL S01EAE, X02AHE, X02AJE, X02AME, P01ABE, X02BBE, & X02BHE, X02BJE, X02BKE, X02BLE ! .. External subroutines .. EXTERNAL DGXS17, DGZS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, LOG, LOG10, MAX, MIN, REAL, & SQRT ! .. Data statements .. DATA TTH, C1, C2, COEF/6.66666666666666667E-01, & 3.55028053887817240E-01, & 2.58819403792806799E-01, & 1.83776298473930683E-01/ DATA CONE/(1.0E0,0.0E0)/ ! .. Executable Statements .. IERR = 0 NREC = 0 NZ = 0 if (DERIV == 'F' .or. DERIV == 'f') then ID = 0 else if (DERIV == 'D' .or. DERIV == 'd') then ID = 1 ELSE ID = -1 endif if (SCALE == 'U' .or. SCALE == 'u') then KODE = 1 else if (SCALE == 'S' .or. SCALE == 's') then KODE = 2 ELSE KODE = -1 endif if (ID == -1) then IERR = 1 NREC = 1 WRITE (REC,FMT=99999) DERIV else if (KODE == -1) then IERR = 1 NREC = 1 WRITE (REC,FMT=99998) SCALE endif if (IERR == 0) then AZ = ABS(Z) TOL = MAX(X02AJE(),1.0E-18) FID = ID if (AZ > 1.0E0) then ! ------------------------------------------------------------ ! CASE FOR CABS(Z)>1.0 ! ------------------------------------------------------------ FNU = (1.0E0+FID)/3.0E0 ! ------------------------------------------------------------ ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW ! LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM)>EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS ! NEAR UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC ! IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR ! LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! ------------------------------------------------------------ K1 = X02BKE() K2 = X02BLE() R1M5 = LOG10(REAL(X02BHE())) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = X02BJE() - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) RL = 1.2E0*DIG + 3.0E0 ALAZ = LOG(AZ) ! ------------------------------------------------------------ ! TEST FOR RANGE ! ------------------------------------------------------------ AA = 0.5E0/TOL BB = X02BBE(1.0E0)*0.5E0 AA = MIN(AA,BB,X02AHE(1.0E0)) AA = AA**TTH if (AZ > AA) then NZ = 0 IERR = 4 NREC = 1 WRITE (REC,FMT=99997) AZ, AA ELSE AA = SQRT(AA) SAVAA = AA if (AZ > AA) then IERR = 3 NREC = 1 WRITE (REC,FMT=99996) AZ, AA endif CSQ = SQRT(Z) ZTA = Z*CSQ*CMPLX(TTH,0.0E0) ! --------------------------------------------------------- ! RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS ! SMALL ! --------------------------------------------------------- IFLAG = 0 SFAC = 1.0E0 ZI = AIMAG(Z) ZR = REAL(Z) AK = AIMAG(ZTA) if (ZR < 0.0E0) then BK = REAL(ZTA) CK = -ABS(BK) ZTA = CMPLX(CK,AK) endif if (ZI == 0.0E0) then if (ZR <= 0.0E0) ZTA = CMPLX(0.0E0,AK) endif AA = REAL(ZTA) if (AA >= 0.0E0 .and. ZR > 0.0E0) then if (KODE /= 2) then ! --------------------------------------------------- ! UNDERFLOW TEST ! --------------------------------------------------- if (AA >= ALIM) then AA = -AA - 0.25E0*ALAZ IFLAG = 2 SFAC = 1.0E0/TOL if (AA < (-ELIM)) then NZ = 1 AI = CMPLX(0.0E0,0.0E0) IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif endif endif CALL DGXS17(ZTA,FNU,KODE,1,CY,NZ,TOL,ELIM,ALIM) ELSE if (KODE /= 2) then ! --------------------------------------------------- ! OVERFLOW TEST ! --------------------------------------------------- if (AA <= (-ALIM)) then AA = -AA + 0.25E0*ALAZ IFLAG = 1 SFAC = TOL if (AA > ELIM) goto 20 endif endif ! ------------------------------------------------------ ! DGXS17 AND DGZS17 return EXP(ZTA)*K(FNU,ZTA) ON KODE=2 ! ------------------------------------------------------ MR = 1 if (ZI < 0.0E0) MR = -1 CALL DGZS17(ZTA,FNU,KODE,MR,1,CY,NN,RL,TOL,ELIM,ALIM) if (NN >= 0) then NZ = NZ + NN goto 40 else if (NN == (-3)) then NZ = 0 IERR = 4 NREC = 1 WRITE (REC,FMT=99997) AZ, SAVAA IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return else if (NN /= (-1)) then NZ = 0 IERR = 5 NREC = 1 WRITE (REC,FMT=99995) IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif 20 NZ = 0 IERR = 2 NREC = 1 WRITE (REC,FMT=99994) IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif 40 S1 = CY(1)*CMPLX(COEF,0.0E0) if (IFLAG /= 0) then S1 = S1*CMPLX(SFAC,0.0E0) if (ID == 1) then S1 = -S1*Z AI = S1*CMPLX(1.0E0/SFAC,0.0E0) ELSE S1 = S1*CSQ AI = S1*CMPLX(1.0E0/SFAC,0.0E0) endif else if (ID == 1) then AI = -Z*S1 ELSE AI = CSQ*S1 endif endif ELSE ! ------------------------------------------------------------ ! POWER SERIES FOR CABS(Z) <= 1. ! ------------------------------------------------------------ S1 = CONE S2 = CONE if (AZ < TOL) then AA = 1.0E+3*X02AME() S1 = CMPLX(0.0E0,0.0E0) if (ID == 1) then AI = -CMPLX(C2,0.0E0) AA = SQRT(AA) if (AZ > AA) S1 = Z*Z*CMPLX(0.5E0,0.0E0) AI = AI + S1*CMPLX(C1,0.0E0) ELSE if (AZ > AA) S1 = CMPLX(C2,0.0E0)*Z AI = CMPLX(C1,0.0E0) - S1 endif ELSE AA = AZ*AZ if (AA >= TOL/AZ) then TRM1 = CONE TRM2 = CONE ATRM = 1.0E0 Z3 = Z*Z*Z AZ3 = AZ*AA AK = 2.0E0 + FID BK = 3.0E0 - FID - FID CK = 4.0E0 - FID DK = 3.0E0 + FID + FID D1 = AK*DK D2 = BK*CK AD = MIN(D1,D2) AK = 24.0E0 + 9.0E0*FID BK = 30.0E0 - 9.0E0*FID Z3R = REAL(Z3) Z3I = AIMAG(Z3) DO 60 K = 1, 25 TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) S1 = S1 + TRM1 TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) S2 = S2 + TRM2 ATRM = ATRM*AZ3/AD D1 = D1 + AK D2 = D2 + BK AD = MIN(D1,D2) if (ATRM < TOL*AD) then goto 80 ELSE AK = AK + 18.0E0 BK = BK + 18.0E0 endif 60 continue endif 80 if (ID == 1) then AI = -S2*CMPLX(C2,0.0E0) if (AZ > TOL) AI = AI + Z*Z*S1*CMPLX(C1/(1.0E0+FID), & 0.0E0) if (KODE /= 1) then ZTA = Z*SQRT(Z)*CMPLX(TTH,0.0E0) ! AI = AI*EXP(ZTA) IFL = 1 AI = AI*S01EAE(ZTA,IFL) endif ELSE AI = S1*CMPLX(C1,0.0E0) - Z*S2*CMPLX(C2,0.0E0) if (KODE /= 1) then ZTA = Z*SQRT(Z)*CMPLX(TTH,0.0E0) ! AI = AI*EXP(ZTA) IFL = 1 AI = AI*S01EAE(ZTA,IFL) endif endif endif endif endif IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return ! 99999 FORMAT (1X,'** On entry, DERIV has illegal value: DERIV = ''',A, & '''') 99998 FORMAT (1X,'** On entry, SCALE has illegal value: SCALE = ''',A, & '''') 99997 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' > ', & E13.5) 99996 FORMAT (1X,'** Results lack precision because abs(Z) =',1P,E13.5, & ' > ',E13.5) 99995 FORMAT (1X,'** No computation - algorithm termination condition ', & 'not met.') 99994 FORMAT (1X,'** No computation because real(ZTA) too large, where', & ' ZTA = (2/3)*Z**(3/2).') END subroutine S17DLE(M,FNU,Z,N,SCALE,CY,NZ,IFAIL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-781 (DEC 1989). ! ! Original name: CBESH ! ! PURPOSE TO COMPUTE THE H-BESSEL functionS OF A COMPLEX ARGUMENT ! ! DESCRIPTION ! =========== ! ! ON SCALE='U', S17DLE COMPUTES AN N MEMBER SEQUENCE OF COMPLEX ! HANKEL (BESSEL) functionS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 ! OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX ! Z /= CMPLX(0.0E0,0.0E0) IN THE CUT PLANE -PI < ARG(Z) <= PI. ! ON SCALE='S', S17DLE COMPUTES THE SCALED HANKEL functionS ! ! CY(I)=H(M,FNU+J-1,Z)*EXP(-MM*Z*I) MM=3-2M, I**2=-1. ! ! WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER ! AND LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN ! THE NBS HANDBOOK OF MATHEMATICAL functionS (REF. 1). ! ! INPUT ! Z - Z=CMPLX(X,Y), Z /= CMPLX(0.,0.),-PI < ARG(Z) <= PI ! FNU - ORDER OF INITIAL H function, FNU >= 0.0E0 ! SCALE - A PARAMETER TO INDICATE THE SCALING OPTION ! SCALE = 'U' OR SCALE = 'u' returnS ! CY(J)=H(M,FNU+J-1,Z), J=1,...,N ! = 'S' OR SCALE = 's' returnS ! CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) ! J=1,...,N , I**2=-1 ! M - KIND OF HANKEL function, M=1 OR 2 ! N - NUMBER OF MEMBERS OF THE SEQUENCE, N >= 1 ! ! OUTPUT ! CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN ! VALUES FOR THE SEQUENCE ! CY(J)=H(M,FNU+J-1,Z) OR ! CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N ! DEPENDING ON SCALE, I**2=-1. ! NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, ! NZ= 0 , NORMAL return ! NZ>0 , FIRST NZ COMPONENTS OF CY SET TO ZERO ! DUE TO UNDERFLOW, CY(J)=CMPLX(0.0,0.0) ! J=1,...,NZ WHEN Y>0.0 AND M=1 OR ! Y < 0.0 AND M=2. FOR THE COMPLMENTARY ! HALF PLANES, NZ STATES ONLY THE NUMBER ! OF UNDERFLOWS. ! IERR -ERROR FLAG ! IERR=0, NORMAL return - COMPUTATION COMPLETED ! IERR=1, INPUT ERROR - NO COMPUTATION ! IERR=2, OVERFLOW - NO COMPUTATION, ! CABS(Z) TOO SMALL ! IERR=3 OVERFLOW - NO COMPUTATION, ! FNU+N-1 TOO LARGE ! IERR=4, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE ! BUT LOSSES OF SIGNIFCANCE BY ARGUMENT ! REDUCTION PRODUCE LESS THAN HALF OF MACHINE ! ACCURACY ! IERR=5, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- ! TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- ! CANCE BY ARGUMENT REDUCTION ! IERR=6, ERROR - NO COMPUTATION, ! ALGORITHM TERMINATION CONDITION NOT MET ! ! LONG DESCRIPTION ! ================ ! ! THE COMPUTATION IS CARRIED OUT BY THE RELATION ! ! H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP)) ! MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1 ! ! FOR M=1 OR 2 WHERE THE K BESSEL function IS COMPUTED FOR THE ! RIGHT HALF PLANE RE(Z) >= 0.0. THE K function IS continueD ! TO THE LEFT HALF PLANE BY THE RELATION ! ! K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) ! MP=MR*PI*I, MR=+1 OR -1, RE(Z)>0, I**2=-1 ! ! WHERE I(FNU,Z) IS THE I BESSEL function. ! ! EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z ! PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL ! GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING ! BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE ! WHOLE Z PLANE FOR Z TO INFINITY. ! ! FOR NEGATIVE ORDERS,THE FORMULAE ! ! H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I) ! H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) ! I**2=-1 ! ! CAN BE USED. ! ! IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- ! MENTARY functionS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS ! LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. ! CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN ! LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG ! IERR=4 IS TRIGGERED WHERE UR=X02AJE()=UNIT ROUNDOFF. ALSO ! IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS ! LOST AND IERR=5. IN ORDER TO USE THE INT function, ARGUMENTS ! MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE ! INTEGER, U3=X02BBE(). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS ! RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 ! ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION ! ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION ! ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN ! THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT ! TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS ! IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. ! SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. ! ! THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX ! BESSEL function CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT ! ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- ! SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE ! ELEMENTARY functionS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), ! ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF ! CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY ! HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN ! ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY ! SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER ! THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, ! 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS ! THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER ! COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY ! BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER ! COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE ! MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, ! THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, ! OR -PI/2+P. ! ! REFERENCES ! ========== ! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ ! AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF ! COMMERCE, 1955. ! ! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT ! BY D. E. AMOS, SAND83-0083, MAY, 1983. ! ! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT ! AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 ! ! A subroutine PACKAGE FOR BESSEL functionS OF A COMPLEX ! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- ! 1018, MAY, 1985 ! ! A PORTABLE PACKAGE FOR BESSEL functionS OF A COMPLEX ! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. ! MATH. SOFTWARE, 1986 ! ! DATE WRITTEN 830501 (YYMMDD) ! REVISION DATE 830501 (YYMMDD) ! AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES ! ! .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='S17DLE') ! .. Scalar Arguments .. COMPLEX Z REAL FNU INTEGER IFAIL, M, N, NZ CHARACTER*1 SCALE ! .. Array Arguments .. COMPLEX CY(N) ! .. Local Scalars .. COMPLEX CSGN, ZN, ZT REAL AA, ALIM, ALN, ARG, ASCLE, ATOL, AZ, BB, CPN, & DIG, ELIM, FMM, FN, FNUL, HPI, R1M5, RHPI, RL, & RTOL, SGN, SPN, TOL, UFL, XN, XX, YN, YY INTEGER I, IERR, INU, INUH, IR, K, K1, K2, KODE, MM, MR, & NN, NREC, NUF, NW ! .. Local Arrays .. CHARACTER*80 REC(1) ! .. External functions .. REAL X02AHE, X02AJE INTEGER P01ABE, X02BBE, X02BHE, X02BJE, X02BKE, X02BLE EXTERNAL X02AHE, X02AJE, P01ABE, X02BBE, X02BHE, X02BJE, & X02BKE, X02BLE ! .. External subroutines .. EXTERNAL DEVS17, DGXS17, DLYS17, DLZS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, LOG, LOG10, & MAX, MIN, MOD, REAL, SIGN, SIN, SQRT ! .. Data statements .. ! DATA HPI/1.57079632679489662E0/ ! .. Executable Statements .. NZ = 0 NREC = 0 XX = REAL(Z) YY = AIMAG(Z) IERR = 0 if (SCALE == 'U' .or. SCALE == 'u') then KODE = 1 else if (SCALE == 'S' .or. SCALE == 's') then KODE = 2 ELSE KODE = -1 endif if (XX == 0.0E0 .and. YY == 0.0E0) then IERR = 1 NREC = 1 WRITE (REC,FMT=99999) else if (FNU < 0.0E0) then IERR = 1 NREC = 1 WRITE (REC,FMT=99998) FNU else if (KODE == -1) then IERR = 1 NREC = 1 WRITE (REC,FMT=99997) SCALE else if (N < 1) then IERR = 1 NREC = 1 WRITE (REC,FMT=99996) N else if (M < 1 .or. M > 2) then IERR = 1 NREC = 1 WRITE (REC,FMT=99995) M endif if (IERR == 0) then NN = N ! --------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM)>EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR ! LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE ! FNU ! --------------------------------------------------------------- TOL = MAX(X02AJE(),1.0E-18) K1 = X02BKE() K2 = X02BLE() R1M5 = LOG10(REAL(X02BHE())) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = X02BJE() - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) RL = 1.2E0*DIG + 3.0E0 FN = FNU + NN - 1 MM = 3 - M - M FMM = MM ZN = Z*CMPLX(0.0E0,-FMM) XN = REAL(ZN) YN = AIMAG(ZN) AZ = ABS(Z) ! --------------------------------------------------------------- ! TEST FOR RANGE ! --------------------------------------------------------------- AA = 0.5E0/TOL BB = X02BBE(1.0E0)*0.5E0 AA = MIN(AA,BB,X02AHE(1.0E0)) if (AZ <= AA) then if (FN <= AA) then AA = SQRT(AA) if (AZ > AA) then IERR = 4 NREC = 1 WRITE (REC,FMT=99994) AZ, AA else if (FN > AA) then IERR = 4 NREC = 1 WRITE (REC,FMT=99993) FN, AA endif ! --------------------------------------------------------- ! OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE ! --------------------------------------------------------- UFL = EXP(-ELIM) if (AZ >= UFL) then if (FNU > FNUL) then ! --------------------------------------------------- ! UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU>FNUL ! --------------------------------------------------- MR = 0 if ((XN < 0.0E0) .or. (XN == 0.0E0 .and. YN <& 0.0E0 .and. M == 2)) then MR = -MM if (XN == 0.0E0 .and. YN < 0.0E0) ZN = -ZN endif CALL DLYS17(ZN,FNU,KODE,MR,NN,CY,NW,TOL,ELIM,ALIM) if (NW < 0) then goto 40 ELSE NZ = NZ + NW endif ELSE if (FN > 1.0E0) then if (FN > 2.0E0) then CALL DEVS17(ZN,FNU,KODE,2,NN,CY,NUF,TOL,ELIM, & ALIM) if (NUF < 0) then goto 60 ELSE NZ = NZ + NUF NN = NN - NUF ! ------------------------------------------ ! HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ! ON return FROM DEVS17 ! IF NUF=NN, THEN CY(I)=CZERO FOR ALL I ! ------------------------------------------ if (NN == 0) then if (XN < 0.0E0) then goto 60 ELSE IFAIL = P01ABE(IFAIL,IERR,SRNAME, & NREC,REC) return endif endif endif else if (AZ <= TOL) then ARG = 0.5E0*AZ ALN = -FN*LOG(ARG) if (ALN > ELIM) goto 60 endif endif if ((XN < 0.0E0) .or. (XN == 0.0E0 .and. YN <& 0.0E0 .and. M == 2)) then ! ------------------------------------------------ ! LEFT HALF PLANE COMPUTATION ! ------------------------------------------------ MR = -MM CALL DLZS17(ZN,FNU,KODE,MR,NN,CY,NW,RL,FNUL,TOL, & ELIM,ALIM) if (NW < 0) then goto 40 ELSE NZ = NW endif ELSE ! ------------------------------------------------ ! RIGHT HALF PLANE COMPUTATION, XN >= 0. .and. ! (XN /= 0. .or. YN >= 0. .or. M=1) ! ------------------------------------------------ CALL DGXS17(ZN,FNU,KODE,NN,CY,NZ,TOL,ELIM,ALIM) endif endif ! ------------------------------------------------------ ! H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) ! ! ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 ! ------------------------------------------------------ SGN = SIGN(HPI,-FMM) ! ------------------------------------------------------ ! CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF ! SIGNIFICANCE WHEN FNU IS LARGE ! ------------------------------------------------------ INU = INT(FNU) INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-INU+IR)*SGN RHPI = 1.0E0/SGN CPN = RHPI*COS(ARG) SPN = RHPI*SIN(ARG) ! ZN = CMPLX(-SPN,CPN) CSGN = CMPLX(-SPN,CPN) ! if (MOD(INUH,2)==1) ZN = -ZN if (MOD(INUH,2) == 1) CSGN = -CSGN ZT = CMPLX(0.0E0,-FMM) RTOL = 1.0E0/TOL ASCLE = UFL*RTOL DO 20 I = 1, NN ! CY(I) = CY(I)*ZN ! ZN = ZN*ZT ZN = CY(I) AA = REAL(ZN) BB = AIMAG(ZN) ATOL = 1.0E0 if (MAX(ABS(AA),ABS(BB)) <= ASCLE) then ZN = ZN*RTOL ATOL = TOL endif ZN = ZN*CSGN CY(I) = ZN*ATOL CSGN = CSGN*ZT 20 continue IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return 40 if (NW == (-3)) then NZ = 0 IERR = 5 NREC = 1 WRITE (REC,FMT=99988) AZ, AA IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return else if (NW /= (-1)) then NZ = 0 IERR = 6 NREC = 1 WRITE (REC,FMT=99992) IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif 60 IERR = 3 NZ = 0 NREC = 1 WRITE (REC,FMT=99991) FN IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return ELSE IERR = 2 NZ = 0 NREC = 1 WRITE (REC,FMT=99990) AZ, UFL IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif ELSE NZ = 0 IERR = 5 NREC = 1 WRITE (REC,FMT=99989) FN, AA endif ELSE NZ = 0 IERR = 5 NREC = 1 WRITE (REC,FMT=99988) AZ, AA endif endif IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return ! 99999 FORMAT (1X,'** On entry, Z = (0.0,0.0)') 99998 FORMAT (1X,'** On entry, FNU < 0: FNU = ',E13.5) 99997 FORMAT (1X,'** On entry, SCALE has an illegal value: SCALE = ''', & A,'''') 99996 FORMAT (1X,'** On entry, N <= 0: N = ',I16) 99995 FORMAT (1X,'** On entry, M has illegal value: M = ',I16) 99994 FORMAT (1X,'** Results lack precision because abs(Z) =',1P,E13.5, & ' > ',E13.5) 99993 FORMAT (1X,'** Results lack precision, FNU+N-1 =',1P,E13.5, & ' > ',E13.5) 99992 FORMAT (1X,'** No computation - algorithm termination condition ', & 'not met.') 99991 FORMAT (1X,'** No computation because FNU+N-1 =',1P,E13.5,' is t', & 'oo large.') 99990 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' < ', & E13.5) 99989 FORMAT (1X,'** No computation because FNU+N-1 =',1P,E13.5,' > ', & E13.5) 99988 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' > ', & E13.5) END REAL function X02AHE(X) ! MARK 9 RELEASE. NAG COPYRIGHT 1981. ! MARK 11.5(F77) REVISED. (SEPT 1985.) ! ! * MAXIMUM ARGUMENT FOR SIN AND COS * ! returnS THE LARGEST POSITIVE REAL NUMBER MAXSC SUCH THAT ! SIN(MAXSC) AND COS(MAXSC) CAN BE SUCCESSFULLY COMPUTED ! BY THE COMPILER SUPPLIED SIN AND COS ROUTINES. ! ! .. Scalar Arguments .. REAL X REAL CONX02 DATA CONX02 /1.677721600000E+7 / ! .. Executable Statements .. X02AHE = CONX02 return END REAL function X02AJE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS (1/2)*B**(1-P) IF ROUNDS IS .true. ! returnS B**(1-P) OTHERWISE ! REAL CONX02 DATA CONX02 /1.4210854715202E-14 / !bc DATA CONX02 /1.421090000020E-14 / ! .. Executable Statements .. X02AJE = CONX02 return END REAL function X02ALE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS (1 - B**(-P)) * B**EMAX (THE LARGEST POSITIVE MODEL ! NUMBER) ! REAL CONX02 ! DK DK DK DATA CONX02 /0577757777777777777777B / DATA CONX02 /1.e30/ ! .. Executable Statements .. X02ALE = CONX02 return END REAL function X02AME() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE 'SAFE RANGE' PARAMETER ! I.E. THE SMALLEST POSITIVE MODEL NUMBER Z SUCH THAT ! FOR ANY X WHICH SATISFIES X >= Z AND X <= 1/Z ! THE FOLLOWING CAN BE COMPUTED WITHOUT OVERFLOW, UNDERFLOW OR OTHER ! ERROR ! ! -X ! 1.0/X ! SQRT(X) ! LOG(X) ! EXP(LOG(X)) ! Y**(LOG(X)/LOG(Y)) FOR ANY Y ! REAL CONX02 ! DK DK DK DATA CONX02 /0200044000000000000004B / DATA CONX02 /1.e-27/ ! .. Executable Statements .. X02AME = CONX02 return END REAL function X02ANE() ! MARK 15 RELEASE. NAG COPYRIGHT 1991. ! ! returns the 'safe range' parameter for complex numbers, ! i.e. the smallest positive model number Z such that ! for any X which satisfies X >= Z and X <= 1/Z ! the following can be computed without overflow, underflow or other ! error ! ! -W ! 1.0/W ! SQRT(W) ! LOG(W) ! EXP(LOG(W)) ! Y**(LOG(W)/LOG(Y)) for any Y ! ABS(W) ! ! where W is any of cmplx(X,0), cmplx(0,X), cmplx(X,X), ! cmplx(1/X,0), cmplx(0,1/X), cmplx(1/X,1/X). ! REAL CONX02 !bc DATA CONX02 /0000006220426276611547B / !! DK DK DATA CONX02 / 2.708212596942E-1233 / DATA CONX02 / 2.708212596942E-30 / ! .. Executable Statements .. X02ANE = CONX02 return END INTEGER function X02BBE(X) ! NAG COPYRIGHT 1975 ! MARK 4.5 RELEASE ! MARK 11.5(F77) REVISED. (SEPT 1985.) ! * MAXINT * ! returnS THE LARGEST INTEGER REPRESENTABLE ON THE COMPUTER ! THE X PARAMETER IS NOT USED ! .. Scalar Arguments .. REAL X ! .. Executable Statements .. ! FOR ICL 1900 ! X02BBE = 8388607 ! DK DK DK X02BBE = 70368744177663 X02BBE = 744177663 return END INTEGER function X02BHE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE MODEL PARAMETER, B. ! ! .. Executable Statements .. X02BHE = 2 return END INTEGER function X02BJE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE MODEL PARAMETER, p. ! ! .. Executable Statements .. X02BJE = 47 return END INTEGER function X02BKE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE MODEL PARAMETER, EMIN. ! ! .. Executable Statements .. X02BKE = -8192 return END INTEGER function X02BLE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE MODEL PARAMETER, EMAX. ! ! .. Executable Statements .. X02BLE = 8189 return END subroutine X04AAE(I,NERR) ! MARK 7 RELEASE. NAG COPYRIGHT 1978 ! MARK 7C REVISED IER-190 (MAY 1979) ! MARK 11.5(F77) REVISED. (SEPT 1985.) ! MARK 14 REVISED. IER-829 (DEC 1989). ! IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER ! (STORED IN NERR1). ! IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO ! VALUE SPECIFIED BY NERR. ! ! .. Scalar Arguments .. INTEGER I, NERR ! .. Local Scalars .. INTEGER NERR1 ! .. Save statement .. SAVE NERR1 ! .. Data statements .. DATA NERR1/0/ ! .. Executable Statements .. if (I == 0) NERR = NERR1 if (I == 1) NERR1 = NERR return END subroutine X04BAE(NOUT,REC) ! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. ! ! X04BAE writes the contents of REC to the unit defined by NOUT. ! ! Trailing blanks are not output, except that if REC is entirely ! blank, a single blank character is output. ! If NOUT < 0, i.e. if NOUT is not a valid Fortran unit identifier, ! then no output occurs. ! ! .. Scalar Arguments .. INTEGER NOUT CHARACTER*(*) REC ! .. Local Scalars .. INTEGER I ! .. Intrinsic functions .. INTRINSIC LEN ! .. Executable Statements .. if (NOUT >= 0) then ! Remove trailing blanks DO 20 I = LEN(REC), 2, -1 if (REC(I:I) /= ' ') goto 40 20 continue ! Write record to external file 40 WRITE (NOUT,FMT=99999) REC(1:I) endif return ! 99999 FORMAT (A) END ================================================ FILE: analytical_solution_viscoelastic_2D_plane_strain_Carcione_correct_with_1_over_L.f90 ================================================ program analytical_solution !! DK DK we compute the solution for velocity instead of for displacement in this version of the analytical code. ! This program implements the analytical solution for the velocity vector in a 2D plane-strain viscoelastic medium ! with a vertical force source located in (0,0), ! from Appendix B of Carcione et al., Wave propagation simulation in a linear viscoelastic medium, GJI, vol. 95, p. 597-611 (1988) ! (note that that Appendix contains two typos, fixed in this code; I added two comments below to mention them). ! The amplitude of the force is called F and is defined below. implicit none !! DK DK May 2018: the missing 1/L factor in older Carcione papers !! DK DK May 2018: has been added to this code by Quentin Brissaud and by Etienne Bachmann !! DK DK for the viscoacoustic code in directory EXAMPLES/attenuation/viscoacoustic, !! DK DK it would be very easy to copy the changes from there to this viscoelastic version; !! DK DK but then all the values of the tau_epsilon in the code below would need to change. !! DK DK Dimitri Komatitsch, CNRS Marseille, France, April 2017: added the elastic reference calculation. ! compute the non-viscoacoustic case as a reference if needed, i.e. turn attenuation off logical, parameter :: TURN_ATTENUATION_OFF = .false. ! to see how small the contribution of the near-field term is, ! here the user can ask not to include it, to then compare with the full result obtained with this flag set to false logical, parameter :: DO_NOT_COMPUTE_THE_NEAR_FIELD = .false. integer, parameter :: iratio = 64 integer, parameter :: nfreq = 524288 integer, parameter :: nt = iratio * nfreq double precision, parameter :: freqmax = 400.d0 !! DK DK to print the velocity if we want to display the curve of how velocity varies with frequency !! DK DK for instance to compute the unrelaxed velocity in the Zener model ! double precision, parameter :: freqmax = 20000.d0 double precision, parameter :: freqseuil = 0.00005d0 double precision, parameter :: pi = 3.141592653589793d0 ! for the solution in time domain integer it,i real wsave(4*nt+15) complex c(nt) !! DK DK for my slow inverse Discrete Fourier Transform using a double loop complex :: input(nt), i_imaginary_constant integer :: j,m ! density of the medium double precision, parameter :: rho = 2000.d0 ! unrelaxed (f = +infinity) values ! these values for the unrelaxed state are computed from the relaxed state values (Vp = 3000, Vs = 2000, rho = 2000) ! given in Carcione et al. 1988 GJI vol 95 p 604 Table 1 double precision, parameter :: Vp = 2000.d0 double precision, parameter :: Vs = Vp / 1.732d0 ! unrelaxed (f = +infinity) values, i.e. using the fastest Vp and Vs velocities double precision, parameter :: M2_unrelaxed = Vs**2 * 2.d0 * rho double precision, parameter :: M1_unrelaxed = 2.d0 * Vp**2 * rho - M2_unrelaxed ! amplitude of the force source double precision, parameter :: F = 1.d0 ! definition position recepteur Carcione double precision x1,x2 ! Definition source Dimitri double precision, parameter :: f0 = 35.d0 double precision, parameter :: t0 = 1.2d0 / f0 ! Definition source Carcione ! double precision f0,t0,eta,epsil ! parameter(f0 = 50.d0) ! parameter(t0 = 0.075d0) ! parameter(epsil = 1.d0) ! parameter(eta = 0.5d0) ! number of Zener standard linear solids in parallel integer, parameter :: Lnu = 3 ! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform ! DK DK at some point, for verification, using a double loop. I keep it just in case. ! DK DK For large number of points it is extremely slow because of the double loop. ! DK DK Thus there is no reason to turn this flag on. logical, parameter :: USE_SLOW_FOURIER_TRANSFORM = .false. !! DK DK March 2018: this missing 1/L factor has been added to this code by Quentin Brissaud !! DK DK for the viscoacoustic code in directory EXAMPLES/attenuation/viscoacoustic, !! DK DK it would be very easy to copy the changes from there to this viscoelastic version; !! DK DK but then all the values of the tau_epsilon below would need to change. double precision, dimension(Lnu) :: tau_sigma_nu1,tau_sigma_nu2,tau_epsilon_nu1,tau_epsilon_nu2 integer :: ifreq,icalculation double precision :: deltafreq,freq,omega,omega0,deltat,time,a double complex :: comparg ! Fourier transform of the Ricker wavelet source double complex fomega(0:nfreq) ! real and imaginary parts double precision ra(0:nfreq),rb(0:nfreq) ! spectral amplitude double precision ampli(0:nfreq) ! analytical solution for the two components double complex phi1(-nfreq:nfreq) double complex phi2(-nfreq:nfreq) ! external functions double complex, external :: u1,u2 ! modules elastiques double complex :: M1C, M2C, E, V1, V2, temp ! ********** end of variable declarations ************ ! classical least-squares constants tau_epsilon_nu1 = (/ 2.408158185753685d-002, 4.699608990861351d-003, 9.567997872435925d-004 /) tau_sigma_nu1 = (/ 2.256014638636808d-002, 4.508471279712252d-003, 8.937876403768840d-004 /) tau_epsilon_nu2 = (/ 2.430544480527216d-002, 4.728107829226396d-003, 9.667252695863502d-004 /) tau_sigma_nu2 = (/ 2.250919779429490d-002, 4.501388007338097d-003, 8.917332095369118d-004 /) ! do the calculation twice, because in the finite-difference code that we want to check using this analytical code ! the Vy component is staggered half a grid cell away from Vx, thus to compute the analytical solution we need ! to slightly change the location at which the calculation is done when computing the second component, ! by half a grid cell do icalculation = 1,2 ! position of the receiver if (icalculation == 1) then x1 = +801. - 1.5/2. x2 = +801. - 1.5/2. else if (icalculation == 2) then x1 = +801. x2 = +801. else stop 'wrong value of icalculation' endif print *,'Force source located at the origin (0,0)' print *,'Receiver located in (x,z) = ',x1,x2 if (TURN_ATTENUATION_OFF) then print *,'BEWARE: computing the elastic reference solution (i.e., without attenuation) instead of the viscoelastic solution' else print *,'Computing the viscoelastic solution' endif if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then print *,'BEWARE: computing the far-field solution only, rather than the full Green function' else print *,'Computing the full solution, including the near-field term of the Green function' endif ! step in frequency deltafreq = freqmax / dble(nfreq) ! define parameters for the Ricker source omega0 = 2.d0 * pi * f0 a = pi**2 * f0**2 deltat = 1.d0 / (freqmax*dble(iratio)) ! define the spectrum of the source do ifreq=0,nfreq freq = deltafreq * dble(ifreq) omega = 2.d0 * pi * freq ! typo in equation (B7) of Carcione et al., Wave propagation simulation in a linear viscoelastic medium, ! Geophysical Journal, vol. 95, p. 597-611 (1988), the exponential should be of -i omega t0, ! fixed here by adding the minus sign comparg = dcmplx(0.d0,-omega*t0) ! definir le spectre du Ricker de Carcione avec cos() ! equation (B7) of Carcione et al., Wave propagation simulation in a linear viscoelastic medium, ! Geophysical Journal, vol. 95, p. 597-611 (1988) ! fomega(ifreq) = pi * dsqrt(pi/eta) * (1.d0/omega0) * cdexp(comparg) * ( dexp(- (pi*pi/eta) * (epsil/2 - omega/omega0)**2) & ! + dexp(- (pi*pi/eta) * (epsil/2 + omega/omega0)**2) ) ! definir le spectre d'un Ricker classique (centre en t0) fomega(ifreq) = dsqrt(pi) * cdexp(comparg) * omega**2 * dexp(-omega**2/(4.d0*a)) / (2.d0 * dsqrt(a**3)) !! DK DK multiply by i omega in order to get the solution for velocity instead of for displacement fomega(ifreq) = fomega(ifreq) * dcmplx(0.d0,omega) ra(ifreq) = dreal(fomega(ifreq)) rb(ifreq) = dimag(fomega(ifreq)) ! prendre le module de l'amplitude spectrale ampli(ifreq) = dsqrt(ra(ifreq)**2 + rb(ifreq)**2) enddo ! sauvegarde du spectre d'amplitude de la source en Hz au format Gnuplot open(unit=10,file='spectrum_of_the_source_used.gnu',status='unknown') do ifreq = 0,nfreq freq = deltafreq * dble(ifreq) write(10,*) sngl(freq),sngl(ampli(ifreq)) enddo close(10) ! ************** calcul solution analytique **************** ! d'apres Carcione GJI vol 95 p 611 (1988) do ifreq=0,nfreq freq = deltafreq * dble(ifreq) omega = 2.d0 * pi * freq ! critere ad-hoc pour eviter singularite en zero if (freq < freqseuil) omega = 2.d0 * pi * freqseuil ! use standard infinite frequency (unrelaxed) reference, ! in which waves slow down when attenuation is turned on. temp = dcmplx(0.d0,0.d0) do i=1,Lnu temp = temp + dcmplx(1.d0,omega*tau_epsilon_nu1(i)) / dcmplx(1.d0,omega*tau_sigma_nu1(i)) enddo M1C = (M1_unrelaxed /(sum(tau_epsilon_nu1(:)/tau_sigma_nu1(:)))) * temp temp = dcmplx(0.d0,0.d0) do i=1,Lnu temp = temp + dcmplx(1.d0,omega*tau_epsilon_nu2(i)) / dcmplx(1.d0,omega*tau_sigma_nu2(i)) enddo M2C = (M2_unrelaxed /(sum(tau_epsilon_nu2(:)/tau_sigma_nu2(:)))) * temp if (TURN_ATTENUATION_OFF) then ! from Etienne Bachmann, May 2018: pour calculer la solution sans attenuation, il faut donner le Mu_unrelaxed et pas le Mu_relaxed. ! En effet, pour comparer avec SPECFEM, il faut simplement partir de la bonne reference. ! SPECFEM est defini en unrelaxed et les constantes unrelaxed dans Carcione matchent parfaitement les Vp et Vs definis dans SPECFEM. M1C = M1_unrelaxed M2C = M2_unrelaxed endif E = (M1C + M2C) / 2 V1 = cdsqrt(E / rho) !! DK DK this is Vp !! DK DK print the velocity if we want to display the curve of how velocity varies with frequency !! DK DK for instance to compute the unrelaxed velocity in the Zener model ! print *,freq,dsqrt(real(V1)**2 + imag(V1)**2) V2 = cdsqrt(M2C / (2.d0 * rho)) !! DK DK this is Vs !! DK DK print the velocity if we want to display the curve of how velocity varies with frequency !! DK DK for instance to compute the unrelaxed velocity in the Zener model ! print *,freq,dsqrt(real(V2)**2 + imag(V2)**2) ! calcul de la solution analytique en frequence phi1(ifreq) = u1(omega,V1,V2,x1,x2,rho,F,DO_NOT_COMPUTE_THE_NEAR_FIELD) * fomega(ifreq) phi2(ifreq) = u2(omega,V1,V2,x1,x2,rho,F,DO_NOT_COMPUTE_THE_NEAR_FIELD) * fomega(ifreq) enddo ! take the conjugate value for negative frequencies do ifreq=-nfreq,-1 phi1(ifreq) = dconjg(phi1(-ifreq)) phi2(ifreq) = dconjg(phi2(-ifreq)) enddo ! save the result in the frequency domain ! open(unit=11,file='cmplx_phi',status='unknown') ! do ifreq=-nfreq,nfreq ! freq = deltafreq * dble(ifreq) ! write(11,*) sngl(freq),sngl(dreal(phi1(ifreq))),sngl(dimag(phi1(ifreq))),sngl(dreal(phi2(ifreq))),sngl(dimag(phi2(ifreq))) ! enddo ! close(11) ! *************************************************************************** ! Calculation of the time domain solution (using routine "cfftb" from Netlib) ! *************************************************************************** ! ********** ! Compute Vx ! ********** if (icalculation == 1) then ! initialize FFT arrays call cffti(nt,wsave) ! clear array of Fourier coefficients do it = 1,nt c(it) = cmplx(0.,0.) enddo ! use the Fourier values for Vx c(1) = cmplx(phi1(0)) do ifreq=1,nfreq-2 c(ifreq+1) = cmplx(phi1(ifreq)) c(nt+1-ifreq) = conjg(cmplx(phi1(ifreq))) enddo ! perform the inverse FFT for Vx if (.not. USE_SLOW_FOURIER_TRANSFORM) then call cfftb(nt,c,wsave) else ! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform here ! DK DK at some point, for verification, using a double loop. I keep it just in case. ! DK DK For large number of points it is extremely slow because of the double loop. input(:) = c(:) ! imaginary constant "i" i_imaginary_constant = (0.,1.) do it = 1,nt if (mod(it,1000) == 0) print *,'FFT inverse it = ',it,' out of ',nt j = it c(j) = cmplx(0.,0.) do m = 1,nt c(j) = c(j) + input(m) * exp(2.d0 * PI * i_imaginary_constant * dble((m-1) * (j-1)) / nt) enddo enddo endif ! in the inverse Discrete Fourier transform one needs to divide by N, the number of samples (number of time steps here) c(:) = c(:) / nt ! value of a time step deltat = 1.d0 / (freqmax*dble(iratio)) ! to get the amplitude right, we need to divide by the time step c(:) = c(:) / deltat ! save time result inverse FFT for Vx if (TURN_ATTENUATION_OFF) then if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then open(unit=11,file='Vx_time_analytical_solution_elastic_without_near_field.dat',status='unknown') else open(unit=11,file='Vx_time_analytical_solution_elastic.dat',status='unknown') endif else if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then open(unit=11,file='Vx_time_analytical_solution_viscoelastic_without_near_field.dat',status='unknown') else open(unit=11,file='Vx_time_analytical_solution_viscoelastic.dat',status='unknown') endif endif do it=1,nt ! DK DK Dec 2011: subtract t0 to be consistent with the SPECFEM2D code time = dble(it-1)*deltat - t0 ! the seismograms are very long due to the very large number of FFT points used, ! thus keeping the useful part of the signal only (the first six seconds of the seismogram) if (time >= 0.d0 .and. time <= 6.d0) write(11,*) sngl(time),real(c(it)) enddo close(11) endif ! of if (icalculation == 1) then ! ********** ! Compute Vz ! ********** if (icalculation == 2) then ! clear array of Fourier coefficients do it = 1,nt c(it) = cmplx(0.,0.) enddo ! use the Fourier values for Vz c(1) = cmplx(phi2(0)) do ifreq=1,nfreq-2 c(ifreq+1) = cmplx(phi2(ifreq)) c(nt+1-ifreq) = conjg(cmplx(phi2(ifreq))) enddo ! perform the inverse FFT for Vz if (.not. USE_SLOW_FOURIER_TRANSFORM) then call cfftb(nt,c,wsave) else ! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform here ! DK DK at some point, for verification, using a double loop. I keep it just in case. ! DK DK For large number of points it is extremely slow because of the double loop. input(:) = c(:) ! imaginary constant "i" i_imaginary_constant = (0.,1.) do it = 1,nt if (mod(it,1000) == 0) print *,'FFT inverse it = ',it,' out of ',nt j = it c(j) = cmplx(0.,0.) do m = 1,nt c(j) = c(j) + input(m) * exp(2.d0 * PI * i_imaginary_constant * dble((m-1) * (j-1)) / nt) enddo enddo endif ! in the inverse Discrete Fourier transform one needs to divide by N, the number of samples (number of time steps here) c(:) = c(:) / nt ! value of a time step deltat = 1.d0 / (freqmax*dble(iratio)) ! to get the amplitude right, we need to divide by the time step c(:) = c(:) / deltat ! save time result inverse FFT for Vz if (TURN_ATTENUATION_OFF) then if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then open(unit=11,file='Vz_time_analytical_solution_elastic_without_near_field.dat',status='unknown') else open(unit=11,file='Vz_time_analytical_solution_elastic.dat',status='unknown') endif else if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then open(unit=11,file='Vz_time_analytical_solution_viscoelastic_without_near_field.dat',status='unknown') else open(unit=11,file='Vz_time_analytical_solution_viscoelastic.dat',status='unknown') endif endif do it=1,nt ! DK DK Dec 2011: subtract t0 to be consistent with the SPECFEM2D code time = dble(it-1)*deltat - t0 ! the seismograms are very long due to the very large number of FFT points used, ! thus keeping the useful part of the signal only (the first six seconds of the seismogram) if (time >= 0.d0 .and. time <= 6.d0) write(11,*) sngl(time),real(c(it)) enddo close(11) endif ! of if (icalculation == 2) then enddo ! of do icalculation = 1,2 end ! ----------- double complex function u1(omega,v1,v2,x1,x2,rho,F,DO_NOT_COMPUTE_THE_NEAR_FIELD) implicit none double precision omega double complex v1,v2 logical :: DO_NOT_COMPUTE_THE_NEAR_FIELD double complex G1,G2 external G1,G2 double precision, parameter :: pi = 3.141592653589793d0 ! amplitude of the force double precision F double precision x1,x2,r,rho ! source-receiver distance r = dsqrt(x1**2 + x2**2) u1 = F * x1 * x2 * (G1(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD) + & G2(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD)) / (2.d0 * pi * rho * r**2) end ! ----------- double complex function u2(omega,v1,v2,x1,x2,rho,F,DO_NOT_COMPUTE_THE_NEAR_FIELD) implicit none double precision omega double complex v1,v2 logical :: DO_NOT_COMPUTE_THE_NEAR_FIELD double complex G1,G2 external G1,G2 double precision, parameter :: pi = 3.141592653589793d0 ! amplitude of the force double precision F double precision x1,x2,r,rho ! source-receiver distance r = dsqrt(x1**2 + x2**2) u2 = F * (x2*x2*G1(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD) - & x1*x1*G2(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD)) / (2.d0 * pi * rho * r**2) end ! ----------- double complex function G1(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD) implicit none double precision r,omega double complex v1,v2 logical :: DO_NOT_COMPUTE_THE_NEAR_FIELD double complex hankel0,hankel1 external hankel0,hankel1 double precision, parameter :: pi = 3.141592653589793d0 ! typo in equations (B4a) and (B4b) of Carcione et al., Wave propagation simulation in a linear viscoelastic medium, ! Geophysical Journal, vol. 95, p. 597-611 (1988), fixed here: omega/(r*v) -> omega*r/v if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then G1 = (hankel0(omega*r/v1)/(v1**2)) * dcmplx(0.d0,-pi/2.d0) else G1 = (hankel0(omega*r/v1)/(v1**2) + hankel1(omega*r/v2)/(omega*r*v2) - hankel1(omega*r/v1)/(omega*r*v1)) * dcmplx(0.d0,-pi/2.d0) endif end ! ----------- double complex function G2(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD) implicit none double precision r,omega double complex v1,v2 logical :: DO_NOT_COMPUTE_THE_NEAR_FIELD double complex hankel0,hankel1 external hankel0,hankel1 double precision, parameter :: pi = 3.141592653589793d0 ! typo in equations (B4a) and (B4b) of Carcione et al., Wave propagation simulation in a linear viscoelastic medium, ! Geophysical Journal, vol. 95, p. 597-611 (1988), fixed here: omega/(r*v) -> omega*r/v if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then G2 = (hankel0(omega*r/v2)/(v2**2)) * dcmplx(0.d0,+pi/2.d0) else G2 = (hankel0(omega*r/v2)/(v2**2) - hankel1(omega*r/v2)/(omega*r*v2) + hankel1(omega*r/v1)/(omega*r*v1)) * dcmplx(0.d0,+pi/2.d0) endif end ! ----------- double complex function hankel0(z) implicit none double complex z ! on utilise la routine NAG appelee S17DLE (simple precision) integer ifail,nz complex result ifail = -1 call S17DLE(2,0.0,cmplx(z),1,'U',result,nz,ifail) if (ifail /= 0) stop 'S17DLE failed in hankel0' if (nz > 0) print *,nz,' termes mis a zero par underflow' hankel0 = dcmplx(result) end ! ----------- double complex function hankel1(z) implicit none double complex z ! on utilise la routine NAG appelee S17DLE (simple precision) integer ifail,nz complex result ifail = -1 call S17DLE(2,1.0,cmplx(z),1,'U',result,nz,ifail) if (ifail /= 0) stop 'S17DLE failed in hankel1' if (nz > 0) print *,nz,' termes mis a zero par underflow' hankel1 = dcmplx(result) end ! ***************** routine de FFT pour signal en temps **************** ! FFT routine taken from Netlib subroutine CFFTB (N,C,WSAVE) DIMENSION C(1) ,WSAVE(1) if (N == 1) return IW1 = N+N+1 IW2 = IW1+N+N CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) return END subroutine CFFTB1 (N,C,CH,WA,IFAC) DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1) NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDOT = IDO+IDO IDL1 = IDOT*L1 if (IP /= 4) goto 103 IX2 = IW+IDOT IX3 = IX2+IDOT if (NA /= 0) goto 101 CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) goto 102 101 CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA goto 115 103 if (IP /= 2) goto 106 if (NA /= 0) goto 104 CALL PASSB2 (IDOT,L1,C,CH,WA(IW)) goto 105 104 CALL PASSB2 (IDOT,L1,CH,C,WA(IW)) 105 NA = 1-NA goto 115 106 if (IP /= 3) goto 109 IX2 = IW+IDOT if (NA /= 0) goto 107 CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) goto 108 107 CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA goto 115 109 if (IP /= 5) goto 112 IX2 = IW+IDOT IX3 = IX2+IDOT IX4 = IX3+IDOT if (NA /= 0) goto 110 CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) goto 111 110 CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA goto 115 112 if (NA /= 0) goto 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) goto 114 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 if (NAC /= 0) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDOT 116 continue if (NA == 0) return N2 = N+N DO 117 I=1,N2 C(I) = CH(I) 117 continue return END subroutine PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1), & C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), & CH2(IDL1,IP) IDOT = IDO/2 NT = IP*IDL1 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO ! if (IDO < L1) goto 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 continue 102 continue 103 continue DO 105 K=1,L1 DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 continue 105 continue goto 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 continue 108 continue 109 continue DO 111 I=1,IDO DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 continue 111 continue 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = WA(IDL)*CH2(IK,IP) 113 continue IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC if (IDLJ > IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) 114 continue 115 continue 116 continue DO 118 J=2,IPPH DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 continue 118 continue DO 120 J=2,IPPH JC = IPP2-J DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 continue 120 continue NAC = 1 if (IDO == 2) return NAC = 0 DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 continue DO 123 J=2,IP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 continue 123 continue if (IDOT > L1) goto 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 DO 124 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 124 continue 125 continue 126 continue return 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ DO 128 I=4,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 128 continue 129 continue 130 continue return END subroutine PASSB2 (IDO,L1,CC,CH,WA1) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2), & WA1(1) if (IDO > 2) goto 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 103 continue 104 continue return END subroutine PASSB3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3), & WA1(1) ,WA2(1) DATA TAUR,TAUI /-.5,.866025403784439/ if (IDO /= 2) goto 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 103 continue 104 continue return END subroutine PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4), & WA1(1) ,WA2(1) ,WA3(1) if (IDO /= 2) goto 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,4,K)-CC(2,2,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,2,K)-CC(1,4,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,4,K)-CC(I,2,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,2,K)-CC(I-1,4,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 103 continue 104 continue return END subroutine PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5), & WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, & -.809016994374947,.587785252292473/ if (IDO /= 2) goto 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 103 continue 104 continue return END subroutine CFFTI (N,WSAVE) DIMENSION WSAVE(1) if (N == 1) return IW1 = N+N+1 IW2 = IW1+N+N CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2)) return END subroutine CFFTI1 (N,WA,IFAC) DIMENSION WA(1) ,IFAC(1) ,NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/ NL = N NF = 0 J = 0 101 J = J+1 if (J-4) 102,102,103 102 NTRY = NTRYH(J) goto 104 103 NTRY = NTRY+2 104 NQ = NL/NTRY NR = NL-NTRY*NQ if (NR) 101,105,101 105 NF = NF+1 IFAC(NF+2) = NTRY NL = NQ if (NTRY /= 2) goto 107 if (NF == 1) goto 107 DO 106 I=2,NF IB = NF-I+2 IFAC(IB+2) = IFAC(IB+1) 106 continue IFAC(3) = 2 107 if (NL /= 1) goto 104 IFAC(1) = N IFAC(2) = NF TPI = 6.28318530717959 ARGH = TPI/FLOAT(N) I = 2 L1 = 1 DO 110 K1=1,NF IP = IFAC(K1+2) LD = 0 L2 = L1*IP IDO = N/L2 IDOT = IDO+IDO+2 IPM = IP-1 DO 109 J=1,IPM I1 = I WA(I-1) = 1. WA(I) = 0. LD = LD+L1 FI = 0. ARGLD = FLOAT(LD)*ARGH DO 108 II=4,IDOT,2 I = I+2 FI = FI+1. ARG = FI*ARGLD WA(I-1) = COS(ARG) WA(I) = SIN(ARG) 108 continue if (IP <= 5) goto 109 WA(I1-1) = WA(I-1) WA(I1) = WA(I) 109 continue L1 = L2 110 continue return END subroutine CFFTF (N,C,WSAVE) DIMENSION C(1) ,WSAVE(1) if (N == 1) return IW1 = N+N+1 IW2 = IW1+N+N CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) return END subroutine CFFTF1 (N,C,CH,WA,IFAC) DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1) NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDOT = IDO+IDO IDL1 = IDOT*L1 if (IP /= 4) goto 103 IX2 = IW+IDOT IX3 = IX2+IDOT if (NA /= 0) goto 101 CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) goto 102 101 CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA goto 115 103 if (IP /= 2) goto 106 if (NA /= 0) goto 104 CALL PASSF2 (IDOT,L1,C,CH,WA(IW)) goto 105 104 CALL PASSF2 (IDOT,L1,CH,C,WA(IW)) 105 NA = 1-NA goto 115 106 if (IP /= 3) goto 109 IX2 = IW+IDOT if (NA /= 0) goto 107 CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) goto 108 107 CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA goto 115 109 if (IP /= 5) goto 112 IX2 = IW+IDOT IX3 = IX2+IDOT IX4 = IX3+IDOT if (NA /= 0) goto 110 CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) goto 111 110 CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA goto 115 112 if (NA /= 0) goto 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) goto 114 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 if (NAC /= 0) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDOT 116 continue if (NA == 0) return N2 = N+N DO 117 I=1,N2 C(I) = CH(I) 117 continue return END subroutine PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1), & C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), & CH2(IDL1,IP) IDOT = IDO/2 NT = IP*IDL1 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO ! if (IDO < L1) goto 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 continue 102 continue 103 continue DO 105 K=1,L1 DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 continue 105 continue goto 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 continue 108 continue 109 continue DO 111 I=1,IDO DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 continue 111 continue 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = -WA(IDL)*CH2(IK,IP) 113 continue IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC if (IDLJ > IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) 114 continue 115 continue 116 continue DO 118 J=2,IPPH DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 continue 118 continue DO 120 J=2,IPPH JC = IPP2-J DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 continue 120 continue NAC = 1 if (IDO == 2) return NAC = 0 DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 continue DO 123 J=2,IP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 continue 123 continue if (IDOT > L1) goto 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 DO 124 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 124 continue 125 continue 126 continue return 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ DO 128 I=4,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 128 continue 129 continue 130 continue return END subroutine PASSF2 (IDO,L1,CC,CH,WA1) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2), & WA1(1) if (IDO > 2) goto 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 103 continue 104 continue return END subroutine PASSF3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3), & WA1(1) ,WA2(1) DATA TAUR,TAUI /-.5,-.866025403784439/ if (IDO /= 2) goto 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 103 continue 104 continue return END subroutine PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4), & WA1(1) ,WA2(1) ,WA3(1) if (IDO /= 2) goto 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,2,K)-CC(2,4,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,4,K)-CC(1,2,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,2,K)-CC(I,4,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,4,K)-CC(I-1,2,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 103 continue 104 continue return END subroutine PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5), & WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) DATA TR11,TI11,TR12,TI12 /.309016994374947,-.951056516295154, & -.809016994374947,-.587785252292473/ if (IDO /= 2) goto 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 continue return 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 103 continue 104 continue return END ! !!!!!!!! DK DK NAG routines included below ! DK DK march99 : routines recuperees sur le Cray (simple precision) subroutine ABZP01 ! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. ! ! Terminates execution when a hard failure occurs. ! ! ******************** IMPLEMENTATION NOTE ******************** ! The following STOP statement may be replaced by a call to an ! implementation-dependent routine to display a message and/or ! to abort the program. ! ************************************************************* ! .. Executable Statements .. STOP END subroutine DCYS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-785 (DEC 1989). ! ! Original name: CUNK2 ! ! DCYS18 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE ! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE ! UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) ! WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR ! -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT ! HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- ! ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. ! NZ=-1 MEANS AN OVERFLOW WILL OCCUR ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX AI, ARGD, ASUMD, BSUMD, C1, C2, CFN, CI, CK, & CONE, CR1, CR2, CRSC, CS, CSCL, CSGN, CSPN, & CZERO, DAI, PHID, RZ, S1, S2, ZB, ZETA1D, & ZETA2D, ZN, ZR REAL AARG, AIC, ANG, APHI, ASC, ASCLE, C2I, C2M, C2R, & CAR, CPN, FMR, FN, FNF, HPI, PI, RS1, SAR, SGN, & SPN, X, YY INTEGER I, IB, IC, IDUM, IFLAG, IFN, IL, IN, INU, IPARD, & IUF, J, K, KDFLG, KFLAG, KK, NAI, NDAI, NW ! .. Local Arrays .. COMPLEX ARG(2), ASUM(2), BSUM(2), CIP(4), CSR(3), & CSS(3), CY(2), PHI(2), ZETA1(2), ZETA2(2) REAL BRY(3) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEUS17, S17DGE, DGSS17, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, INT, LOG, & MAX, MOD, REAL, SIGN, SIN ! .. Data statements .. DATA CZERO, CONE, CI, CR1, CR2/(0.0E0,0.0E0), & (1.0E0,0.0E0), (0.0E0,1.0E0), & (1.0E0,1.73205080756887729E0), & (-0.5E0,-8.66025403784438647E-01)/ DATA HPI, PI, AIC/1.57079632679489662E+00, & 3.14159265358979324E+00, & 1.26551212348464539E+00/ DATA CIP(1), CIP(2), CIP(3), CIP(4)/(1.0E0,0.0E0), & (0.0E0,-1.0E0), (-1.0E0,0.0E0), (0.0E0,1.0E0)/ ! .. Executable Statements .. ! KDFLG = 1 NZ = 0 ! ------------------------------------------------------------------ ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN ! THE UNDERFLOW LIMIT ! ------------------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() X = REAL(Z) ZR = Z if (X < 0.0E0) ZR = -Z YY = AIMAG(ZR) ZN = -ZR*CI ZB = ZR INU = INT(FNU) FNF = FNU - INU ANG = -HPI*FNF CAR = COS(ANG) SAR = SIN(ANG) CPN = -HPI*CAR SPN = -HPI*SAR C2 = CMPLX(-SPN,CPN) KK = MOD(INU,4) + 1 CS = CR1*C2*CIP(KK) if (YY <= 0.0E0) then ZN = CONJG(-ZN) ZB = CONJG(ZB) endif ! ------------------------------------------------------------------ ! K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST ! QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY ! CONJUGATION SINCE THE K function IS REAL ON THE POSITIVE REAL AXIS ! ------------------------------------------------------------------ J = 2 DO 40 I = 1, N ! --------------------------------------------------------------- ! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J ! --------------------------------------------------------------- J = 3 - J FN = FNU + I - 1 CALL DEUS17(ZN,FN,0,TOL,PHI(J),ARG(J),ZETA1(J),ZETA2(J),ASUM(J) & ,BSUM(J),ELIM) if (KODE == 1) then S1 = ZETA1(J) - ZETA2(J) ELSE CFN = CMPLX(FN,0.0E0) S1 = ZETA1(J) - CFN*(CFN/(ZB+ZETA2(J))) endif ! --------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW ! --------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (KDFLG == 1) KFLAG = 2 if (ABS(RS1) >= ALIM) then ! --------------------------------------------------------- ! REFINE TEST AND SCALE ! --------------------------------------------------------- APHI = ABS(PHI(J)) AARG = ABS(ARG(J)) RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC if (ABS(RS1) > ELIM) then goto 20 ELSE if (KDFLG == 1) KFLAG = 1 if (RS1 >= 0.0E0) then if (KDFLG == 1) KFLAG = 3 endif endif endif ! ------------------------------------------------------------ ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES ! ------------------------------------------------------------ C2 = ARG(J)*CR2 IDUM = 1 ! S17DGE assumed not to fail, therefore IDUM set to one. CALL S17DGE('F',C2,'S',AI,NAI,IDUM) IDUM = 1 CALL S17DGE('D',C2,'S',DAI,NDAI,IDUM) S2 = CS*PHI(J)*(AI*ASUM(J)+CR2*DAI*BSUM(J)) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(KFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (KFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) goto 20 endif if (YY <= 0.0E0) S2 = CONJG(S2) CY(KDFLG) = S2 Y(I) = S2*CSR(KFLAG) CS = -CI*CS if (KDFLG == 2) then goto 60 ELSE KDFLG = 2 goto 40 endif endif 20 if (RS1 > 0.0E0) then goto 280 ! ------------------------------------------------------------ ! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW ! ------------------------------------------------------------ else if (X < 0.0E0) then goto 280 ELSE KDFLG = 1 Y(I) = CZERO CS = -CI*CS NZ = NZ + 1 if (I /= 1) then if (Y(I-1) /= CZERO) then Y(I-1) = CZERO NZ = NZ + 1 endif endif endif 40 continue I = N 60 RZ = CMPLX(2.0E0,0.0E0)/ZR CK = CMPLX(FN,0.0E0)*RZ IB = I + 1 if (N >= IB) then ! --------------------------------------------------------------- ! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ! ZERO ON UNDERFLOW ! --------------------------------------------------------------- FN = FNU + N - 1 IPARD = 1 if (MR /= 0) IPARD = 0 CALL DEUS17(ZN,FN,IPARD,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD, & BSUMD,ELIM) if (KODE == 1) then S1 = ZETA1D - ZETA2D ELSE CFN = CMPLX(FN,0.0E0) S1 = ZETA1D - CFN*(CFN/(ZB+ZETA2D)) endif RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (ABS(RS1) >= ALIM) then ! --------------------------------------------------------- ! REFINE ESTIMATE AND TEST ! --------------------------------------------------------- APHI = ABS(PHID) AARG = ABS(ARGD) RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC if (ABS(RS1) >= ELIM) goto 100 endif ! ------------------------------------------------------------ ! SCALED FORWARD RECURRENCE FOR REMAINDER OF THE SEQUENCE ! ------------------------------------------------------------ S1 = CY(1) S2 = CY(2) C1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 80 I = IB, N C2 = S2 S2 = CK*S2 + S1 S1 = C2 CK = CK + RZ C2 = S2*C1 Y(I) = C2 if (KFLAG < 3) then C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) C1 = CSR(KFLAG) endif endif 80 continue goto 140 endif 100 if (RS1 > 0.0E0) then goto 280 ! ------------------------------------------------------------ ! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW ! ------------------------------------------------------------ else if (X < 0.0E0) then goto 280 ELSE NZ = N DO 120 I = 1, N Y(I) = CZERO 120 continue return endif endif 140 if (MR == 0) then return ELSE ! --------------------------------------------------------------- ! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0 ! --------------------------------------------------------------- NZ = 0 FMR = MR SGN = -SIGN(PI,FMR) ! --------------------------------------------------------------- ! CSPN AND CSGN ARE COEFF OF K AND I functionS RESP. ! --------------------------------------------------------------- CSGN = CMPLX(0.0E0,SGN) if (YY <= 0.0E0) CSGN = CONJG(CSGN) IFN = INU + N - 1 ANG = FNF*SGN CPN = COS(ANG) SPN = SIN(ANG) CSPN = CMPLX(CPN,SPN) if (MOD(IFN,2) == 1) CSPN = -CSPN ! --------------------------------------------------------------- ! CS=COEFF OF THE J function TO GET THE I function. I(FNU,Z) IS ! COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE ! FIRST QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE ! COMPUTED BY CONJUGATION SINCE THE I function IS REAL ON THE ! POSITIVE REAL AXIS ! --------------------------------------------------------------- CS = CMPLX(CAR,-SAR)*CSGN IN = MOD(IFN,4) + 1 C2 = CIP(IN) CS = CS*CONJG(C2) ASC = BRY(1) KK = N KDFLG = 1 IB = IB - 1 IC = IB - 1 IUF = 0 DO 220 K = 1, N ! ------------------------------------------------------------ ! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K ! function ABOVE ! ------------------------------------------------------------ FN = FNU + KK - 1 if (N > 2) then if ((KK == N) .and. (IB < N)) then goto 160 else if ((KK /= IB) .and. (KK /= IC)) then CALL DEUS17(ZN,FN,0,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD, & BSUMD,ELIM) goto 160 endif endif PHID = PHI(J) ARGD = ARG(J) ZETA1D = ZETA1(J) ZETA2D = ZETA2(J) ASUMD = ASUM(J) BSUMD = BSUM(J) J = 3 - J 160 if (KODE == 1) then S1 = -ZETA1D + ZETA2D ELSE CFN = CMPLX(FN,0.0E0) S1 = -ZETA1D + CFN*(CFN/(ZB+ZETA2D)) endif ! ------------------------------------------------------------ ! TEST FOR UNDERFLOW AND OVERFLOW ! ------------------------------------------------------------ RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (KDFLG == 1) IFLAG = 2 if (ABS(RS1) >= ALIM) then ! ------------------------------------------------------ ! REFINE TEST AND SCALE ! ------------------------------------------------------ APHI = ABS(PHID) AARG = ABS(ARGD) RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC if (ABS(RS1) > ELIM) then goto 180 ELSE if (KDFLG == 1) IFLAG = 1 if (RS1 >= 0.0E0) then if (KDFLG == 1) IFLAG = 3 endif endif endif IDUM = 1 ! S17DGE assumed not to fail, therefore IDUM set to one. CALL S17DGE('F',ARGD,'S',AI,NAI,IDUM) IDUM = 1 CALL S17DGE('D',ARGD,'S',DAI,NDAI,IDUM) S2 = CS*PHID*(AI*ASUMD+DAI*BSUMD) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0) endif goto 200 endif 180 if (RS1 > 0.0E0) then goto 280 ELSE S2 = CZERO endif 200 if (YY <= 0.0E0) S2 = CONJG(S2) CY(KDFLG) = S2 C2 = S2 S2 = S2*CSR(IFLAG) ! ------------------------------------------------------------ ! ADD I AND K functionS, K SEQUENCE IN Y(I), I=1,N ! ------------------------------------------------------------ S1 = Y(KK) if (KODE /= 1) then CALL DGSS17(ZR,S1,S2,NW,ASC,ALIM,IUF) NZ = NZ + NW endif Y(KK) = S1*CSPN + S2 KK = KK - 1 CSPN = -CSPN CS = -CS*CI if (C2 == CZERO) then KDFLG = 1 else if (KDFLG == 2) then goto 240 ELSE KDFLG = 2 endif 220 continue K = N 240 IL = N - K if (IL /= 0) then ! ------------------------------------------------------------ ! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE ! K functionS, SCALING THE I SEQUENCE DURING RECURRENCE TO ! KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT ! EXTREMES. ! ------------------------------------------------------------ S1 = CY(1) S2 = CY(2) CS = CSR(IFLAG) ASCLE = BRY(IFLAG) FN = INU + IL DO 260 I = 1, IL C2 = S2 S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 S1 = C2 FN = FN - 1.0E0 C2 = S2*CS CK = C2 C1 = Y(KK) if (KODE /= 1) then CALL DGSS17(ZR,C1,C2,NW,ASC,ALIM,IUF) NZ = NZ + NW endif Y(KK) = C1*CSPN + C2 KK = KK - 1 CSPN = -CSPN if (IFLAG < 3) then C2R = REAL(CK) C2I = AIMAG(CK) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CS S2 = CK S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) CS = CSR(IFLAG) endif endif 260 continue endif return endif 280 NZ = -1 return END subroutine DCZS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-786 (DEC 1989). ! ! Original name: CUNK1 ! ! DCZS18 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE ! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE ! UNIFORM ASYMPTOTIC EXPANSION. ! MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. ! NZ=-1 MEANS AN OVERFLOW WILL OCCUR ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CFN, CK, CONE, CRSC, CS, CSCL, CSGN, & CSPN, CZERO, PHID, RZ, S1, S2, SUMD, ZETA1D, & ZETA2D, ZR REAL ANG, APHI, ASC, ASCLE, C2I, C2M, C2R, CPN, FMR, & FN, FNF, PI, RS1, SGN, SPN, X INTEGER I, IB, IC, IFLAG, IFN, IL, INITD, INU, IPARD, & IUF, J, K, KDFLG, KFLAG, KK, M, NW ! .. Local Arrays .. COMPLEX CSR(3), CSS(3), CWRK(16,3), CY(2), PHI(2), & SUM(2), ZETA1(2), ZETA2(2) REAL BRY(3) INTEGER INIT(2) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEWS17, DGSS17, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, LOG, MAX, MOD, & REAL, SIGN, SIN ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ DATA PI/3.14159265358979324E0/ ! .. Executable Statements .. ! KDFLG = 1 NZ = 0 ! ------------------------------------------------------------------ ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN ! THE UNDERFLOW LIMIT ! ------------------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() X = REAL(Z) ZR = Z if (X < 0.0E0) ZR = -Z J = 2 DO 40 I = 1, N ! --------------------------------------------------------------- ! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J ! --------------------------------------------------------------- J = 3 - J FN = FNU + I - 1 INIT(J) = 0 CALL DEWS17(ZR,FN,2,0,TOL,INIT(J),PHI(J),ZETA1(J),ZETA2(J), & SUM(J),CWRK(1,J),ELIM) if (KODE == 1) then S1 = ZETA1(J) - ZETA2(J) ELSE CFN = CMPLX(FN,0.0E0) S1 = ZETA1(J) - CFN*(CFN/(ZR+ZETA2(J))) endif ! --------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW ! --------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (KDFLG == 1) KFLAG = 2 if (ABS(RS1) >= ALIM) then ! --------------------------------------------------------- ! REFINE TEST AND SCALE ! --------------------------------------------------------- APHI = ABS(PHI(J)) RS1 = RS1 + LOG(APHI) if (ABS(RS1) > ELIM) then goto 20 ELSE if (KDFLG == 1) KFLAG = 1 if (RS1 >= 0.0E0) then if (KDFLG == 1) KFLAG = 3 endif endif endif ! ------------------------------------------------------------ ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES ! ------------------------------------------------------------ S2 = PHI(J)*SUM(J) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(KFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (KFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) goto 20 endif CY(KDFLG) = S2 Y(I) = S2*CSR(KFLAG) if (KDFLG == 2) then goto 60 ELSE KDFLG = 2 goto 40 endif endif 20 if (RS1 > 0.0E0) then goto 280 ! ------------------------------------------------------------ ! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW ! ------------------------------------------------------------ else if (X < 0.0E0) then goto 280 ELSE KDFLG = 1 Y(I) = CZERO NZ = NZ + 1 if (I /= 1) then if (Y(I-1) /= CZERO) then Y(I-1) = CZERO NZ = NZ + 1 endif endif endif 40 continue I = N 60 RZ = CMPLX(2.0E0,0.0E0)/ZR CK = CMPLX(FN,0.0E0)*RZ IB = I + 1 if (N >= IB) then ! --------------------------------------------------------------- ! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ! ZERO ON UNDERFLOW ! --------------------------------------------------------------- FN = FNU + N - 1 IPARD = 1 if (MR /= 0) IPARD = 0 INITD = 0 CALL DEWS17(ZR,FN,2,IPARD,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, & CWRK(1,3),ELIM) if (KODE == 1) then S1 = ZETA1D - ZETA2D ELSE CFN = CMPLX(FN,0.0E0) S1 = ZETA1D - CFN*(CFN/(ZR+ZETA2D)) endif RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (ABS(RS1) >= ALIM) then ! --------------------------------------------------------- ! REFINE ESTIMATE AND TEST ! --------------------------------------------------------- APHI = ABS(PHID) RS1 = RS1 + LOG(APHI) if (ABS(RS1) >= ELIM) goto 100 endif ! ------------------------------------------------------------ ! RECUR FORWARD FOR REMAINDER OF THE SEQUENCE ! ------------------------------------------------------------ S1 = CY(1) S2 = CY(2) C1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 80 I = IB, N C2 = S2 S2 = CK*S2 + S1 S1 = C2 CK = CK + RZ C2 = S2*C1 Y(I) = C2 if (KFLAG < 3) then C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) C1 = CSR(KFLAG) endif endif 80 continue goto 140 endif 100 if (RS1 > 0.0E0) then goto 280 ! ------------------------------------------------------------ ! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW ! ------------------------------------------------------------ else if (X < 0.0E0) then goto 280 ELSE NZ = N DO 120 I = 1, N Y(I) = CZERO 120 continue return endif endif 140 if (MR == 0) then return ELSE ! --------------------------------------------------------------- ! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0 ! --------------------------------------------------------------- NZ = 0 FMR = MR SGN = -SIGN(PI,FMR) ! --------------------------------------------------------------- ! CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. ! --------------------------------------------------------------- CSGN = CMPLX(0.0E0,SGN) INU = INT(FNU) FNF = FNU - INU IFN = INU + N - 1 ANG = FNF*SGN CPN = COS(ANG) SPN = SIN(ANG) CSPN = CMPLX(CPN,SPN) if (MOD(IFN,2) == 1) CSPN = -CSPN ASC = BRY(1) KK = N IUF = 0 KDFLG = 1 IB = IB - 1 IC = IB - 1 DO 220 K = 1, N FN = FNU + KK - 1 ! ------------------------------------------------------------ ! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K ! function ABOVE ! ------------------------------------------------------------ M = 3 if (N > 2) then if ((KK == N) .and. (IB < N)) then goto 160 else if ((KK /= IB) .and. (KK /= IC)) then INITD = 0 goto 160 endif endif INITD = INIT(J) PHID = PHI(J) ZETA1D = ZETA1(J) ZETA2D = ZETA2(J) SUMD = SUM(J) M = J J = 3 - J 160 CALL DEWS17(ZR,FN,1,0,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, & CWRK(1,M),ELIM) if (KODE == 1) then S1 = -ZETA1D + ZETA2D ELSE CFN = CMPLX(FN,0.0E0) S1 = -ZETA1D + CFN*(CFN/(ZR+ZETA2D)) endif ! ------------------------------------------------------------ ! TEST FOR UNDERFLOW AND OVERFLOW ! ------------------------------------------------------------ RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then if (KDFLG == 1) IFLAG = 2 if (ABS(RS1) >= ALIM) then ! ------------------------------------------------------ ! REFINE TEST AND SCALE ! ------------------------------------------------------ APHI = ABS(PHID) RS1 = RS1 + LOG(APHI) if (ABS(RS1) > ELIM) then goto 180 ELSE if (KDFLG == 1) IFLAG = 1 if (RS1 >= 0.0E0) then if (KDFLG == 1) IFLAG = 3 endif endif endif S2 = CSGN*PHID*SUMD C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0) endif goto 200 endif 180 if (RS1 > 0.0E0) then goto 280 ELSE S2 = CZERO endif 200 CY(KDFLG) = S2 C2 = S2 S2 = S2*CSR(IFLAG) ! ------------------------------------------------------------ ! ADD I AND K functionS, K SEQUENCE IN Y(I), I=1,N ! ------------------------------------------------------------ S1 = Y(KK) if (KODE /= 1) then CALL DGSS17(ZR,S1,S2,NW,ASC,ALIM,IUF) NZ = NZ + NW endif Y(KK) = S1*CSPN + S2 KK = KK - 1 CSPN = -CSPN if (C2 == CZERO) then KDFLG = 1 else if (KDFLG == 2) then goto 240 ELSE KDFLG = 2 endif 220 continue K = N 240 IL = N - K if (IL /= 0) then ! ------------------------------------------------------------ ! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE ! K functionS, SCALING THE I SEQUENCE DURING RECURRENCE TO ! KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT ! EXTREMES. ! ------------------------------------------------------------ S1 = CY(1) S2 = CY(2) CS = CSR(IFLAG) ASCLE = BRY(IFLAG) FN = INU + IL DO 260 I = 1, IL C2 = S2 S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 S1 = C2 FN = FN - 1.0E0 C2 = S2*CS CK = C2 C1 = Y(KK) if (KODE /= 1) then CALL DGSS17(ZR,C1,C2,NW,ASC,ALIM,IUF) NZ = NZ + NW endif Y(KK) = C1*CSPN + C2 KK = KK - 1 CSPN = -CSPN if (IFLAG < 3) then C2R = REAL(CK) C2I = AIMAG(CK) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CS S2 = CK S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) CS = CSR(IFLAG) endif endif 260 continue endif return endif 280 NZ = -1 return END subroutine DERS17(Z,FNU,N,CY,TOL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-761 (DEC 1989). ! ! Original name: CRATI ! ! DERS17 COMPUTES RATIOS OF I BESSEL functionS BY BACKWARD ! RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD ! RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, ! MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, ! BESSEL functionS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, ! BY D. J. SOOKNE. ! ! .. Scalar Arguments .. COMPLEX Z REAL FNU, TOL INTEGER N ! .. Array Arguments .. COMPLEX CY(N) ! .. Local Scalars .. COMPLEX CDFNU, CONE, CZERO, P1, P2, PT, RZ, T1 REAL AK, AMAGZ, AP1, AP2, ARG, AZ, DFNU, FDNU, FLAM, & FNUP, RAP1, RHO, TEST, TEST1 INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, INT, MAX, MIN, REAL, SQRT ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! AZ = ABS(Z) INU = INT(FNU) IDNU = INU + N - 1 FDNU = IDNU MAGZ = INT(AZ) AMAGZ = MAGZ + 1 FNUP = MAX(AMAGZ,FDNU) ID = IDNU - MAGZ - 1 ITIME = 1 K = 1 RZ = (CONE+CONE)/Z T1 = CMPLX(FNUP,0.0E0)*RZ P2 = -T1 P1 = CONE T1 = T1 + RZ if (ID > 0) ID = 0 AP2 = ABS(P2) AP1 = ABS(P1) ! ------------------------------------------------------------------ ! THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNX ! GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT ! P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR ! PREMATURELY. ! ------------------------------------------------------------------ ARG = (AP2+AP2)/(AP1*TOL) TEST1 = SQRT(ARG) TEST = TEST1 RAP1 = 1.0E0/AP1 P1 = P1*CMPLX(RAP1,0.0E0) P2 = P2*CMPLX(RAP1,0.0E0) AP2 = AP2*RAP1 20 continue K = K + 1 AP1 = AP2 PT = P2 P2 = P1 - T1*P2 P1 = PT T1 = T1 + RZ AP2 = ABS(P2) if (AP1 <= TEST) then goto 20 else if (ITIME /= 2) then AK = ABS(T1)*0.5E0 FLAM = AK + SQRT(AK*AK-1.0E0) RHO = MIN(AP2/AP1,FLAM) TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0E0)) ITIME = 2 goto 20 endif KK = K + 1 - ID AK = KK DFNU = FNU + N - 1 CDFNU = CMPLX(DFNU,0.0E0) T1 = CMPLX(AK,0.0E0) P1 = CMPLX(1.0E0/AP2,0.0E0) P2 = CZERO DO 40 I = 1, KK PT = P1 P1 = RZ*(CDFNU+T1)*P1 + P2 P2 = PT T1 = T1 - CONE 40 continue if (REAL(P1) == 0.0E0 .and. AIMAG(P1) == 0.0E0) P1 = CMPLX(TOL, & TOL) CY(N) = P2/P1 if (N /= 1) then K = N - 1 AK = K T1 = CMPLX(AK,0.0E0) CDFNU = CMPLX(FNU,0.0E0)*RZ DO 60 I = 2, N PT = CDFNU + T1*RZ + CY(K+1) if (REAL(PT) == 0.0E0 .and. AIMAG(PT) == 0.0E0) & PT = CMPLX(TOL,TOL) CY(K) = CONE/PT T1 = T1 - CONE K = K - 1 60 continue endif return END subroutine DESS17(ZR,FNU,KODE,N,Y,NZ,CW,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-762 (DEC 1989). ! ! Original name: CWRSK ! ! DESS17 COMPUTES THE I BESSEL function FOR RE(Z) >= 0.0 BY ! NORMALIZING THE I function RATIOS FROM DERS17 BY THE WRONSKIAN ! ! .. Scalar Arguments .. COMPLEX ZR REAL ALIM, ELIM, FNU, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX CW(2), Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CINU, CSCL, CT, RCT, ST REAL ACT, ACW, ASCLE, S1, S2, YY INTEGER I, NW ! .. External functions .. REAL X02AME EXTERNAL X02AME ! .. External subroutines .. EXTERNAL DERS17, DGXS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, SIN ! .. Executable Statements .. ! ------------------------------------------------------------------ ! I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS ! Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM DERS17 NORMALIZED BY THE ! WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM DGXS17. ! ------------------------------------------------------------------ NZ = 0 CALL DGXS17(ZR,FNU,KODE,2,CW,NW,TOL,ELIM,ALIM) if (NW /= 0) then NZ = -1 if (NW == (-2)) NZ = -2 if (NW == (-3)) NZ = -3 ELSE CALL DERS17(ZR,FNU,N,Y,TOL) ! --------------------------------------------------------------- ! RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), ! R(FNU+J-1,Z)=Y(J), J=1,...,N ! --------------------------------------------------------------- CINU = CMPLX(1.0E0,0.0E0) if (KODE /= 1) then YY = AIMAG(ZR) S1 = COS(YY) S2 = SIN(YY) CINU = CMPLX(S1,S2) endif ! --------------------------------------------------------------- ! ON LOW EXPONENT MACHINES THE K functionS CAN BE CLOSE TO BOTH ! THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE ! SCALED TO PREVENT OVER OR UNDERFLOW. DEVS17 HAS DETERMINED THAT ! THE RESULT IS ON SCALE. ! --------------------------------------------------------------- ACW = ABS(CW(2)) ASCLE = (1.0E+3*X02AME())/TOL CSCL = CMPLX(1.0E0,0.0E0) if (ACW > ASCLE) then ASCLE = 1.0E0/ASCLE if (ACW >= ASCLE) CSCL = CMPLX(TOL,0.0E0) ELSE CSCL = CMPLX(1.0E0/TOL,0.0E0) endif C1 = CW(1)*CSCL C2 = CW(2)*CSCL ST = Y(1) ! --------------------------------------------------------------- ! CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0E0/CABS(CT) PREVENTS ! UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) ! --------------------------------------------------------------- CT = ZR*(C2+ST*C1) ACT = ABS(CT) RCT = CMPLX(1.0E0/ACT,0.0E0) CT = CONJG(CT)*RCT CINU = CINU*RCT*CT Y(1) = CINU*CSCL if (N /= 1) then DO 20 I = 2, N CINU = ST*CINU ST = Y(I) Y(I) = CINU*CSCL 20 continue endif endif return END subroutine DETS17(Z,FNU,KODE,N,Y,NZ,NLAST,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-763 (DEC 1989). ! ! Original name: CUNI2 ! ! DETS17 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF ! UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I ! OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. ! ! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC ! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. ! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER ! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL. ! Y(I)=CZERO FOR I=NLAST+1,N ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, TOL INTEGER KODE, N, NLAST, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX AI, ARG, ASUM, BSUM, C1, C2, CFN, CI, CID, CONE, & CRSC, CSCL, CZERO, DAI, PHI, RZ, S1, S2, ZB, & ZETA1, ZETA2, ZN REAL AARG, AIC, ANG, APHI, ASCLE, AY, C2I, C2M, C2R, & CAR, FN, HPI, RS1, SAR, YY INTEGER I, IDUM, IFLAG, IN, INU, J, K, NAI, ND, NDAI, & NN, NUF, NW ! .. Local Arrays .. COMPLEX CIP(4), CSR(3), CSS(3), CY(2) REAL BRY(3) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEUS17, DEVS17, S17DGE, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, INT, LOG, & MAX, MIN, MOD, REAL, SIN ! .. Data statements .. DATA CZERO, CONE, CI/(0.0E0,0.0E0), (1.0E0,0.0E0), & (0.0E0,1.0E0)/ DATA CIP(1), CIP(2), CIP(3), CIP(4)/(1.0E0,0.0E0), & (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0)/ DATA HPI, AIC/1.57079632679489662E+00, & 1.265512123484645396E+00/ ! .. Executable Statements .. ! NZ = 0 ND = N NLAST = 0 ! ------------------------------------------------------------------ ! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- ! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, ! EXP(ALIM)=EXP(ELIM)*TOL ! ------------------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL YY = AIMAG(Z) ! ------------------------------------------------------------------ ! ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI ! ------------------------------------------------------------------ ZN = -Z*CI ZB = Z CID = -CI INU = INT(FNU) ANG = HPI*(FNU-INU) CAR = COS(ANG) SAR = SIN(ANG) C2 = CMPLX(CAR,SAR) IN = INU + N - 1 IN = MOD(IN,4) C2 = C2*CIP(IN+1) if (YY <= 0.0E0) then ZN = CONJG(-ZN) ZB = CONJG(ZB) CID = -CID C2 = CONJG(C2) endif ! ------------------------------------------------------------------ ! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER ! ------------------------------------------------------------------ FN = MAX(FNU,1.0E0) CALL DEUS17(ZN,FN,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM) if (KODE == 1) then S1 = -ZETA1 + ZETA2 ELSE CFN = CMPLX(FNU,0.0E0) S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) endif RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then 20 continue NN = MIN(2,ND) DO 40 I = 1, NN FN = FNU + ND - I CALL DEUS17(ZN,FN,0,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM) if (KODE == 1) then S1 = -ZETA1 + ZETA2 ELSE CFN = CMPLX(FN,0.0E0) AY = ABS(YY) S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + CMPLX(0.0E0,AY) endif ! ------------------------------------------------------------ ! TEST FOR UNDERFLOW AND OVERFLOW ! ------------------------------------------------------------ RS1 = REAL(S1) if (ABS(RS1) > ELIM) then goto 60 ELSE if (I == 1) IFLAG = 2 if (ABS(RS1) >= ALIM) then ! ------------------------------------------------------ ! REFINE TEST AND SCALE ! ------------------------------------------------------ ! ------------------------------------------------------ APHI = ABS(PHI) AARG = ABS(ARG) RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC if (ABS(RS1) > ELIM) then goto 60 ELSE if (I == 1) IFLAG = 1 if (RS1 >= 0.0E0) then if (I == 1) IFLAG = 3 endif endif endif ! --------------------------------------------------------- ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES ! --------------------------------------------------------- IDUM = 1 ! S17DGE assumed not to fail, therefore IDUM set to one. CALL S17DGE('F',ARG,'S',AI,NAI,IDUM) IDUM = 1 CALL S17DGE('D',ARG,'S',DAI,NDAI,IDUM) S2 = PHI*(AI*ASUM+DAI*BSUM) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) goto 60 endif if (YY <= 0.0E0) S2 = CONJG(S2) J = ND - I + 1 S2 = S2*C2 CY(I) = S2 Y(J) = S2*CSR(IFLAG) C2 = C2*CID endif 40 continue goto 80 60 if (RS1 > 0.0E0) then goto 160 ELSE ! ------------------------------------------------------------ ! SET UNDERFLOW AND UPDATE PARAMETERS ! ------------------------------------------------------------ Y(ND) = CZERO NZ = NZ + 1 ND = ND - 1 if (ND == 0) then return ELSE CALL DEVS17(Z,FNU,KODE,1,ND,Y,NUF,TOL,ELIM,ALIM) if (NUF < 0) then goto 160 ELSE ND = ND - NUF NZ = NZ + NUF if (ND == 0) then return ELSE FN = FNU + ND - 1 if (FN < FNUL) then goto 120 ELSE ! FN = AIMAG(CID) ! J = NUF + 1 ! K = MOD(J,4) + 1 ! S1 = CIP(K) ! if (FN < 0.0E0) S1 = CONJG(S1) ! C2 = C2*S1 ! The above 6 lines were replaced by the 5 below ! to fix a bug discovered during implementation ! on a Multics machine, whereby some results ! were returned wrongly scaled by sqrt(-1.0). MWP. C2 = CMPLX(CAR,SAR) IN = INU + ND - 1 IN = MOD(IN,4) + 1 C2 = C2*CIP(IN) if (YY <= 0.0E0) C2 = CONJG(C2) goto 20 endif endif endif endif endif 80 if (ND > 2) then RZ = CMPLX(2.0E0,0.0E0)/Z BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() S1 = CY(1) S2 = CY(2) C1 = CSR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = K DO 100 I = 3, ND C2 = S2 S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 S1 = C2 C2 = S2*C1 Y(K) = C2 K = K - 1 FN = FN - 1.0E0 if (IFLAG < 3) then C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) C1 = CSR(IFLAG) endif endif 100 continue endif return 120 NLAST = ND return else if (RS1 <= 0.0E0) then NZ = N DO 140 I = 1, N Y(I) = CZERO 140 continue return endif 160 NZ = -1 return END subroutine DEUS17(Z,FNU,IPMTR,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM, & ELIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-764 (DEC 1989). ! ! Original name: CUNHJ ! ! REFERENCES ! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ AND I.A. ! STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. ! ! ASYMPTOTICS AND SPECIAL functionS BY F.W.J. OLVER, ACADEMIC ! PRESS, N.Y., 1974, PAGE 420 ! ! ABSTRACT ! DEUS17 COMPUTES PARAMETERS FOR BESSEL functionS C(FNU,Z) = ! J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU ! BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION ! ! C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) ! ! FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS ! AN AIRY function AND DAIRY IS ITS DERIVATIVE. ! ! (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, ! ! ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING ! PURPOSES IN AIRY functionS FROM S17DGE OR S17DHE. ! ! MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND ! MUST BE SPECIFIED. IPMTR=0 returnS ALL PARAMETERS. IPMTR= ! 1 COMPUTES ALL EXCEPT ASUM AND BSUM. ! ! .. Scalar Arguments .. COMPLEX ARG, ASUM, BSUM, PHI, Z, ZETA1, ZETA2 REAL ELIM, FNU, TOL INTEGER IPMTR ! .. Local Scalars .. COMPLEX CFNU, CONE, CZERO, PRZTH, PTFN, RFN13, RTZTA, & RZTH, SUMA, SUMB, T2, TFN, W, W2, ZA, ZB, ZC, & ZETA, ZTH REAL ANG, ASUMI, ASUMR, ATOL, AW2, AZTH, BSUMI, & BSUMR, BTOL, EX1, EX2, FN13, FN23, HPI, PI, PP, & RFNU, RFNU2, TEST, THPI, TSTI, TSTR, WI, WR, & ZCI, ZCR, ZETAI, ZETAR, ZTHI, ZTHR INTEGER IAS, IBS, IS, J, JR, JU, K, KMAX, KP1, KS, L, & L1, L2, LR, LRP1, M ! .. Local Arrays .. COMPLEX CR(14), DR(14), P(30), UP(14) REAL ALFA(180), AP(30), AR(14), BETA(210), BR(14), & C(105), GAMA(30) ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, ATAN, CMPLX, COS, EXP, LOG, REAL, & SIN, SQRT ! .. Data statements .. DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), & AR(8), AR(9), AR(10), AR(11), AR(12), AR(13), & AR(14)/1.00000000000000000E+00, & 1.04166666666666667E-01, & 8.35503472222222222E-02, & 1.28226574556327160E-01, & 2.91849026464140464E-01, & 8.81627267443757652E-01, & 3.32140828186276754E+00, & 1.49957629868625547E+01, & 7.89230130115865181E+01, & 4.74451538868264323E+02, & 3.20749009089066193E+03, & 2.40865496408740049E+04, & 1.98923119169509794E+05, & 1.79190200777534383E+06/ DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), & BR(8), BR(9), BR(10), BR(11), BR(12), BR(13), & BR(14)/1.00000000000000000E+00, & -1.45833333333333333E-01, & -9.87413194444444444E-02, & -1.43312053915895062E-01, & -3.17227202678413548E-01, & -9.42429147957120249E-01, & -3.51120304082635426E+00, & -1.57272636203680451E+01, & -8.22814390971859444E+01, & -4.92355370523670524E+02, & -3.31621856854797251E+03, & -2.48276742452085896E+04, & -2.04526587315129788E+05, & -1.83844491706820990E+06/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), & C(9), C(10), C(11), C(12), C(13), C(14), C(15), & C(16)/1.00000000000000000E+00, & -2.08333333333333333E-01, & 1.25000000000000000E-01, & 3.34201388888888889E-01, & -4.01041666666666667E-01, & 7.03125000000000000E-02, & -1.02581259645061728E+00, & 1.84646267361111111E+00, & -8.91210937500000000E-01, & 7.32421875000000000E-02, & 4.66958442342624743E+00, & -1.12070026162229938E+01, & 8.78912353515625000E+00, & -2.36408691406250000E+00, & 1.12152099609375000E-01, & -2.82120725582002449E+01/ DATA C(17), C(18), C(19), C(20), C(21), C(22), C(23), & C(24)/8.46362176746007346E+01, & -9.18182415432400174E+01, & 4.25349987453884549E+01, & -7.36879435947963170E+00, & 2.27108001708984375E-01, & 2.12570130039217123E+02, & -7.65252468141181642E+02, & 1.05999045252799988E+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), & C(32), C(33), C(34), C(35), C(36), C(37), C(38), & C(39), C(40)/-6.99579627376132541E+02, & 2.18190511744211590E+02, & -2.64914304869515555E+01, & 5.72501420974731445E-01, & -1.91945766231840700E+03, & 8.06172218173730938E+03, & -1.35865500064341374E+04, & 1.16553933368645332E+04, & -5.30564697861340311E+03, & 1.20090291321635246E+03, & -1.08090919788394656E+02, & 1.72772750258445740E+00, & 2.02042913309661486E+04, & -9.69805983886375135E+04, & 1.92547001232531532E+05, & -2.03400177280415534E+05/ DATA C(41), C(42), C(43), C(44), C(45), C(46), C(47), & C(48)/1.22200464983017460E+05, & -4.11926549688975513E+04, & 7.10951430248936372E+03, & -4.93915304773088012E+02, & 6.07404200127348304E+00, & -2.42919187900551333E+05, & 1.31176361466297720E+06, & -2.99801591853810675E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), & C(56), C(57), C(58), C(59), C(60), C(61), C(62), & C(63), C(64)/3.76327129765640400E+06, & -2.81356322658653411E+06, & 1.26836527332162478E+06, & -3.31645172484563578E+05, & 4.52187689813627263E+04, & -2.49983048181120962E+03, & 2.43805296995560639E+01, & 3.28446985307203782E+06, & -1.97068191184322269E+07, & 5.09526024926646422E+07, & -7.41051482115326577E+07, & 6.63445122747290267E+07, & -3.75671766607633513E+07, & 1.32887671664218183E+07, & -2.78561812808645469E+06, & 3.08186404612662398E+05/ DATA C(65), C(66), C(67), C(68), C(69), C(70), C(71), & C(72)/-1.38860897537170405E+04, & 1.10017140269246738E+02, & -4.93292536645099620E+07, & 3.25573074185765749E+08, & -9.39462359681578403E+08, & 1.55359689957058006E+09, & -1.62108055210833708E+09, & 1.10684281682301447E+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), & C(80), C(81), C(82), C(83), C(84), C(85), C(86), & C(87), C(88)/-4.95889784275030309E+08, & 1.42062907797533095E+08, & -2.44740627257387285E+07, & 2.24376817792244943E+06, & -8.40054336030240853E+04, & 5.51335896122020586E+02, & 8.14789096118312115E+08, & -5.86648149205184723E+09, & 1.86882075092958249E+10, & -3.46320433881587779E+10, & 4.12801855797539740E+10, & -3.30265997498007231E+10, & 1.79542137311556001E+10, & -6.56329379261928433E+09, & 1.55927986487925751E+09, & -2.25105661889415278E+08/ DATA C(89), C(90), C(91), C(92), C(93), C(94), C(95), & C(96)/1.73951075539781645E+07, & -5.49842327572288687E+05, & 3.03809051092238427E+03, & -1.46792612476956167E+10, & 1.14498237732025810E+11, & -3.99096175224466498E+11, & 8.19218669548577329E+11, & -1.09837515608122331E+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), & C(103), C(104), C(105)/1.00815810686538209E+12, & -6.45364869245376503E+11, & 2.87900649906150589E+11, & -8.78670721780232657E+10, & 1.76347306068349694E+10, & -2.16716498322379509E+09, & 1.43157876718888981E+08, & -3.87183344257261262E+06, & 1.82577554742931747E+04/ DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), & ALFA(6), ALFA(7), ALFA(8), ALFA(9), ALFA(10), & ALFA(11), ALFA(12), ALFA(13), & ALFA(14)/-4.44444444444444444E-03, & -9.22077922077922078E-04, & -8.84892884892884893E-05, & 1.65927687832449737E-04, & 2.46691372741792910E-04, & 2.65995589346254780E-04, & 2.61824297061500945E-04, & 2.48730437344655609E-04, & 2.32721040083232098E-04, & 2.16362485712365082E-04, & 2.00738858762752355E-04, & 1.86267636637545172E-04, & 1.73060775917876493E-04, & 1.61091705929015752E-04/ DATA ALFA(15), ALFA(16), ALFA(17), ALFA(18), & ALFA(19), ALFA(20), ALFA(21), & ALFA(22)/1.50274774160908134E-04, & 1.40503497391269794E-04, & 1.31668816545922806E-04, & 1.23667445598253261E-04, & 1.16405271474737902E-04, & 1.09798298372713369E-04, & 1.03772410422992823E-04, & 9.82626078369363448E-05/ DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), & ALFA(27), ALFA(28), ALFA(29), ALFA(30), & ALFA(31), ALFA(32), ALFA(33), ALFA(34), & ALFA(35), ALFA(36)/9.32120517249503256E-05, & 8.85710852478711718E-05, & 8.42963105715700223E-05, & 8.03497548407791151E-05, & 7.66981345359207388E-05, & 7.33122157481777809E-05, & 7.01662625163141333E-05, & 6.72375633790160292E-05, & 6.93735541354588974E-04, & 2.32241745182921654E-04, & -1.41986273556691197E-05, & -1.16444931672048640E-04, & -1.50803558053048762E-04, & -1.55121924918096223E-04/ DATA ALFA(37), ALFA(38), ALFA(39), ALFA(40), & ALFA(41), ALFA(42), ALFA(43), & ALFA(44)/-1.46809756646465549E-04, & -1.33815503867491367E-04, & -1.19744975684254051E-04, & -1.06184319207974020E-04, & -9.37699549891194492E-05, & -8.26923045588193274E-05, & -7.29374348155221211E-05, & -6.44042357721016283E-05/ DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), & ALFA(49), ALFA(50), ALFA(51), ALFA(52), & ALFA(53), ALFA(54), ALFA(55), ALFA(56), & ALFA(57), ALFA(58)/-5.69611566009369048E-05, & -5.04731044303561628E-05, & -4.48134868008882786E-05, & -3.98688727717598864E-05, & -3.55400532972042498E-05, & -3.17414256609022480E-05, & -2.83996793904174811E-05, & -2.54522720634870566E-05, & -2.28459297164724555E-05, & -2.05352753106480604E-05, & -1.84816217627666085E-05, & -1.66519330021393806E-05, & -1.50179412980119482E-05, & -1.35554031379040526E-05/ DATA ALFA(59), ALFA(60), ALFA(61), ALFA(62), & ALFA(63), ALFA(64), ALFA(65), & ALFA(66)/-1.22434746473858131E-05, & -1.10641884811308169E-05, & -3.54211971457743841E-04, & -1.56161263945159416E-04, & 3.04465503594936410E-05, & 1.30198655773242693E-04, & 1.67471106699712269E-04, & 1.70222587683592569E-04/ DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), & ALFA(71), ALFA(72), ALFA(73), ALFA(74), & ALFA(75), ALFA(76), ALFA(77), ALFA(78), & ALFA(79), ALFA(80)/1.56501427608594704E-04, & 1.36339170977445120E-04, & 1.14886692029825128E-04, & 9.45869093034688111E-05, & 7.64498419250898258E-05, & 6.07570334965197354E-05, & 4.74394299290508799E-05, & 3.62757512005344297E-05, & 2.69939714979224901E-05, & 1.93210938247939253E-05, & 1.30056674793963203E-05, & 7.82620866744496661E-06, & 3.59257485819351583E-06, & 1.44040049814251817E-07/ DATA ALFA(81), ALFA(82), ALFA(83), ALFA(84), & ALFA(85), ALFA(86), ALFA(87), & ALFA(88)/-2.65396769697939116E-06, & -4.91346867098485910E-06, & -6.72739296091248287E-06, & -8.17269379678657923E-06, & -9.31304715093561232E-06, & -1.02011418798016441E-05, & -1.08805962510592880E-05, & -1.13875481509603555E-05/ DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), & ALFA(93), ALFA(94), ALFA(95), ALFA(96), & ALFA(97), ALFA(98), ALFA(99), ALFA(100), & ALFA(101), ALFA(102)/-1.17519675674556414E-05, & -1.19987364870944141E-05, & 3.78194199201772914E-04, & 2.02471952761816167E-04, & -6.37938506318862408E-05, & -2.38598230603005903E-04, & -3.10916256027361568E-04, & -3.13680115247576316E-04, & -2.78950273791323387E-04, & -2.28564082619141374E-04, & -1.75245280340846749E-04, & -1.25544063060690348E-04, & -8.22982872820208365E-05, & -4.62860730588116458E-05/ DATA ALFA(103), ALFA(104), ALFA(105), ALFA(106), & ALFA(107), ALFA(108), ALFA(109), & ALFA(110)/-1.72334302366962267E-05, & 5.60690482304602267E-06, & 2.31395443148286800E-05, & 3.62642745856793957E-05, & 4.58006124490188752E-05, & 5.24595294959114050E-05, & 5.68396208545815266E-05, & 5.94349820393104052E-05/ DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), & ALFA(115), ALFA(116), ALFA(117), ALFA(118), & ALFA(119), ALFA(120), ALFA(121), & ALFA(122)/6.06478527578421742E-05, & 6.08023907788436497E-05, & 6.01577894539460388E-05, & 5.89199657344698500E-05, & 5.72515823777593053E-05, & 5.52804375585852577E-05, & 5.31063773802880170E-05, & 5.08069302012325706E-05, & 4.84418647620094842E-05, & 4.60568581607475370E-05, & -6.91141397288294174E-04, & -4.29976633058871912E-04/ DATA ALFA(123), ALFA(124), ALFA(125), ALFA(126), & ALFA(127), ALFA(128), ALFA(129), & ALFA(130)/1.83067735980039018E-04, & 6.60088147542014144E-04, & 8.75964969951185931E-04, & 8.77335235958235514E-04, & 7.49369585378990637E-04, & 5.63832329756980918E-04, & 3.68059319971443156E-04, & 1.88464535514455599E-04/ DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), & ALFA(135), ALFA(136), ALFA(137), ALFA(138), & ALFA(139), ALFA(140), ALFA(141), & ALFA(142)/3.70663057664904149E-05, & -8.28520220232137023E-05, & -1.72751952869172998E-04, & -2.36314873605872983E-04, & -2.77966150694906658E-04, & -3.02079514155456919E-04, & -3.12594712643820127E-04, & -3.12872558758067163E-04, & -3.05678038466324377E-04, & -2.93226470614557331E-04, & -2.77255655582934777E-04, & -2.59103928467031709E-04/ DATA ALFA(143), ALFA(144), ALFA(145), ALFA(146), & ALFA(147), ALFA(148), ALFA(149), & ALFA(150)/-2.39784014396480342E-04, & -2.20048260045422848E-04, & -2.00443911094971498E-04, & -1.81358692210970687E-04, & -1.63057674478657464E-04, & -1.45712672175205844E-04, & -1.29425421983924587E-04, & -1.14245691942445952E-04/ DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), & ALFA(155), ALFA(156), ALFA(157), ALFA(158), & ALFA(159), ALFA(160), ALFA(161), & ALFA(162)/1.92821964248775885E-03, & 1.35592576302022234E-03, & -7.17858090421302995E-04, & -2.58084802575270346E-03, & -3.49271130826168475E-03, & -3.46986299340960628E-03, & -2.82285233351310182E-03, & -1.88103076404891354E-03, & -8.89531718383947600E-04, & 3.87912102631035228E-06, & 7.28688540119691412E-04, & 1.26566373053457758E-03/ DATA ALFA(163), ALFA(164), ALFA(165), ALFA(166), & ALFA(167), ALFA(168), ALFA(169), & ALFA(170)/1.62518158372674427E-03, & 1.83203153216373172E-03, & 1.91588388990527909E-03, & 1.90588846755546138E-03, & 1.82798982421825727E-03, & 1.70389506421121530E-03, & 1.55097127171097686E-03, & 1.38261421852276159E-03/ DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), & ALFA(175), ALFA(176), ALFA(177), ALFA(178), & ALFA(179), ALFA(180)/1.20881424230064774E-03, & 1.03676532638344962E-03, & 8.71437918068619115E-04, & 7.16080155297701002E-04, & 5.72637002558129372E-04, & 4.42089819465802277E-04, & 3.24724948503090564E-04, & 2.20342042730246599E-04, & 1.28412898401353882E-04, & 4.82005924552095464E-05/ DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), & BETA(6), BETA(7), BETA(8), BETA(9), BETA(10), & BETA(11), BETA(12), BETA(13), & BETA(14)/1.79988721413553309E-02, & 5.59964911064388073E-03, & 2.88501402231132779E-03, & 1.80096606761053941E-03, & 1.24753110589199202E-03, & 9.22878876572938311E-04, & 7.14430421727287357E-04, & 5.71787281789704872E-04, & 4.69431007606481533E-04, & 3.93232835462916638E-04, & 3.34818889318297664E-04, & 2.88952148495751517E-04, & 2.52211615549573284E-04, & 2.22280580798883327E-04/ DATA BETA(15), BETA(16), BETA(17), BETA(18), & BETA(19), BETA(20), BETA(21), & BETA(22)/1.97541838033062524E-04, & 1.76836855019718004E-04, & 1.59316899661821081E-04, & 1.44347930197333986E-04, & 1.31448068119965379E-04, & 1.20245444949302884E-04, & 1.10449144504599392E-04, & 1.01828770740567258E-04/ DATA BETA(23), BETA(24), BETA(25), BETA(26), & BETA(27), BETA(28), BETA(29), BETA(30), & BETA(31), BETA(32), BETA(33), BETA(34), & BETA(35), BETA(36)/9.41998224204237509E-05, & 8.74130545753834437E-05, & 8.13466262162801467E-05, & 7.59002269646219339E-05, & 7.09906300634153481E-05, & 6.65482874842468183E-05, & 6.25146958969275078E-05, & 5.88403394426251749E-05, & -1.49282953213429172E-03, & -8.78204709546389328E-04, & -5.02916549572034614E-04, & -2.94822138512746025E-04, & -1.75463996970782828E-04, & -1.04008550460816434E-04/ DATA BETA(37), BETA(38), BETA(39), BETA(40), & BETA(41), BETA(42), BETA(43), & BETA(44)/-5.96141953046457895E-05, & -3.12038929076098340E-05, & -1.26089735980230047E-05, & -2.42892608575730389E-07, & 8.05996165414273571E-06, & 1.36507009262147391E-05, & 1.73964125472926261E-05, & 1.98672978842133780E-05/ DATA BETA(45), BETA(46), BETA(47), BETA(48), & BETA(49), BETA(50), BETA(51), BETA(52), & BETA(53), BETA(54), BETA(55), BETA(56), & BETA(57), BETA(58)/2.14463263790822639E-05, & 2.23954659232456514E-05, & 2.28967783814712629E-05, & 2.30785389811177817E-05, & 2.30321976080909144E-05, & 2.28236073720348722E-05, & 2.25005881105292418E-05, & 2.20981015361991429E-05, & 2.16418427448103905E-05, & 2.11507649256220843E-05, & 2.06388749782170737E-05, & 2.01165241997081666E-05, & 1.95913450141179244E-05, & 1.90689367910436740E-05/ DATA BETA(59), BETA(60), BETA(61), BETA(62), & BETA(63), BETA(64), BETA(65), & BETA(66)/1.85533719641636667E-05, & 1.80475722259674218E-05, & 5.52213076721292790E-04, & 4.47932581552384646E-04, & 2.79520653992020589E-04, & 1.52468156198446602E-04, & 6.93271105657043598E-05, & 1.76258683069991397E-05/ DATA BETA(67), BETA(68), BETA(69), BETA(70), & BETA(71), BETA(72), BETA(73), BETA(74), & BETA(75), BETA(76), BETA(77), BETA(78), & BETA(79), BETA(80)/-1.35744996343269136E-05, & -3.17972413350427135E-05, & -4.18861861696693365E-05, & -4.69004889379141029E-05, & -4.87665447413787352E-05, & -4.87010031186735069E-05, & -4.74755620890086638E-05, & -4.55813058138628452E-05, & -4.33309644511266036E-05, & -4.09230193157750364E-05, & -3.84822638603221274E-05, & -3.60857167535410501E-05, & -3.37793306123367417E-05, & -3.15888560772109621E-05/ DATA BETA(81), BETA(82), BETA(83), BETA(84), & BETA(85), BETA(86), BETA(87), & BETA(88)/-2.95269561750807315E-05, & -2.75978914828335759E-05, & -2.58006174666883713E-05, & -2.41308356761280200E-05, & -2.25823509518346033E-05, & -2.11479656768912971E-05, & -1.98200638885294927E-05, & -1.85909870801065077E-05/ DATA BETA(89), BETA(90), BETA(91), BETA(92), & BETA(93), BETA(94), BETA(95), BETA(96), & BETA(97), BETA(98), BETA(99), BETA(100), & BETA(101), BETA(102)/-1.74532699844210224E-05, & -1.63997823854497997E-05, & -4.74617796559959808E-04, & -4.77864567147321487E-04, & -3.20390228067037603E-04, & -1.61105016119962282E-04, & -4.25778101285435204E-05, & 3.44571294294967503E-05, & 7.97092684075674924E-05, & 1.03138236708272200E-04, & 1.12466775262204158E-04, & 1.13103642108481389E-04, & 1.08651634848774268E-04, & 1.01437951597661973E-04/ DATA BETA(103), BETA(104), BETA(105), BETA(106), & BETA(107), BETA(108), BETA(109), & BETA(110)/9.29298396593363896E-05, & 8.40293133016089978E-05, & 7.52727991349134062E-05, & 6.69632521975730872E-05, & 5.92564547323194704E-05, & 5.22169308826975567E-05, & 4.58539485165360646E-05, & 4.01445513891486808E-05/ DATA BETA(111), BETA(112), BETA(113), BETA(114), & BETA(115), BETA(116), BETA(117), BETA(118), & BETA(119), BETA(120), BETA(121), & BETA(122)/3.50481730031328081E-05, & 3.05157995034346659E-05, & 2.64956119950516039E-05, & 2.29363633690998152E-05, & 1.97893056664021636E-05, & 1.70091984636412623E-05, & 1.45547428261524004E-05, & 1.23886640995878413E-05, & 1.04775876076583236E-05, & 8.79179954978479373E-06, & 7.36465810572578444E-04, & 8.72790805146193976E-04/ DATA BETA(123), BETA(124), BETA(125), BETA(126), & BETA(127), BETA(128), BETA(129), & BETA(130)/6.22614862573135066E-04, & 2.85998154194304147E-04, & 3.84737672879366102E-06, & -1.87906003636971558E-04, & -2.97603646594554535E-04, & -3.45998126832656348E-04, & -3.53382470916037712E-04, & -3.35715635775048757E-04/ DATA BETA(131), BETA(132), BETA(133), BETA(134), & BETA(135), BETA(136), BETA(137), BETA(138), & BETA(139), BETA(140), BETA(141), & BETA(142)/-3.04321124789039809E-04, & -2.66722723047612821E-04, & -2.27654214122819527E-04, & -1.89922611854562356E-04, & -1.55058918599093870E-04, & -1.23778240761873630E-04, & -9.62926147717644187E-05, & -7.25178327714425337E-05, & -5.22070028895633801E-05, & -3.50347750511900522E-05, & -2.06489761035551757E-05, & -8.70106096849767054E-06/ DATA BETA(143), BETA(144), BETA(145), BETA(146), & BETA(147), BETA(148), BETA(149), & BETA(150)/1.13698686675100290E-06, & 9.16426474122778849E-06, & 1.56477785428872620E-05, & 2.08223629482466847E-05, & 2.48923381004595156E-05, & 2.80340509574146325E-05, & 3.03987774629861915E-05, & 3.21156731406700616E-05/ DATA BETA(151), BETA(152), BETA(153), BETA(154), & BETA(155), BETA(156), BETA(157), BETA(158), & BETA(159), BETA(160), BETA(161), & BETA(162)/-1.80182191963885708E-03, & -2.43402962938042533E-03, & -1.83422663549856802E-03, & -7.62204596354009765E-04, & 2.39079475256927218E-04, & 9.49266117176881141E-04, & 1.34467449701540359E-03, & 1.48457495259449178E-03, & 1.44732339830617591E-03, & 1.30268261285657186E-03, & 1.10351597375642682E-03, & 8.86047440419791759E-04/ DATA BETA(163), BETA(164), BETA(165), BETA(166), & BETA(167), BETA(168), BETA(169), & BETA(170)/6.73073208165665473E-04, & 4.77603872856582378E-04, & 3.05991926358789362E-04, & 1.60315694594721630E-04, & 4.00749555270613286E-05, & -5.66607461635251611E-05, & -1.32506186772982638E-04, & -1.90296187989614057E-04/ DATA BETA(171), BETA(172), BETA(173), BETA(174), & BETA(175), BETA(176), BETA(177), BETA(178), & BETA(179), BETA(180), BETA(181), & BETA(182)/-2.32811450376937408E-04, & -2.62628811464668841E-04, & -2.82050469867598672E-04, & -2.93081563192861167E-04, & -2.97435962176316616E-04, & -2.96557334239348078E-04, & -2.91647363312090861E-04, & -2.83696203837734166E-04, & -2.73512317095673346E-04, & -2.61750155806768580E-04, & 6.38585891212050914E-03, & 9.62374215806377941E-03/ DATA BETA(183), BETA(184), BETA(185), BETA(186), & BETA(187), BETA(188), BETA(189), & BETA(190)/7.61878061207001043E-03, & 2.83219055545628054E-03, & -2.09841352012720090E-03, & -5.73826764216626498E-03, & -7.70804244495414620E-03, & -8.21011692264844401E-03, & -7.65824520346905413E-03, & -6.47209729391045177E-03/ DATA BETA(191), BETA(192), BETA(193), BETA(194), & BETA(195), BETA(196), BETA(197), BETA(198), & BETA(199), BETA(200), BETA(201), & BETA(202)/-4.99132412004966473E-03, & -3.45612289713133280E-03, & -2.01785580014170775E-03, & -7.59430686781961401E-04, & 2.84173631523859138E-04, & 1.10891667586337403E-03, & 1.72901493872728771E-03, & 2.16812590802684701E-03, & 2.45357710494539735E-03, & 2.61281821058334862E-03, & 2.67141039656276912E-03, & 2.65203073395980430E-03/ DATA BETA(203), BETA(204), BETA(205), BETA(206), & BETA(207), BETA(208), BETA(209), & BETA(210)/2.57411652877287315E-03, & 2.45389126236094427E-03, & 2.30460058071795494E-03, & 2.13684837686712662E-03, & 1.95896528478870911E-03, & 1.77737008679454412E-03, & 1.59690280765839059E-03, & 1.42111975664438546E-03/ DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), & GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), & GAMA(11), GAMA(12), GAMA(13), & GAMA(14)/6.29960524947436582E-01, & 2.51984209978974633E-01, & 1.54790300415655846E-01, & 1.10713062416159013E-01, & 8.57309395527394825E-02, & 6.97161316958684292E-02, & 5.86085671893713576E-02, & 5.04698873536310685E-02, & 4.42600580689154809E-02, & 3.93720661543509966E-02, & 3.54283195924455368E-02, & 3.21818857502098231E-02, & 2.94646240791157679E-02, & 2.71581677112934479E-02/ DATA GAMA(15), GAMA(16), GAMA(17), GAMA(18), & GAMA(19), GAMA(20), GAMA(21), & GAMA(22)/2.51768272973861779E-02, & 2.34570755306078891E-02, & 2.19508390134907203E-02, & 2.06210828235646240E-02, & 1.94388240897880846E-02, & 1.83810633800683158E-02, & 1.74293213231963172E-02, & 1.65685837786612353E-02/ DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), & GAMA(27), GAMA(28), GAMA(29), & GAMA(30)/1.57865285987918445E-02, & 1.50729501494095594E-02, & 1.44193250839954639E-02, & 1.38184805735341786E-02, & 1.32643378994276568E-02, & 1.27517121970498651E-02, & 1.22761545318762767E-02, & 1.18338262398482403E-02/ DATA EX1, EX2, HPI, PI, THPI/3.33333333333333333E-01, & 6.66666666666666667E-01, & 1.57079632679489662E+00, & 3.14159265358979324E+00, & 4.71238898038468986E+00/ DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! RFNU = 1.0E0/FNU TSTR = REAL(Z) TSTI = AIMAG(Z) TEST = FNU*EXP(-ELIM) if (ABS(TSTR) < TEST) TSTR = 0.0E0 if (ABS(TSTI) < TEST) TSTI = 0.0E0 if (TSTR == 0.0E0 .and. TSTI == 0.0E0) then ZETA1 = CMPLX(ELIM+ELIM+FNU,0.0E0) ZETA2 = CMPLX(FNU,0.0E0) PHI = CONE ARG = CONE return endif ZB = CMPLX(TSTR,TSTI)*CMPLX(RFNU,0.0E0) RFNU2 = RFNU*RFNU ! ------------------------------------------------------------------ ! COMPUTE IN THE FOURTH QUADRANT ! ------------------------------------------------------------------ FN13 = FNU**EX1 FN23 = FN13*FN13 RFN13 = CMPLX(1.0E0/FN13,0.0E0) W2 = CONE - ZB*ZB AW2 = ABS(W2) if (AW2 > 0.25E0) then ! --------------------------------------------------------------- ! CABS(W2)>0.25E0 ! --------------------------------------------------------------- W = SQRT(W2) WR = REAL(W) WI = AIMAG(W) if (WR < 0.0E0) WR = 0.0E0 if (WI < 0.0E0) WI = 0.0E0 W = CMPLX(WR,WI) ZA = (CONE+W)/ZB ZC = LOG(ZA) ZCR = REAL(ZC) ZCI = AIMAG(ZC) if (ZCI < 0.0E0) ZCI = 0.0E0 if (ZCI > HPI) ZCI = HPI if (ZCR < 0.0E0) ZCR = 0.0E0 ZC = CMPLX(ZCR,ZCI) ZTH = (ZC-W)*CMPLX(1.5E0,0.0E0) CFNU = CMPLX(FNU,0.0E0) ZETA1 = ZC*CFNU ZETA2 = W*CFNU AZTH = ABS(ZTH) ZTHR = REAL(ZTH) ZTHI = AIMAG(ZTH) ANG = THPI if (ZTHR < 0.0E0 .or. ZTHI >= 0.0E0) then ANG = HPI if (ZTHR /= 0.0E0) then ANG = ATAN(ZTHI/ZTHR) if (ZTHR < 0.0E0) ANG = ANG + PI endif endif PP = AZTH**EX2 ANG = ANG*EX2 ZETAR = PP*COS(ANG) ZETAI = PP*SIN(ANG) if (ZETAI < 0.0E0) ZETAI = 0.0E0 ZETA = CMPLX(ZETAR,ZETAI) ARG = ZETA*CMPLX(FN23,0.0E0) RTZTA = ZTH/ZETA ZA = RTZTA/W PHI = SQRT(ZA+ZA)*RFN13 if (IPMTR /= 1) then TFN = CMPLX(RFNU,0.0E0)/W RZTH = CMPLX(RFNU,0.0E0)/ZTH ZC = RZTH*CMPLX(AR(2),0.0E0) T2 = CONE/W2 UP(2) = (T2*CMPLX(C(2),0.0E0)+CMPLX(C(3),0.0E0))*TFN BSUM = UP(2) + ZC ASUM = CZERO if (RFNU >= TOL) then PRZTH = RZTH PTFN = TFN UP(1) = CONE PP = 1.0E0 BSUMR = REAL(BSUM) BSUMI = AIMAG(BSUM) BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) KS = 0 KP1 = 2 L = 3 IAS = 0 IBS = 0 DO 100 LR = 2, 12, 2 LRP1 = LR + 1 ! ------------------------------------------------------ ! COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE ! TERMS IN NEXT SUMA AND SUMB ! ------------------------------------------------------ DO 40 K = LR, LRP1 KS = KS + 1 KP1 = KP1 + 1 L = L + 1 ZA = CMPLX(C(L),0.0E0) DO 20 J = 2, KP1 L = L + 1 ZA = ZA*T2 + CMPLX(C(L),0.0E0) 20 continue PTFN = PTFN*TFN UP(KP1) = PTFN*ZA CR(KS) = PRZTH*CMPLX(BR(KS+1),0.0E0) PRZTH = PRZTH*RZTH DR(KS) = PRZTH*CMPLX(AR(KS+2),0.0E0) 40 continue PP = PP*RFNU2 if (IAS /= 1) then SUMA = UP(LRP1) JU = LRP1 DO 60 JR = 1, LR JU = JU - 1 SUMA = SUMA + CR(JR)*UP(JU) 60 continue ASUM = ASUM + SUMA ASUMR = REAL(ASUM) ASUMI = AIMAG(ASUM) TEST = ABS(ASUMR) + ABS(ASUMI) if (PP < TOL .and. TEST < TOL) IAS = 1 endif if (IBS /= 1) then SUMB = UP(LR+2) + UP(LRP1)*ZC JU = LRP1 DO 80 JR = 1, LR JU = JU - 1 SUMB = SUMB + DR(JR)*UP(JU) 80 continue BSUM = BSUM + SUMB BSUMR = REAL(BSUM) BSUMI = AIMAG(BSUM) TEST = ABS(BSUMR) + ABS(BSUMI) if (PP < BTOL .and. TEST < TOL) IBS = 1 endif if (IAS == 1 .and. IBS == 1) goto 120 100 continue endif 120 ASUM = ASUM + CONE BSUM = -BSUM*RFN13/RTZTA endif ELSE ! --------------------------------------------------------------- ! POWER SERIES FOR CABS(W2) <= 0.25E0 ! --------------------------------------------------------------- K = 1 P(1) = CONE SUMA = CMPLX(GAMA(1),0.0E0) AP(1) = 1.0E0 if (AW2 >= TOL) then DO 140 K = 2, 30 P(K) = P(K-1)*W2 SUMA = SUMA + P(K)*CMPLX(GAMA(K),0.0E0) AP(K) = AP(K-1)*AW2 if (AP(K) < TOL) goto 160 140 continue K = 30 endif 160 KMAX = K ZETA = W2*SUMA ARG = ZETA*CMPLX(FN23,0.0E0) ZA = SQRT(SUMA) ZETA2 = SQRT(W2)*CMPLX(FNU,0.0E0) ZETA1 = ZETA2*(CONE+ZETA*ZA*CMPLX(EX2,0.0E0)) ZA = ZA + ZA PHI = SQRT(ZA)*RFN13 if (IPMTR /= 1) then ! ------------------------------------------------------------ ! SUM SERIES FOR ASUM AND BSUM ! ------------------------------------------------------------ SUMB = CZERO DO 180 K = 1, KMAX SUMB = SUMB + P(K)*CMPLX(BETA(K),0.0E0) 180 continue ASUM = CZERO BSUM = SUMB L1 = 0 L2 = 30 BTOL = TOL*ABS(BSUM) ATOL = TOL PP = 1.0E0 IAS = 0 IBS = 0 if (RFNU2 >= TOL) then DO 280 IS = 2, 7 ATOL = ATOL/RFNU2 PP = PP*RFNU2 if (IAS /= 1) then SUMA = CZERO DO 200 K = 1, KMAX M = L1 + K SUMA = SUMA + P(K)*CMPLX(ALFA(M),0.0E0) if (AP(K) < ATOL) goto 220 200 continue 220 ASUM = ASUM + SUMA*CMPLX(PP,0.0E0) if (PP < TOL) IAS = 1 endif if (IBS /= 1) then SUMB = CZERO DO 240 K = 1, KMAX M = L2 + K SUMB = SUMB + P(K)*CMPLX(BETA(M),0.0E0) if (AP(K) < ATOL) goto 260 240 continue 260 BSUM = BSUM + SUMB*CMPLX(PP,0.0E0) if (PP < BTOL) IBS = 1 endif if (IAS == 1 .and. IBS == 1) then goto 300 ELSE L1 = L1 + 30 L2 = L2 + 30 endif 280 continue endif 300 ASUM = ASUM + CONE PP = RFNU*REAL(RFN13) BSUM = BSUM*CMPLX(PP,0.0E0) endif endif return END subroutine DEVS17(Z,FNU,KODE,IKFLG,N,Y,NUF,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-765 (DEC 1989). ! ! Original name: CUOIK ! ! DEVS17 COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC ! EXPANSIONS FOR THE I AND K functionS AND COMPARES THEM ! (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW ! WHERE ALIM < ELIM. IF THE MAGNITUDE, BASED ON THE LEADING ! EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN ! THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER ! MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE ! EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= ! EXP(-ELIM)/TOL ! ! IKFLG=1 MEANS THE I SEQUENCE IS TESTED ! =2 MEANS THE K SEQUENCE IS TESTED ! NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE ! =-1 MEANS AN OVERFLOW WOULD OCCUR ! IKFLG=1 AND NUF>0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO ! THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE ! IKFLG=2 AND NUF==N MEANS ALL Y VALUES WERE SET TO ZERO ! IKFLG=2 AND 0 < NUF < N NOT CONSIDERED. Y MUST BE SET BY ! ANOTHER ROUTINE ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER IKFLG, KODE, N, NUF ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX ARG, ASUM, BSUM, CZ, CZERO, PHI, SUM, ZB, ZETA1, & ZETA2, ZN, ZR REAL AARG, AIC, APHI, ASCLE, AX, AY, FNN, GNN, GNU, & RCZ, X, YY INTEGER I, IFORM, INIT, NN, NW ! .. Local Arrays .. COMPLEX CWRK(16) ! .. External functions .. REAL X02AME EXTERNAL X02AME ! .. External subroutines .. EXTERNAL DEUS17, DEWS17, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, LOG, MAX, & REAL, SIN ! .. Data statements .. DATA CZERO/(0.0E0,0.0E0)/ DATA AIC/1.265512123484645396E+00/ ! .. Executable Statements .. ! NUF = 0 NN = N X = REAL(Z) ZR = Z if (X < 0.0E0) ZR = -Z ZB = ZR YY = AIMAG(ZR) AX = ABS(X)*1.7321E0 AY = ABS(YY) IFORM = 1 if (AY > AX) IFORM = 2 GNU = MAX(FNU,1.0E0) if (IKFLG /= 1) then FNN = NN GNN = FNU + FNN - 1.0E0 GNU = MAX(GNN,FNN) endif ! ------------------------------------------------------------------ ! ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE ! REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET ! THE SIGN OF THE IMAGINARY PART CORRECT. ! ------------------------------------------------------------------ if (IFORM == 2) then ZN = -ZR*CMPLX(0.0E0,1.0E0) if (YY <= 0.0E0) ZN = CONJG(-ZN) CALL DEUS17(ZN,GNU,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM) CZ = -ZETA1 + ZETA2 AARG = ABS(ARG) ELSE INIT = 0 CALL DEWS17(ZR,GNU,IKFLG,1,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK, & ELIM) CZ = -ZETA1 + ZETA2 endif if (KODE == 2) CZ = CZ - ZB if (IKFLG == 2) CZ = -CZ APHI = ABS(PHI) RCZ = REAL(CZ) ! ------------------------------------------------------------------ ! OVERFLOW TEST ! ------------------------------------------------------------------ if (RCZ <= ELIM) then if (RCZ < ALIM) then ! ------------------------------------------------------------ ! UNDERFLOW TEST ! ------------------------------------------------------------ if (RCZ >= (-ELIM)) then if (RCZ > (-ALIM)) then goto 40 ELSE RCZ = RCZ + LOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC if (RCZ > (-ELIM)) then ASCLE = (1.0E+3*X02AME())/TOL CZ = CZ + LOG(PHI) if (IFORM /= 1) CZ = CZ - CMPLX(0.25E0,0.0E0) & *LOG(ARG) - CMPLX(AIC,0.0E0) AX = EXP(RCZ)/TOL AY = AIMAG(CZ) CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) CALL DGVS17(CZ,NW,ASCLE,TOL) if (NW /= 1) goto 40 endif endif endif DO 20 I = 1, NN Y(I) = CZERO 20 continue NUF = NN return ELSE RCZ = RCZ + LOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC if (RCZ > ELIM) goto 80 endif 40 if (IKFLG /= 2) then if (N /= 1) then 60 continue ! --------------------------------------------------------- ! SET UNDERFLOWS ON I SEQUENCE ! --------------------------------------------------------- GNU = FNU + NN - 1 if (IFORM == 2) then CALL DEUS17(ZN,GNU,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM, & BSUM,ELIM) CZ = -ZETA1 + ZETA2 AARG = ABS(ARG) ELSE INIT = 0 CALL DEWS17(ZR,GNU,IKFLG,1,TOL,INIT,PHI,ZETA1,ZETA2, & SUM,CWRK,ELIM) CZ = -ZETA1 + ZETA2 endif if (KODE == 2) CZ = CZ - ZB APHI = ABS(PHI) RCZ = REAL(CZ) if (RCZ >= (-ELIM)) then if (RCZ > (-ALIM)) then return ELSE RCZ = RCZ + LOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC if (RCZ > (-ELIM)) then ASCLE = (1.0E+3*X02AME())/TOL CZ = CZ + LOG(PHI) if (IFORM /= 1) CZ = CZ - CMPLX(0.25E0,0.0E0) & *LOG(ARG) - CMPLX(AIC, & 0.0E0) AX = EXP(RCZ)/TOL AY = AIMAG(CZ) CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) CALL DGVS17(CZ,NW,ASCLE,TOL) if (NW /= 1) return endif endif endif Y(NN) = CZERO NN = NN - 1 NUF = NUF + 1 if (NN /= 0) goto 60 endif endif return endif 80 NUF = -1 return END subroutine DEWS17(ZR,FNU,IKFLG,IPMTR,TOL,INIT,PHI,ZETA1,ZETA2,SUM, & CWRK,ELIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-766 (DEC 1989). ! ! Original name: CUNIK ! ! DEWS17 COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC ! EXPANSIONS OF THE I AND K functionS ON IKFLG= 1 OR 2 ! RESPECTIVELY BY ! ! W(FNU,ZR) = PHI*EXP(ZETA)*SUM ! ! WHERE ZETA=-ZETA1 + ZETA2 OR ! ZETA1 - ZETA2 ! ! THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE ! SAME ZR AND FNU WILL return THE I OR K function ON IKFLG= ! 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK ! ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, ! ZETA1,ZETA2. ! ! .. Scalar Arguments .. COMPLEX PHI, SUM, ZETA1, ZETA2, ZR REAL ELIM, FNU, TOL INTEGER IKFLG, INIT, IPMTR ! .. Array Arguments .. COMPLEX CWRK(16) ! .. Local Scalars .. COMPLEX CFN, CONE, CRFN, CZERO, S, SR, T, T2, ZN REAL AC, RFN, TEST, TSTI, TSTR INTEGER I, J, K, L ! .. Local Arrays .. COMPLEX CON(2) REAL C(120) !bc ! .. external functions .. real x02ane external x02ane ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, EXP, LOG, REAL, SQRT ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ DATA CON(1), CON(2)/(3.98942280401432678E-01,0.0E0), & (1.25331413731550025E+00,0.0E0)/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), & C(9), C(10), C(11), C(12), C(13), C(14), C(15), & C(16)/1.00000000000000000E+00, & -2.08333333333333333E-01, & 1.25000000000000000E-01, & 3.34201388888888889E-01, & -4.01041666666666667E-01, & 7.03125000000000000E-02, & -1.02581259645061728E+00, & 1.84646267361111111E+00, & -8.91210937500000000E-01, & 7.32421875000000000E-02, & 4.66958442342624743E+00, & -1.12070026162229938E+01, & 8.78912353515625000E+00, & -2.36408691406250000E+00, & 1.12152099609375000E-01, & -2.82120725582002449E+01/ DATA C(17), C(18), C(19), C(20), C(21), C(22), C(23), & C(24)/8.46362176746007346E+01, & -9.18182415432400174E+01, & 4.25349987453884549E+01, & -7.36879435947963170E+00, & 2.27108001708984375E-01, & 2.12570130039217123E+02, & -7.65252468141181642E+02, & 1.05999045252799988E+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), & C(32), C(33), C(34), C(35), C(36), C(37), C(38), & C(39), C(40)/-6.99579627376132541E+02, & 2.18190511744211590E+02, & -2.64914304869515555E+01, & 5.72501420974731445E-01, & -1.91945766231840700E+03, & 8.06172218173730938E+03, & -1.35865500064341374E+04, & 1.16553933368645332E+04, & -5.30564697861340311E+03, & 1.20090291321635246E+03, & -1.08090919788394656E+02, & 1.72772750258445740E+00, & 2.02042913309661486E+04, & -9.69805983886375135E+04, & 1.92547001232531532E+05, & -2.03400177280415534E+05/ DATA C(41), C(42), C(43), C(44), C(45), C(46), C(47), & C(48)/1.22200464983017460E+05, & -4.11926549688975513E+04, & 7.10951430248936372E+03, & -4.93915304773088012E+02, & 6.07404200127348304E+00, & -2.42919187900551333E+05, & 1.31176361466297720E+06, & -2.99801591853810675E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), & C(56), C(57), C(58), C(59), C(60), C(61), C(62), & C(63), C(64)/3.76327129765640400E+06, & -2.81356322658653411E+06, & 1.26836527332162478E+06, & -3.31645172484563578E+05, & 4.52187689813627263E+04, & -2.49983048181120962E+03, & 2.43805296995560639E+01, & 3.28446985307203782E+06, & -1.97068191184322269E+07, & 5.09526024926646422E+07, & -7.41051482115326577E+07, & 6.63445122747290267E+07, & -3.75671766607633513E+07, & 1.32887671664218183E+07, & -2.78561812808645469E+06, & 3.08186404612662398E+05/ DATA C(65), C(66), C(67), C(68), C(69), C(70), C(71), & C(72)/-1.38860897537170405E+04, & 1.10017140269246738E+02, & -4.93292536645099620E+07, & 3.25573074185765749E+08, & -9.39462359681578403E+08, & 1.55359689957058006E+09, & -1.62108055210833708E+09, & 1.10684281682301447E+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), & C(80), C(81), C(82), C(83), C(84), C(85), C(86), & C(87), C(88)/-4.95889784275030309E+08, & 1.42062907797533095E+08, & -2.44740627257387285E+07, & 2.24376817792244943E+06, & -8.40054336030240853E+04, & 5.51335896122020586E+02, & 8.14789096118312115E+08, & -5.86648149205184723E+09, & 1.86882075092958249E+10, & -3.46320433881587779E+10, & 4.12801855797539740E+10, & -3.30265997498007231E+10, & 1.79542137311556001E+10, & -6.56329379261928433E+09, & 1.55927986487925751E+09, & -2.25105661889415278E+08/ DATA C(89), C(90), C(91), C(92), C(93), C(94), C(95), & C(96)/1.73951075539781645E+07, & -5.49842327572288687E+05, & 3.03809051092238427E+03, & -1.46792612476956167E+10, & 1.14498237732025810E+11, & -3.99096175224466498E+11, & 8.19218669548577329E+11, & -1.09837515608122331E+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), & C(103), C(104), C(105), C(106), C(107), C(108), & C(109), C(110)/1.00815810686538209E+12, & -6.45364869245376503E+11, & 2.87900649906150589E+11, & -8.78670721780232657E+10, & 1.76347306068349694E+10, & -2.16716498322379509E+09, & 1.43157876718888981E+08, & -3.87183344257261262E+06, & 1.82577554742931747E+04, & 2.86464035717679043E+11, & -2.40629790002850396E+12, & 9.10934118523989896E+12, & -2.05168994109344374E+13, & 3.05651255199353206E+13/ DATA C(111), C(112), C(113), C(114), C(115), C(116), & C(117), C(118), C(119), & C(120)/-3.16670885847851584E+13, & 2.33483640445818409E+13, & -1.23204913055982872E+13, & 4.61272578084913197E+12, & -1.19655288019618160E+12, & 2.05914503232410016E+11, & -2.18229277575292237E+10, & 1.24700929351271032E+09, & -2.91883881222208134E+07, & 1.18838426256783253E+05/ ! .. Executable Statements .. ! if (INIT == 0) then ! --------------------------------------------------------------- ! INITIALIZE ALL VARIABLES ! --------------------------------------------------------------- RFN = 1.0E0/FNU CRFN = CMPLX(RFN,0.0E0) TSTR = REAL(ZR) TSTI = AIMAG(ZR) TEST = FNU*EXP(-ELIM) if (ABS(TSTR) < TEST) TSTR = 0.0E0 if (ABS(TSTI) < TEST) TSTI = 0.0E0 !bc if (TSTR==0.0E0 .and. TSTI==0.0E0) then if (abs(tstr) <= x02ane() .and. abs(tsti) <= x02ane()) then ZETA1 = CMPLX(ELIM+ELIM+FNU,0.0E0) ZETA2 = CMPLX(FNU,0.0E0) PHI = CONE return endif T = CMPLX(TSTR,TSTI)*CRFN S = CONE + T*T SR = SQRT(S) CFN = CMPLX(FNU,0.0E0) ZN = (CONE+SR)/T ZETA1 = CFN*LOG(ZN) ZETA2 = CFN*SR T = CONE/SR SR = T*CRFN CWRK(16) = SQRT(SR) PHI = CWRK(16)*CON(IKFLG) if (IPMTR /= 0) then return ELSE T2 = CONE/S CWRK(1) = CONE CRFN = CONE AC = 1.0E0 L = 1 DO 40 K = 2, 15 S = CZERO DO 20 J = 1, K L = L + 1 S = S*T2 + CMPLX(C(L),0.0E0) 20 continue CRFN = CRFN*SR CWRK(K) = CRFN*S AC = AC*RFN TSTR = REAL(CWRK(K)) TSTI = AIMAG(CWRK(K)) TEST = ABS(TSTR) + ABS(TSTI) if (AC < TOL .and. TEST < TOL) goto 60 40 continue K = 15 60 INIT = K endif endif if (IKFLG == 2) then ! --------------------------------------------------------------- ! COMPUTE SUM FOR THE K function ! --------------------------------------------------------------- S = CZERO T = CONE DO 80 I = 1, INIT S = S + T*CWRK(I) T = -T 80 continue SUM = S PHI = CWRK(16)*CON(2) ELSE ! --------------------------------------------------------------- ! COMPUTE SUM FOR THE I function ! --------------------------------------------------------------- S = CZERO DO 100 I = 1, INIT S = S + CWRK(I) 100 continue SUM = S PHI = CWRK(16)*CON(1) endif return END subroutine DEXS17(Z,FNU,KODE,N,Y,NZ,NLAST,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-767 (DEC 1989). ! ! Original name: CUNI1 ! ! DEXS17 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC ! EXPANSION FOR I(FNU,Z) IN -PI/3 <= ARG Z <= PI/3. ! ! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC ! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. ! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER ! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL. ! Y(I)=CZERO FOR I=NLAST+1,N ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, TOL INTEGER KODE, N, NLAST, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CFN, CONE, CRSC, CSCL, CZERO, PHI, RZ, & S1, S2, SUM, ZETA1, ZETA2 REAL APHI, ASCLE, C2I, C2M, C2R, FN, RS1, YY INTEGER I, IFLAG, INIT, K, M, ND, NN, NUF, NW ! .. Local Arrays .. COMPLEX CSR(3), CSS(3), CWRK(16), CY(2) REAL BRY(3) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEVS17, DEWS17, DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MAX, MIN, & REAL, SIN ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 ND = N NLAST = 0 ! ------------------------------------------------------------------ ! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- ! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, ! EXP(ALIM)=EXP(ELIM)*TOL ! ------------------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL ! ------------------------------------------------------------------ ! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER ! ------------------------------------------------------------------ FN = MAX(FNU,1.0E0) INIT = 0 CALL DEWS17(Z,FN,1,1,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK,ELIM) if (KODE == 1) then S1 = -ZETA1 + ZETA2 ELSE CFN = CMPLX(FN,0.0E0) S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) endif RS1 = REAL(S1) if (ABS(RS1) <= ELIM) then 20 continue NN = MIN(2,ND) DO 40 I = 1, NN FN = FNU + ND - I INIT = 0 CALL DEWS17(Z,FN,1,0,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK,ELIM) if (KODE == 1) then S1 = -ZETA1 + ZETA2 ELSE CFN = CMPLX(FN,0.0E0) YY = AIMAG(Z) S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + CMPLX(0.0E0,YY) endif ! ------------------------------------------------------------ ! TEST FOR UNDERFLOW AND OVERFLOW ! ------------------------------------------------------------ RS1 = REAL(S1) if (ABS(RS1) > ELIM) then goto 60 ELSE if (I == 1) IFLAG = 2 if (ABS(RS1) >= ALIM) then ! ------------------------------------------------------ ! REFINE TEST AND SCALE ! ------------------------------------------------------ APHI = ABS(PHI) RS1 = RS1 + LOG(APHI) if (ABS(RS1) > ELIM) then goto 60 ELSE if (I == 1) IFLAG = 1 if (RS1 >= 0.0E0) then if (I == 1) IFLAG = 3 endif endif endif ! --------------------------------------------------------- ! SCALE S1 IF CABS(S1) < ASCLE ! --------------------------------------------------------- S2 = PHI*SUM C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG == 1) then CALL DGVS17(S2,NW,BRY(1),TOL) if (NW /= 0) goto 60 endif M = ND - I + 1 CY(I) = S2 Y(M) = S2*CSR(IFLAG) endif 40 continue goto 80 ! --------------------------------------------------------------- ! SET UNDERFLOW AND UPDATE PARAMETERS ! --------------------------------------------------------------- 60 continue if (RS1 > 0.0E0) then goto 160 ELSE Y(ND) = CZERO NZ = NZ + 1 ND = ND - 1 if (ND == 0) then return ELSE CALL DEVS17(Z,FNU,KODE,1,ND,Y,NUF,TOL,ELIM,ALIM) if (NUF < 0) then goto 160 ELSE ND = ND - NUF NZ = NZ + NUF if (ND == 0) then return ELSE FN = FNU + ND - 1 if (FN >= FNUL) then goto 20 ELSE goto 120 endif endif endif endif endif 80 if (ND > 2) then RZ = CMPLX(2.0E0,0.0E0)/Z BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() S1 = CY(1) S2 = CY(2) C1 = CSR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = K DO 100 I = 3, ND C2 = S2 S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 S1 = C2 C2 = S2*C1 Y(K) = C2 K = K - 1 FN = FN - 1.0E0 if (IFLAG < 3) then C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) C1 = CSR(IFLAG) endif endif 100 continue endif return 120 NLAST = ND return else if (RS1 <= 0.0E0) then NZ = N DO 140 I = 1, N Y(I) = CZERO 140 continue return endif 160 NZ = -1 return END subroutine DEYS17(Z,FNU,KODE,N,Y,NZ,NUI,NLAST,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-768 (DEC 1989). ! ! Original name: CBUNI ! ! DEYS17 COMPUTES THE I BESSEL function FOR LARGE CABS(Z)> ! FNUL AND FNU+N-1 < FNUL. THE ORDER IS INCREASED FROM ! FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING ! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) ! ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, TOL INTEGER KODE, N, NLAST, NUI, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX CSCL, CSCR, RZ, S1, S2, ST REAL ASCLE, AX, AY, DFNU, FNUI, GNU, STI, STM, STR, & XX, YY INTEGER I, IFLAG, IFORM, K, NL, NW ! .. Local Arrays .. COMPLEX CY(2) REAL BRY(3) ! .. External functions .. REAL X02AME EXTERNAL X02AME ! .. External subroutines .. EXTERNAL DETS17, DEXS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, MAX, REAL ! .. Executable Statements .. ! NZ = 0 XX = REAL(Z) YY = AIMAG(Z) AX = ABS(XX)*1.7321E0 AY = ABS(YY) IFORM = 1 if (AY > AX) IFORM = 2 if (NUI == 0) then if (IFORM == 2) then ! ------------------------------------------------------------ ! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 ! ------------------------------------------------------------ CALL DETS17(Z,FNU,KODE,N,Y,NW,NLAST,FNUL,TOL,ELIM,ALIM) ELSE ! ------------------------------------------------------------ ! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 ! ------------------------------------------------------------ CALL DEXS17(Z,FNU,KODE,N,Y,NW,NLAST,FNUL,TOL,ELIM,ALIM) endif if (NW >= 0) then NZ = NW return endif ELSE FNUI = NUI DFNU = FNU + N - 1 GNU = DFNU + FNUI if (IFORM == 2) then ! ------------------------------------------------------------ ! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 ! ------------------------------------------------------------ CALL DETS17(Z,GNU,KODE,2,CY,NW,NLAST,FNUL,TOL,ELIM,ALIM) ELSE ! ------------------------------------------------------------ ! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 ! ------------------------------------------------------------ CALL DEXS17(Z,GNU,KODE,2,CY,NW,NLAST,FNUL,TOL,ELIM,ALIM) endif if (NW >= 0) then if (NW /= 0) then NLAST = N ELSE AY = ABS(CY(1)) ! --------------------------------------------------------- ! SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER ! USED ! --------------------------------------------------------- BRY(1) = (1.0E+3*X02AME())/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = BRY(2) IFLAG = 2 ASCLE = BRY(2) AX = 1.0E0 CSCL = CMPLX(AX,0.0E0) if (AY <= BRY(1)) then IFLAG = 1 ASCLE = BRY(1) AX = 1.0E0/TOL CSCL = CMPLX(AX,0.0E0) else if (AY >= BRY(2)) then IFLAG = 3 ASCLE = BRY(3) AX = TOL CSCL = CMPLX(AX,0.0E0) endif AY = 1.0E0/AX CSCR = CMPLX(AY,0.0E0) S1 = CY(2)*CSCL S2 = CY(1)*CSCL RZ = CMPLX(2.0E0,0.0E0)/Z DO 20 I = 1, NUI ST = S2 S2 = CMPLX(DFNU+FNUI,0.0E0)*RZ*S2 + S1 S1 = ST FNUI = FNUI - 1.0E0 if (IFLAG < 3) then ST = S2*CSCR STR = REAL(ST) STI = AIMAG(ST) STR = ABS(STR) STI = ABS(STI) STM = MAX(STR,STI) if (STM > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CSCR S2 = ST AX = AX*TOL AY = 1.0E0/AX CSCL = CMPLX(AX,0.0E0) CSCR = CMPLX(AY,0.0E0) S1 = S1*CSCL S2 = S2*CSCL endif endif 20 continue Y(N) = S2*CSCR if (N /= 1) then NL = N - 1 FNUI = NL K = NL DO 40 I = 1, NL ST = S2 S2 = CMPLX(FNU+FNUI,0.0E0)*RZ*S2 + S1 S1 = ST ST = S2*CSCR Y(K) = ST FNUI = FNUI - 1.0E0 K = K - 1 if (IFLAG < 3) then STR = REAL(ST) STI = AIMAG(ST) STR = ABS(STR) STI = ABS(STI) STM = MAX(STR,STI) if (STM > ASCLE) then IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CSCR S2 = ST AX = AX*TOL AY = 1.0E0/AX CSCL = CMPLX(AX,0.0E0) CSCR = CMPLX(AY,0.0E0) S1 = S1*CSCL S2 = S2*CSCL endif endif 40 continue endif endif return endif endif NZ = -1 if (NW == (-2)) NZ = -2 return END subroutine DEZS17(Z,FNU,KODE,N,CY,NZ,RL,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-769 (DEC 1989). ! ! Original name: CBINU ! ! DEZS17 COMPUTES THE I function IN THE RIGHT HALF Z PLANE ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, RL, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX CY(N) ! .. Local Scalars .. COMPLEX CZERO REAL AZ, DFNU INTEGER I, INW, NLAST, NN, NUI, NW ! .. Local Arrays .. COMPLEX CW(2) ! .. External subroutines .. EXTERNAL DESS17, DEVS17, DEYS17, DGRS17, DGTS17, DGYS17 ! .. Intrinsic functions .. INTRINSIC ABS, INT, MAX ! .. Data statements .. DATA CZERO/(0.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 AZ = ABS(Z) NN = N DFNU = FNU + N - 1 if (AZ > 2.0E0) then if (AZ*AZ*0.25E0 > DFNU+1.0E0) goto 20 endif ! ------------------------------------------------------------------ ! POWER SERIES ! ------------------------------------------------------------------ CALL DGRS17(Z,FNU,KODE,NN,CY,NW,TOL,ELIM,ALIM) INW = ABS(NW) NZ = NZ + INW NN = NN - INW if (NN == 0) then return else if (NW >= 0) then return ELSE DFNU = FNU + NN - 1 endif 20 if (AZ >= RL) then if (DFNU > 1.0E0) then if (AZ+AZ < DFNU*DFNU) goto 40 endif ! --------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR LARGE Z ! --------------------------------------------------------------- CALL DGYS17(Z,FNU,KODE,NN,CY,NW,RL,TOL,ELIM,ALIM) if (NW < 0) then goto 120 ELSE return endif else if (DFNU <= 1.0E0) then goto 100 endif ! ------------------------------------------------------------------ ! OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM ! ------------------------------------------------------------------ 40 CALL DEVS17(Z,FNU,KODE,1,NN,CY,NW,TOL,ELIM,ALIM) if (NW < 0) then goto 120 ELSE NZ = NZ + NW NN = NN - NW if (NN == 0) then return ELSE DFNU = FNU + NN - 1 if (DFNU <= FNUL) then if (AZ <= FNUL) goto 60 endif ! ------------------------------------------------------------ ! INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD ! ------------------------------------------------------------ NUI = INT(FNUL-DFNU) + 1 NUI = MAX(NUI,0) CALL DEYS17(Z,FNU,KODE,NN,CY,NW,NUI,NLAST,FNUL,TOL,ELIM, & ALIM) if (NW < 0) then goto 120 ELSE NZ = NZ + NW if (NLAST == 0) then return ELSE NN = NLAST endif endif 60 if (AZ > RL) then ! --------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN ! --------------------------------------------------------- ! --------------------------------------------------------- ! OVERFLOW TEST ON K functionS USED IN WRONSKIAN ! --------------------------------------------------------- CALL DEVS17(Z,FNU,KODE,2,2,CW,NW,TOL,ELIM,ALIM) if (NW < 0) then NZ = NN DO 80 I = 1, NN CY(I) = CZERO 80 continue return else if (NW > 0) then goto 120 ELSE CALL DESS17(Z,FNU,KODE,NN,CY,NW,CW,TOL,ELIM,ALIM) if (NW < 0) then goto 120 ELSE return endif endif endif endif endif ! ------------------------------------------------------------------ ! MILLER ALGORITHM NORMALIZED BY THE SERIES ! ------------------------------------------------------------------ 100 CALL DGTS17(Z,FNU,KODE,NN,CY,NW,TOL) if (NW >= 0) return 120 NZ = -1 if (NW == (-2)) NZ = -2 if (NW == (-3)) NZ = -3 return END subroutine DGRS17(Z,FNU,KODE,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-771 (DEC 1989). ! ! Original name: CSERI ! ! DGRS17 COMPUTES THE I BESSEL function FOR REAL(Z) >= 0.0 BY ! MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE ! REGION CABS(Z) <= 2*SQRT(FNU+1). NZ=0 IS A NORMAL return. ! NZ>0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO ! DUE TO UNDERFLOW. NZ < 0 MEANS UNDERFLOW OCCURRED, BUT THE ! CONDITION CABS(Z) <= 2*SQRT(FNU+1) WAS VIOLATED AND THE ! COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX AK1, CK, COEF, CONE, CRSC, CZ, CZERO, HZ, RZ, & S1, S2 REAL AA, ACZ, AK, ARM, ASCLE, ATOL, AZ, DFNU, FNUP, & RAK1, RS, RTR1, S, SS, X INTEGER I, IB, IDUM, IFLAG, IL, K, L, M, NN, NW ! .. Local Arrays .. COMPLEX W(2) ! .. External functions .. REAL S14ABE, X02AME EXTERNAL S14ABE, X02AME ! .. External subroutines .. EXTERNAL DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, REAL, & SIN, SQRT ! .. Data statements .. DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 AZ = ABS(Z) if (AZ /= 0.0E0) then X = REAL(Z) ARM = 1.0E+3*X02AME() RTR1 = SQRT(ARM) CRSC = CMPLX(1.0E0,0.0E0) IFLAG = 0 if (AZ < ARM) then NZ = N if (FNU == 0.0E0) NZ = NZ - 1 ELSE HZ = Z*CMPLX(0.5E0,0.0E0) CZ = CZERO if (AZ > RTR1) CZ = HZ*HZ ACZ = ABS(CZ) NN = N CK = LOG(HZ) 20 continue DFNU = FNU + NN - 1 FNUP = DFNU + 1.0E0 ! ------------------------------------------------------------ ! UNDERFLOW TEST ! ------------------------------------------------------------ AK1 = CK*CMPLX(DFNU,0.0E0) IDUM = 0 ! S14ABE assumed not to fail, therefore IDUM set to zero. AK = S14ABE(FNUP,IDUM) AK1 = AK1 - CMPLX(AK,0.0E0) if (KODE == 2) AK1 = AK1 - CMPLX(X,0.0E0) RAK1 = REAL(AK1) if (RAK1 > (-ELIM)) then if (RAK1 <= (-ALIM)) then IFLAG = 1 SS = 1.0E0/TOL CRSC = CMPLX(TOL,0.0E0) ASCLE = ARM*SS endif AK = AIMAG(AK1) AA = EXP(RAK1) if (IFLAG == 1) AA = AA*SS COEF = CMPLX(AA,0.0E0)*CMPLX(COS(AK),SIN(AK)) ATOL = TOL*ACZ/FNUP IL = MIN(2,NN) DO 60 I = 1, IL DFNU = FNU + NN - I FNUP = DFNU + 1.0E0 S1 = CONE if (ACZ >= TOL*FNUP) then AK1 = CONE AK = FNUP + 2.0E0 S = FNUP AA = 2.0E0 40 continue RS = 1.0E0/S AK1 = AK1*CZ*CMPLX(RS,0.0E0) S1 = S1 + AK1 S = S + AK AK = AK + 2.0E0 AA = AA*ACZ*RS if (AA > ATOL) goto 40 endif M = NN - I + 1 S2 = S1*COEF W(I) = S2 if (IFLAG /= 0) then CALL DGVS17(S2,NW,ASCLE,TOL) if (NW /= 0) goto 80 endif Y(M) = S2*CRSC if (I /= IL) COEF = COEF*CMPLX(DFNU,0.0E0)/HZ 60 continue goto 100 endif 80 NZ = NZ + 1 Y(NN) = CZERO if (ACZ > DFNU) then goto 180 ELSE NN = NN - 1 if (NN == 0) then return ELSE goto 20 endif endif 100 if (NN > 2) then K = NN - 2 AK = K RZ = (CONE+CONE)/Z if (IFLAG == 1) then ! ------------------------------------------------------ ! RECUR BACKWARD WITH SCALED VALUES ! ------------------------------------------------------ ! ------------------------------------------------------ ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE ! THE UNDERFLOW LIMIT = ASCLE = X02AME()*CSCL*1.0E+3 ! ------------------------------------------------------ S1 = W(1) S2 = W(2) DO 120 L = 3, NN CK = S2 S2 = S1 + CMPLX(AK+FNU,0.0E0)*RZ*S2 S1 = CK CK = S2*CRSC Y(K) = CK AK = AK - 1.0E0 K = K - 1 if (ABS(CK) > ASCLE) goto 140 120 continue return 140 IB = L + 1 if (IB > NN) return ELSE IB = 3 endif DO 160 I = IB, NN Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) AK = AK - 1.0E0 K = K - 1 160 continue endif return ! ------------------------------------------------------------ ! return WITH NZ < 0 IF CABS(Z*Z/4)>FNU+N-NZ-1 COMPLETE ! THE CALCULATION IN DEZS17 WITH N=N-IABS(NZ) ! ------------------------------------------------------------ 180 continue NZ = -NZ return endif endif Y(1) = CZERO if (FNU == 0.0E0) Y(1) = CONE if (N /= 1) then DO 200 I = 2, N Y(I) = CZERO 200 continue endif return END subroutine DGSS17(ZR,S1,S2,NZ,ASCLE,ALIM,IUF) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-772 (DEC 1989). ! ! Original name: CS1S2 ! ! DGSS17 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE ! ADDITION OF THE I AND K functionS IN THE ANALYTIC CON- ! TINUATION FORMULA WHERE S1=K function AND S2=I function. ! ON KODE=1 THE I AND K functionS ARE DIFFERENT ORDERS OF ! MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER ! OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE ! PRECISION ABOVE THE UNDERFLOW LIMIT. ! ! .. Scalar Arguments .. COMPLEX S1, S2, ZR REAL ALIM, ASCLE INTEGER IUF, NZ ! .. Local Scalars .. COMPLEX C1, CZERO, S1D REAL AA, ALN, AS1, AS2, XX INTEGER IF1 ! .. External functions .. COMPLEX S01EAE EXTERNAL S01EAE ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, LOG, MAX, REAL ! .. Data statements .. DATA CZERO/(0.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 AS1 = ABS(S1) AS2 = ABS(S2) AA = REAL(S1) ALN = AIMAG(S1) if (AA /= 0.0E0 .or. ALN /= 0.0E0) then if (AS1 /= 0.0E0) then XX = REAL(ZR) ALN = -XX - XX + LOG(AS1) S1D = S1 S1 = CZERO AS1 = 0.0E0 if (ALN >= (-ALIM)) then C1 = LOG(S1D) - ZR - ZR ! S1 = EXP(C1) IF1 = 1 S1 = S01EAE(C1,IF1) AS1 = ABS(S1) IUF = IUF + 1 endif endif endif AA = MAX(AS1,AS2) if (AA <= ASCLE) then S1 = CZERO S2 = CZERO NZ = 1 IUF = 0 endif return END subroutine DGTS17(Z,FNU,KODE,N,Y,NZ,TOL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-773 (DEC 1989). ! Mark 17 REVISED. IER-1703 (JUN 1995). ! ! Original name: CMLRI ! ! DGTS17 COMPUTES THE I BESSEL function FOR RE(Z) >= 0.0 BY THE ! MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. ! ! .. Scalar Arguments .. COMPLEX Z REAL FNU, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX CK, CNORM, CONE, CTWO, CZERO, P1, P2, PT, RZ, & SUM REAL ACK, AK, AP, AT, AZ, BK, FKAP, FKK, FLAM, FNF, & RHO, RHO2, SCLE, TFNF, TST, X INTEGER I, IAZ, IDUM, IFL, IFNU, INU, ITIME, K, KK, KM, & M ! .. External functions .. COMPLEX S01EAE REAL S14ABE, X02ANE EXTERNAL S14ABE, S01EAE, X02ANE ! .. Intrinsic functions .. INTRINSIC ABS, CMPLX, CONJG, EXP, INT, LOG, MAX, MIN, & REAL, SQRT ! .. Data statements .. DATA CZERO, CONE, CTWO/(0.0E0,0.0E0), (1.0E0,0.0E0), & (2.0E0,0.0E0)/ ! .. Executable Statements .. ! SCLE = (1.0E+3*X02ANE())/TOL NZ = 0 AZ = ABS(Z) X = REAL(Z) IAZ = INT(AZ) IFNU = INT(FNU) INU = IFNU + N - 1 AT = IAZ + 1.0E0 CK = CMPLX(AT,0.0E0)/Z RZ = CTWO/Z P1 = CZERO P2 = CONE ACK = (AT+1.0E0)/AZ RHO = ACK + SQRT(ACK*ACK-1.0E0) RHO2 = RHO*RHO TST = (RHO2+RHO2)/((RHO2-1.0E0)*(RHO-1.0E0)) TST = TST/TOL ! ------------------------------------------------------------------ ! COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES ! ------------------------------------------------------------------ AK = AT DO 20 I = 1, 80 PT = P2 P2 = P1 - CK*P2 P1 = PT CK = CK + RZ AP = ABS(P2) if (AP > TST*AK*AK) then goto 40 ELSE AK = AK + 1.0E0 endif 20 continue goto 180 40 I = I + 1 K = 0 if (INU >= IAZ) then ! --------------------------------------------------------------- ! COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS ! --------------------------------------------------------------- P1 = CZERO P2 = CONE AT = INU + 1.0E0 CK = CMPLX(AT,0.0E0)/Z ACK = AT/AZ TST = SQRT(ACK/TOL) ITIME = 1 DO 60 K = 1, 80 PT = P2 P2 = P1 - CK*P2 P1 = PT CK = CK + RZ AP = ABS(P2) if (AP >= TST) then if (ITIME == 2) then goto 80 ELSE ACK = ABS(CK) FLAM = ACK + SQRT(ACK*ACK-1.0E0) FKAP = AP/ABS(P1) RHO = MIN(FLAM,FKAP) TST = TST*SQRT(RHO/(RHO*RHO-1.0E0)) ITIME = 2 endif endif 60 continue goto 180 endif ! ------------------------------------------------------------------ ! BACKWARD RECURRENCE AND SUM NORMALIZING RELATION ! ------------------------------------------------------------------ 80 K = K + 1 KK = MAX(I+IAZ,K+INU) FKK = KK P1 = CZERO ! ------------------------------------------------------------------ ! SCALE P2 AND SUM BY SCLE ! ------------------------------------------------------------------ P2 = CMPLX(SCLE,0.0E0) FNF = FNU - IFNU TFNF = FNF + FNF IDUM = 0 ! S14ABE assumed not to fail, therefore IDUM set to zero. BK = S14ABE(FKK+TFNF+1.0E0,IDUM) - S14ABE(FKK+1.0E0,IDUM) - & S14ABE(TFNF+1.0E0,IDUM) BK = EXP(BK) SUM = CZERO KM = KK - INU DO 100 I = 1, KM PT = P2 P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 P1 = PT AK = 1.0E0 - TFNF/(FKK+TFNF) ACK = BK*AK SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 BK = ACK FKK = FKK - 1.0E0 100 continue Y(N) = P2 if (N /= 1) then DO 120 I = 2, N PT = P2 P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 P1 = PT AK = 1.0E0 - TFNF/(FKK+TFNF) ACK = BK*AK SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 BK = ACK FKK = FKK - 1.0E0 M = N - I + 1 Y(M) = P2 120 continue endif if (IFNU > 0) then DO 140 I = 1, IFNU PT = P2 P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 P1 = PT AK = 1.0E0 - TFNF/(FKK+TFNF) ACK = BK*AK SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 BK = ACK FKK = FKK - 1.0E0 140 continue endif PT = Z if (KODE == 2) PT = PT - CMPLX(X,0.0E0) P1 = -CMPLX(FNF,0.0E0)*LOG(RZ) + PT IDUM = 0 ! S14ABE assumed not to fail, therefore IDUM set to zero. AP = S14ABE(1.0E0+FNF,IDUM) PT = P1 - CMPLX(AP,0.0E0) ! ------------------------------------------------------------------ ! THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW ! IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES ! ------------------------------------------------------------------ P2 = P2 + SUM AP = ABS(P2) P1 = CMPLX(1.0E0/AP,0.0E0) ! CK = EXP(PT)*P1 IFL = 1 CK = S01EAE(PT,IFL)*P1 if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 200 PT = CONJG(P2)*P1 CNORM = CK*PT DO 160 I = 1, N Y(I) = Y(I)*CNORM 160 continue return 180 NZ = -2 return 200 NZ = -3 return END subroutine DGUS17(Z,CSH,CCH) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-774 (DEC 1989). ! ! Original name: CSHCH ! ! DGUS17 COMPUTES THE COMPLEX HYPERBOLIC functionS CSH=SINH(X+I*Y) ! AND CCH=COSH(X+I*Y), WHERE I**2=-1. ! ! .. Scalar Arguments .. COMPLEX CCH, CSH, Z ! .. Local Scalars .. REAL CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y ! .. Intrinsic functions .. INTRINSIC AIMAG, CMPLX, COS, COSH, REAL, SIN, SINH ! .. Executable Statements .. ! X = REAL(Z) Y = AIMAG(Z) SH = SINH(X) CH = COSH(X) SN = SIN(Y) CN = COS(Y) CSHR = SH*CN CSHI = CH*SN CSH = CMPLX(CSHR,CSHI) CCHR = CH*CN CCHI = SH*SN CCH = CMPLX(CCHR,CCHI) return END subroutine DGVS17(Y,NZ,ASCLE,TOL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-775 (DEC 1989). ! ! Original name: CUCHK ! ! Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN ! EXP(-ALIM)=ASCLE=1.0E+3*X02AME()/TOL. THE TEST IS MADE TO SEE ! IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW ! WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED ! IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE ! OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE ! ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. ! ! .. Scalar Arguments .. COMPLEX Y REAL ASCLE, TOL INTEGER NZ ! .. Local Scalars .. REAL SS, ST, YI, YR ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, MAX, MIN, REAL ! .. Executable Statements .. ! NZ = 0 YR = REAL(Y) YI = AIMAG(Y) YR = ABS(YR) YI = ABS(YI) ST = MIN(YR,YI) if (ST <= ASCLE) then SS = MAX(YR,YI) ST = ST/TOL if (SS < ST) NZ = 1 endif return END subroutine DGWS17(ZR,FNU,N,Y,NZ,RZ,ASCLE,TOL,ELIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-776 (DEC 1989). ! ! Original name: CKSCL ! ! SET K functionS TO ZERO ON UNDERFLOW, continue RECURRENCE ! ON SCALED functionS UNTIL TWO MEMBERS COME ON SCALE, THEN ! return WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. ! ! .. Scalar Arguments .. COMPLEX RZ, ZR REAL ASCLE, ELIM, FNU, TOL INTEGER N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX CELM, CK, CS, CZERO, S1, S2, ZD REAL AA, ACS, ALAS, AS, CSI, CSR, ELM, FN, HELIM, XX, & ZRI INTEGER I, IC, K, KK, NN, NW ! .. Local Arrays .. COMPLEX CY(2) ! .. External subroutines .. EXTERNAL DGVS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, REAL, SIN ! .. Data statements .. DATA CZERO/(0.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 IC = 0 XX = REAL(ZR) NN = MIN(2,N) DO 20 I = 1, NN S1 = Y(I) CY(I) = S1 AS = ABS(S1) ACS = -XX + LOG(AS) NZ = NZ + 1 Y(I) = CZERO if (ACS >= (-ELIM)) then CS = -ZR + LOG(S1) CSR = REAL(CS) CSI = AIMAG(CS) AA = EXP(CSR)/TOL CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) CALL DGVS17(CS,NW,ASCLE,TOL) if (NW == 0) then Y(I) = CS NZ = NZ - 1 IC = I endif endif 20 continue if (N /= 1) then if (IC <= 1) then Y(1) = CZERO NZ = 2 endif if (N /= 2) then if (NZ /= 0) then FN = FNU + 1.0E0 CK = CMPLX(FN,0.0E0)*RZ S1 = CY(1) S2 = CY(2) HELIM = 0.5E0*ELIM ELM = EXP(-ELIM) CELM = CMPLX(ELM,0.0E0) ZRI = AIMAG(ZR) ZD = ZR ! ! FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE ! RECURRENCE IF S2 GETS LARGER THAN EXP(ELIM/2) ! DO 40 I = 3, N KK = I CS = S2 S2 = CK*S2 + S1 S1 = CS CK = CK + RZ AS = ABS(S2) ALAS = LOG(AS) ACS = -XX + ALAS NZ = NZ + 1 Y(I) = CZERO if (ACS >= (-ELIM)) then CS = -ZD + LOG(S2) CSR = REAL(CS) CSI = AIMAG(CS) AA = EXP(CSR)/TOL CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) CALL DGVS17(CS,NW,ASCLE,TOL) if (NW == 0) then Y(I) = CS NZ = NZ - 1 if (IC == (KK-1)) then goto 60 ELSE IC = KK goto 40 endif endif endif if (ALAS >= HELIM) then XX = XX - ELIM S1 = S1*CELM S2 = S2*CELM ZD = CMPLX(XX,ZRI) endif 40 continue NZ = N if (IC == N) NZ = N - 1 goto 80 60 NZ = KK - 2 80 DO 100 K = 1, NZ Y(K) = CZERO 100 continue endif endif endif return END subroutine DGXS17(Z,FNU,KODE,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-777 (DEC 1989). ! ! Original name: CBKNU ! ! DGXS17 COMPUTES THE K BESSEL function IN THE RIGHT HALF Z PLANE ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX CCH, CELM, CK, COEF, CONE, CRSC, CS, CSCL, CSH, & CTWO, CZ, CZERO, F, FMU, P, P1, P2, PT, Q, RZ, & S1, S2, SMU, ST, ZD REAL A1, A2, AA, AK, ALAS, AS, ASCLE, BB, BK, CAZ, & DNU, DNU2, ELM, ETEST, FC, FHS, FK, FKS, FPI, & G1, G2, HELIM, HPI, P2I, P2M, P2R, PI, R1, RK, & RTHPI, S, SPI, T1, T2, TM, TTH, XD, XX, YD, YY INTEGER I, IC, IDUM, IFL, IFLAG, INU, INUB, J, K, KFLAG, & KK, KMAX, KODED, NW ! .. Local Arrays .. COMPLEX CSR(3), CSS(3), CY(2) REAL BRY(3), CC(8) ! .. External functions .. COMPLEX S01EAE REAL S14ABE, X02AME, X02ALE INTEGER X02BHE, X02BJE EXTERNAL S14ABE, S01EAE, X02AME, X02ALE, X02BHE, X02BJE ! .. External subroutines .. EXTERNAL DGUS17, DGVS17, DGWS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, ATAN, CMPLX, CONJG, COS, EXP, INT, & LOG, LOG10, MAX, MIN, REAL, SIN, SQRT ! .. Data statements .. ! ! ! DATA KMAX/30/ DATA R1/2.0E0/ DATA CZERO, CONE, CTWO/(0.0E0,0.0E0), (1.0E0,0.0E0), & (2.0E0,0.0E0)/ DATA PI, RTHPI, SPI, HPI, FPI, & TTH/3.14159265358979324E0, & 1.25331413731550025E0, 1.90985931710274403E0, & 1.57079632679489662E0, 1.89769999331517738E0, & 6.66666666666666666E-01/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), & CC(8)/5.77215664901532861E-01, & -4.20026350340952355E-02, & -4.21977345555443367E-02, & 7.21894324666309954E-03, & -2.15241674114950973E-04, & -2.01348547807882387E-05, & 1.13302723198169588E-06, & 6.11609510448141582E-09/ ! .. Executable Statements .. ! XX = REAL(Z) YY = AIMAG(Z) CAZ = ABS(Z) CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = (1.0E+3*X02AME())/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = X02ALE() NZ = 0 IFLAG = 0 KODED = KODE RZ = CTWO/Z INU = INT(FNU+0.5E0) DNU = FNU - INU if (ABS(DNU) /= 0.5E0) then DNU2 = 0.0E0 if (ABS(DNU) > TOL) DNU2 = DNU*DNU if (CAZ <= R1) then ! ------------------------------------------------------------ ! SERIES FOR CABS(Z) <= R1 ! ------------------------------------------------------------ FC = 1.0E0 SMU = LOG(RZ) FMU = SMU*CMPLX(DNU,0.0E0) CALL DGUS17(FMU,CSH,CCH) if (DNU /= 0.0E0) then FC = DNU*PI FC = FC/SIN(FC) SMU = CSH*CMPLX(1.0E0/DNU,0.0E0) endif A2 = 1.0E0 + DNU ! ------------------------------------------------------------ ! GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), ! T2=1/GAM(1+DNU) ! ------------------------------------------------------------ IDUM = 0 ! S14ABE assumed not to fail, therefore IDUM set to zero. T2 = EXP(-S14ABE(A2,IDUM)) T1 = 1.0E0/(T2*FC) if (ABS(DNU) > 0.1E0) then G1 = (T1-T2)/(DNU+DNU) ELSE ! --------------------------------------------------------- ! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) ! --------------------------------------------------------- AK = 1.0E0 S = CC(1) DO 20 K = 2, 8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM if (ABS(TM) < TOL) goto 40 20 continue 40 G1 = -S endif G2 = 0.5E0*(T1+T2)*FC G1 = G1*FC F = CMPLX(G1,0.0E0)*CCH + SMU*CMPLX(G2,0.0E0) IFL = 1 PT = S01EAE(FMU,IFL) if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320 P = CMPLX(0.5E0/T2,0.0E0)*PT Q = CMPLX(0.5E0/T1,0.0E0)/PT S1 = F S2 = P AK = 1.0E0 A1 = 1.0E0 CK = CONE BK = 1.0E0 - DNU2 if (INU > 0 .or. N > 1) then ! --------------------------------------------------------- ! GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE ! --------------------------------------------------------- if (CAZ >= TOL) then CZ = Z*Z*CMPLX(0.25E0,0.0E0) T1 = 0.25E0*CAZ*CAZ 60 continue F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) RK = 1.0E0/AK CK = CK*CZ*CMPLX(RK,0.0E0) S1 = S1 + CK*F S2 = S2 + CK*(P-F*CMPLX(AK,0.0E0)) A1 = A1*T1*RK BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 if (A1 > TOL) goto 60 endif KFLAG = 2 BK = REAL(SMU) A1 = FNU + 1.0E0 AK = A1*ABS(BK) if (AK > ALIM) KFLAG = 3 P2 = S2*CSS(KFLAG) S2 = P2*RZ S1 = S1*CSS(KFLAG) if (KODED /= 1) then ! F = EXP(Z) IFL = 1 F = S01EAE(Z,IFL) if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320 S1 = S1*F S2 = S2*F endif goto 160 ELSE ! --------------------------------------------------------- ! GENERATE K(FNU,Z), 0.0D0 <= FNU < 0.5D0 AND N=1 ! --------------------------------------------------------- if (CAZ >= TOL) then CZ = Z*Z*CMPLX(0.25E0,0.0E0) T1 = 0.25E0*CAZ*CAZ 80 continue F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) RK = 1.0E0/AK CK = CK*CZ*CMPLX(RK,0.0E0) S1 = S1 + CK*F A1 = A1*T1*RK BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 if (A1 > TOL) goto 80 endif Y(1) = S1 ! if (KODED /= 1) Y(1) = S1*EXP(Z) if (KODED /= 1) then IFL = 1 Y(1) = S01EAE(Z,IFL) if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320 Y(1) = S1*Y(1) endif return endif endif endif ! ------------------------------------------------------------------ ! IFLAG=0 MEANS NO UNDERFLOW OCCURRED ! IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH ! KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD ! RECURSION ! ------------------------------------------------------------------ COEF = CMPLX(RTHPI,0.0E0)/SQRT(Z) KFLAG = 2 if (KODED /= 2) then if (XX > ALIM) then ! ------------------------------------------------------------ ! SCALE BY EXP(Z), IFLAG = 1 CASES ! ------------------------------------------------------------ KODED = 2 IFLAG = 1 KFLAG = 2 ELSE ! BLANK LINE ! A1 = EXP(-XX)*REAL(CSS(KFLAG)) ! PT = CMPLX(A1,0.0E0)*CMPLX(COS(YY),-SIN(YY)) IFL = 1 PT = S01EAE(CMPLX(-XX,-YY),IFL) if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320 PT = PT*REAL(CSS(KFLAG)) COEF = COEF*PT endif endif if (ABS(DNU) /= 0.5E0) then ! --------------------------------------------------------------- ! MILLER ALGORITHM FOR CABS(Z)>R1 ! --------------------------------------------------------------- AK = COS(PI*DNU) AK = ABS(AK) if (AK /= 0.0E0) then FHS = ABS(0.25E0-DNU2) if (FHS /= 0.0E0) then ! --------------------------------------------------------- ! COMPUTE R2=F(E). IF CABS(Z) >= R2, USE FORWARD RECURRENCE ! TO DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT ! LINE ON 12 <= E <= 60. E IS COMPUTED FROM ! 2**(-E)=B**(1-X02BJE())=TOL WHERE B IS THE BASE OF THE ! ARITHMETIC. ! --------------------------------------------------------- T1 = (X02BJE()-1)*LOG10(REAL(X02BHE()))*3.321928094E0 T1 = MAX(T1,12.0E0) T1 = MIN(T1,60.0E0) T2 = TTH*T1 - 6.0E0 if (XX /= 0.0E0) then T1 = ATAN(YY/XX) T1 = ABS(T1) ELSE T1 = HPI endif if (T2 > CAZ) then ! ------------------------------------------------------ ! COMPUTE BACKWARD INDEX K FOR CABS(Z) < R2 ! ------------------------------------------------------ A2 = SQRT(CAZ) AK = FPI*AK/(TOL*SQRT(A2)) AA = 3.0E0*T1/(1.0E0+CAZ) BB = 14.7E0*T1/(28.0E0+CAZ) AK = (LOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB) FK = 0.12125E0*AK*AK/CAZ + 1.5E0 ELSE ! ------------------------------------------------------ ! FORWARD RECURRENCE LOOP WHEN CABS(Z) >= R2 ! ------------------------------------------------------ ETEST = AK/(PI*CAZ*TOL) FK = 1.0E0 if (ETEST >= 1.0E0) then FKS = 2.0E0 RK = CAZ + CAZ + 2.0E0 A1 = 0.0E0 A2 = 1.0E0 DO 100 I = 1, KMAX AK = FHS/FKS BK = RK/(FK+1.0E0) TM = A2 A2 = BK*A2 - AK*A1 A1 = TM RK = RK + 2.0E0 FKS = FKS + FK + FK + 2.0E0 FHS = FHS + FK + FK FK = FK + 1.0E0 TM = ABS(A2)*FK if (ETEST < TM) goto 120 100 continue NZ = -2 return 120 FK = FK + SPI*T1*SQRT(T2/CAZ) FHS = ABS(0.25E0-DNU2) endif endif K = INT(FK) ! --------------------------------------------------------- ! BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM ! --------------------------------------------------------- FK = K FKS = FK*FK P1 = CZERO P2 = CMPLX(TOL,0.0E0) CS = P2 DO 140 I = 1, K A1 = FKS - FK A2 = (FKS+FK)/(A1+FHS) RK = 2.0E0/(FK+1.0E0) T1 = (FK+XX)*RK T2 = YY*RK PT = P2 P2 = (P2*CMPLX(T1,T2)-P1)*CMPLX(A2,0.0E0) P1 = PT CS = CS + P2 FKS = A1 - FK + 1.0E0 FK = FK - 1.0E0 140 continue ! --------------------------------------------------------- ! COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR ! BETTER SCALING ! --------------------------------------------------------- TM = ABS(CS) PT = CMPLX(1.0E0/TM,0.0E0) S1 = PT*P2 CS = CONJG(CS)*PT S1 = COEF*S1*CS if (INU > 0 .or. N > 1) then ! ------------------------------------------------------ ! COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR ! SCALING ! ------------------------------------------------------ TM = ABS(P2) PT = CMPLX(1.0E0/TM,0.0E0) P1 = PT*P1 P2 = CONJG(P2)*PT PT = P1*P2 S2 = S1*(CONE+(CMPLX(DNU+0.5E0,0.0E0)-PT)/Z) goto 160 ELSE ZD = Z if (IFLAG == 1) then goto 240 ELSE goto 260 endif endif endif endif endif ! ------------------------------------------------------------------ ! FNU=HALF ODD INTEGER CASE, DNU=-0.5 ! ------------------------------------------------------------------ S1 = COEF S2 = COEF ! ------------------------------------------------------------------ ! FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH ! SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 ! ------------------------------------------------------------------ 160 continue CK = CMPLX(DNU+1.0E0,0.0E0)*RZ if (N == 1) INU = INU - 1 if (INU > 0) then INUB = 1 if (IFLAG == 1) then ! ------------------------------------------------------------ ! IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON ! UNDERFLOW ! ------------------------------------------------------------ HELIM = 0.5E0*ELIM ELM = EXP(-ELIM) CELM = CMPLX(ELM,0.0E0) ASCLE = BRY(1) ZD = Z XD = XX YD = YY IC = -1 J = 2 DO 180 I = 1, INU ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RZ AS = ABS(S2) ALAS = LOG(AS) P2R = -XD + ALAS if (P2R >= (-ELIM)) then P2 = -ZD + LOG(S2) P2R = REAL(P2) P2I = AIMAG(P2) P2M = EXP(P2R)/TOL P1 = CMPLX(P2M,0.0E0)*CMPLX(COS(P2I),SIN(P2I)) CALL DGVS17(P1,NW,ASCLE,TOL) if (NW == 0) then J = 3 - J CY(J) = P1 if (IC == (I-1)) then goto 200 ELSE IC = I goto 180 endif endif endif if (ALAS >= HELIM) then XD = XD - ELIM S1 = S1*CELM S2 = S2*CELM ZD = CMPLX(XD,YD) endif 180 continue if (N == 1) S1 = S2 goto 240 200 KFLAG = 1 INUB = I + 1 S2 = CY(J) J = 3 - J S1 = CY(J) if (INUB > INU) then if (N == 1) S1 = S2 goto 260 endif endif P1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 220 I = INUB, INU ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RZ if (KFLAG < 3) then P2 = S2*P1 P2R = REAL(P2) P2I = AIMAG(P2) P2R = ABS(P2R) P2I = ABS(P2I) P2M = MAX(P2R,P2I) if (P2M > ASCLE) then KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*P1 S2 = P2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) P1 = CSR(KFLAG) endif endif 220 continue if (N == 1) S1 = S2 goto 260 ELSE if (N == 1) S1 = S2 ZD = Z if (IFLAG /= 1) goto 260 endif 240 Y(1) = S1 if (N /= 1) Y(2) = S2 ASCLE = BRY(1) CALL DGWS17(ZD,FNU,N,Y,NZ,RZ,ASCLE,TOL,ELIM) INU = N - NZ if (INU <= 0) then return ELSE KK = NZ + 1 S1 = Y(KK) Y(KK) = S1*CSR(1) if (INU == 1) then return ELSE KK = NZ + 2 S2 = Y(KK) Y(KK) = S2*CSR(1) if (INU == 2) then return ELSE T2 = FNU + KK - 1 CK = CMPLX(T2,0.0E0)*RZ KFLAG = 1 goto 280 endif endif endif 260 Y(1) = S1*CSR(KFLAG) if (N == 1) then return ELSE Y(2) = S2*CSR(KFLAG) if (N == 2) then return ELSE KK = 2 endif endif 280 KK = KK + 1 if (KK <= N) then P1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 300 I = KK, N P2 = S2 S2 = CK*S2 + S1 S1 = P2 CK = CK + RZ P2 = S2*P1 Y(I) = P2 if (KFLAG < 3) then P2R = REAL(P2) P2I = AIMAG(P2) P2R = ABS(P2R) P2I = ABS(P2I) P2M = MAX(P2R,P2I) if (P2M > ASCLE) then KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*P1 S2 = P2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) P1 = CSR(KFLAG) endif endif 300 continue endif return 320 NZ = -3 return END subroutine DGYS17(Z,FNU,KODE,N,Y,NZ,RL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-778 (DEC 1989). ! ! Original name: CASYI ! ! DGYS17 COMPUTES THE I BESSEL function FOR REAL(Z) >= 0.0 BY ! MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE ! REGION CABS(Z)>MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL return. ! NZ < 0 INDICATES AN OVERFLOW ON KODE=1. ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, RL, TOL INTEGER KODE, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, & RZ, S2 REAL AA, ACZ, AEZ, AK, ARG, ARM, ATOL, AZ, BB, BK, & DFNU, DNU2, FDN, PI, RTPI, RTR1, S, SGN, SQK, X, & YY INTEGER I, IB, IERR1, IL, INU, J, JL, K, KODED, M, NN ! .. External functions .. COMPLEX S01EAE REAL X02AME EXTERNAL S01EAE, X02AME ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, MIN, MOD, & REAL, SIN, SQRT ! .. Data statements .. DATA PI, RTPI/3.14159265358979324E0, & 0.159154943091895336E0/ DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 AZ = ABS(Z) X = REAL(Z) ARM = 1.0E+3*X02AME() RTR1 = SQRT(ARM) IL = MIN(2,N) DFNU = FNU + N - IL ! ------------------------------------------------------------------ ! OVERFLOW TEST ! ------------------------------------------------------------------ AK1 = CMPLX(RTPI,0.0E0)/Z AK1 = SQRT(AK1) CZ = Z if (KODE == 2) CZ = Z - CMPLX(X,0.0E0) ACZ = REAL(CZ) if (ABS(ACZ) > ELIM) then NZ = -1 ELSE DNU2 = DFNU + DFNU KODED = 1 if ((ABS(ACZ) <= ALIM) .or. (N <= 2)) then KODED = 0 IERR1 = 1 AK1 = AK1*S01EAE(CZ,IERR1) ! Allow reduced precision from S01EAE, but disallow other errors. if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) goto 140 endif FDN = 0.0E0 if (DNU2 > RTR1) FDN = DNU2*DNU2 EZ = Z*CMPLX(8.0E0,0.0E0) ! --------------------------------------------------------------- ! WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO ! THE FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF ! THE EXPANSION FOR THE IMAGINARY PART. ! --------------------------------------------------------------- AEZ = 8.0E0*AZ S = TOL/AEZ JL = INT(RL+RL) + 2 YY = AIMAG(Z) P1 = CZERO if (YY /= 0.0E0) then ! ------------------------------------------------------------ ! CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF ! SIGNIFICANCE WHEN FNU OR N IS LARGE ! ------------------------------------------------------------ INU = INT(FNU) ARG = (FNU-INU)*PI INU = INU + N - IL AK = -SIN(ARG) BK = COS(ARG) if (YY < 0.0E0) BK = -BK P1 = CMPLX(AK,BK) if (MOD(INU,2) == 1) P1 = -P1 endif DO 60 K = 1, IL SQK = FDN - 1.0E0 ATOL = S*ABS(SQK) SGN = 1.0E0 CS1 = CONE CS2 = CONE CK = CONE AK = 0.0E0 AA = 1.0E0 BB = AEZ DK = EZ DO 20 J = 1, JL CK = CK*CMPLX(SQK,0.0E0)/DK CS2 = CS2 + CK SGN = -SGN CS1 = CS1 + CK*CMPLX(SGN,0.0E0) DK = DK + EZ AA = AA*ABS(SQK)/BB BB = BB + AEZ AK = AK + 8.0E0 SQK = SQK - AK if (AA <= ATOL) goto 40 20 continue goto 120 40 S2 = CS1 if (X+X < ELIM) then IERR1 = 1 S2 = S2 + P1*CS2*S01EAE(-Z-Z,IERR1) if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) & goto 140 endif FDN = FDN + 8.0E0*DFNU + 4.0E0 P1 = -P1 M = N - IL + K Y(M) = S2*AK1 60 continue if (N > 2) then NN = N K = NN - 2 AK = K RZ = (CONE+CONE)/Z IB = 3 DO 80 I = IB, NN Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) AK = AK - 1.0E0 K = K - 1 80 continue if (KODED /= 0) then IERR1 = 1 CK = S01EAE(CZ,IERR1) if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) & goto 140 DO 100 I = 1, NN Y(I) = Y(I)*CK 100 continue endif endif return 120 NZ = -2 return 140 NZ = -3 endif return END subroutine DGZS17(Z,FNU,KODE,MR,N,Y,NZ,RL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-779 (DEC 1989). ! ! Original name: CACAI ! ! DGZS17 APPLIES THE ANALYTIC CONTINUATION FORMULA ! ! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) ! MP=PI*MR*CMPLX(0.0,1.0) ! ! TO continue THE K function FROM THE RIGHT HALF TO THE LEFT ! HALF Z PLANE FOR USE WITH S17DGE WHERE FNU=1/3 OR 2/3 AND N=1. ! DGZS17 IS THE SAME AS DLZS17 WITH THE PARTS FOR LARGER ORDERS AND ! RECURRENCE REMOVED. A RECURSIVE CALL TO DLZS17 CAN RESULT IF S17DL ! IS CALLED FROM S17DGE. ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, RL, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CSGN, CSPN, ZN REAL ARG, ASCLE, AZ, CPN, DFNU, FMR, PI, SGN, SPN, YY INTEGER INU, IUF, NN, NW ! .. Local Arrays .. COMPLEX CY(2) ! .. External functions .. REAL X02AME EXTERNAL X02AME ! .. External subroutines .. EXTERNAL DGRS17, DGSS17, DGTS17, DGXS17, DGYS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, INT, MOD, SIGN, SIN ! .. Data statements .. DATA PI/3.14159265358979324E0/ ! .. Executable Statements .. ! NZ = 0 ZN = -Z AZ = ABS(Z) NN = N DFNU = FNU + N - 1 if (AZ > 2.0E0) then if (AZ*AZ*0.25E0 > DFNU+1.0E0) then if (AZ < RL) then ! --------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I ! function ! --------------------------------------------------------- CALL DGTS17(ZN,FNU,KODE,NN,Y,NW,TOL) if (NW < 0) then goto 40 ELSE goto 20 endif ELSE ! --------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I function ! --------------------------------------------------------- CALL DGYS17(ZN,FNU,KODE,NN,Y,NW,RL,TOL,ELIM,ALIM) if (NW < 0) then goto 40 ELSE goto 20 endif endif endif endif ! ------------------------------------------------------------------ ! POWER SERIES FOR THE I function ! ------------------------------------------------------------------ CALL DGRS17(ZN,FNU,KODE,NN,Y,NW,TOL,ELIM,ALIM) ! ------------------------------------------------------------------ ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K function ! ------------------------------------------------------------------ 20 CALL DGXS17(ZN,FNU,KODE,1,CY,NW,TOL,ELIM,ALIM) if (NW == 0) then FMR = MR SGN = -SIGN(PI,FMR) CSGN = CMPLX(0.0E0,SGN) if (KODE /= 1) then YY = -AIMAG(ZN) CPN = COS(YY) SPN = SIN(YY) CSGN = CSGN*CMPLX(CPN,SPN) endif ! --------------------------------------------------------------- ! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE ! --------------------------------------------------------------- INU = INT(FNU) ARG = (FNU-INU)*SGN CPN = COS(ARG) SPN = SIN(ARG) CSPN = CMPLX(CPN,SPN) if (MOD(INU,2) == 1) CSPN = -CSPN C1 = CY(1) C2 = Y(1) if (KODE /= 1) then IUF = 0 ASCLE = (1.0E+3*X02AME())/TOL CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF) NZ = NZ + NW endif Y(1) = CSPN*C1 + CSGN*C2 return endif 40 NZ = -1 if (NW == (-2)) NZ = -2 if (NW == (-3)) NZ = -3 return END subroutine DLYS17(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-782 (DEC 1989). ! ! Original name: CBUNK ! ! DLYS17 COMPUTES THE K BESSEL function FOR FNU>FNUL. ! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) ! IN DCZS18 AND THE EXPANSION FOR H(2,FNU,Z) IN DCYS18 ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. REAL AX, AY, XX, YY ! .. External subroutines .. EXTERNAL DCYS18, DCZS18 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, REAL ! .. Executable Statements .. ! NZ = 0 XX = REAL(Z) YY = AIMAG(Z) AX = ABS(XX)*1.7321E0 AY = ABS(YY) if (AY > AX) then ! --------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 ! --------------------------------------------------------------- CALL DCYS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) ELSE ! --------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 ! --------------------------------------------------------------- CALL DCZS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM) endif return END subroutine DLZS17(Z,FNU,KODE,MR,N,Y,NZ,RL,FNUL,TOL,ELIM,ALIM) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-783 (DEC 1989). ! ! Original name: CACON ! ! DLZS17 APPLIES THE ANALYTIC CONTINUATION FORMULA ! ! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) ! MP=PI*MR*CMPLX(0.0,1.0) ! ! TO continue THE K function FROM THE RIGHT HALF TO THE LEFT ! HALF Z PLANE ! ! .. Scalar Arguments .. COMPLEX Z REAL ALIM, ELIM, FNU, FNUL, RL, TOL INTEGER KODE, MR, N, NZ ! .. Array Arguments .. COMPLEX Y(N) ! .. Local Scalars .. COMPLEX C1, C2, CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, & RZ, S1, S2, SC1, SC2, ST, ZN REAL ARG, AS2, ASCLE, BSCLE, C1I, C1M, C1R, CPN, FMR, & PI, SGN, SPN, YY INTEGER I, INU, IUF, KFLAG, NN, NW ! .. Local Arrays .. COMPLEX CSR(3), CSS(3), CY(2) REAL BRY(3) ! .. External functions .. REAL X02AME, X02ALE EXTERNAL X02AME, X02ALE ! .. External subroutines .. EXTERNAL DEZS17, DGSS17, DGXS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, INT, MAX, MIN, MOD, & REAL, SIGN, SIN ! .. Data statements .. DATA PI/3.14159265358979324E0/ DATA CONE/(1.0E0,0.0E0)/ ! .. Executable Statements .. ! NZ = 0 ZN = -Z NN = N CALL DEZS17(ZN,FNU,KODE,NN,Y,NW,RL,FNUL,TOL,ELIM,ALIM) if (NW >= 0) then ! --------------------------------------------------------------- ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K function ! --------------------------------------------------------------- NN = MIN(2,N) CALL DGXS17(ZN,FNU,KODE,NN,CY,NW,TOL,ELIM,ALIM) if (NW == 0) then S1 = CY(1) FMR = MR SGN = -SIGN(PI,FMR) CSGN = CMPLX(0.0E0,SGN) if (KODE /= 1) then YY = -AIMAG(ZN) CPN = COS(YY) SPN = SIN(YY) CSGN = CSGN*CMPLX(CPN,SPN) endif ! ------------------------------------------------------------ ! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF ! SIGNIFICANCE WHEN FNU IS LARGE ! ------------------------------------------------------------ INU = INT(FNU) ARG = (FNU-INU)*SGN CPN = COS(ARG) SPN = SIN(ARG) CSPN = CMPLX(CPN,SPN) if (MOD(INU,2) == 1) CSPN = -CSPN IUF = 0 C1 = S1 C2 = Y(1) ASCLE = (1.0E+3*X02AME())/TOL if (KODE /= 1) then CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF) NZ = NZ + NW SC1 = C1 endif Y(1) = CSPN*C1 + CSGN*C2 if (N /= 1) then CSPN = -CSPN S2 = CY(2) C1 = S2 C2 = Y(2) if (KODE /= 1) then CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF) NZ = NZ + NW SC2 = C1 endif Y(2) = CSPN*C1 + CSGN*C2 if (N /= 2) then CSPN = -CSPN RZ = CMPLX(2.0E0,0.0E0)/ZN CK = CMPLX(FNU+1.0E0,0.0E0)*RZ ! ------------------------------------------------------ ! SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON ! K functionS ! ------------------------------------------------------ CSCL = CMPLX(1.0E0/TOL,0.0E0) CSCR = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CSCR CSR(1) = CSCR CSR(2) = CONE CSR(3) = CSCL BRY(1) = ASCLE BRY(2) = 1.0E0/ASCLE BRY(3) = X02ALE() AS2 = ABS(S2) KFLAG = 2 if (AS2 <= BRY(1)) then KFLAG = 1 else if (AS2 >= BRY(2)) then KFLAG = 3 endif BSCLE = BRY(KFLAG) S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) CS = CSR(KFLAG) DO 20 I = 3, N ST = S2 S2 = CK*S2 + S1 S1 = ST C1 = S2*CS ST = C1 C2 = Y(I) if (KODE /= 1) then if (IUF >= 0) then CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF) NZ = NZ + NW SC1 = SC2 SC2 = C1 if (IUF == 3) then IUF = -4 S1 = SC1*CSS(KFLAG) S2 = SC2*CSS(KFLAG) ST = SC2 endif endif endif Y(I) = CSPN*C1 + CSGN*C2 CK = CK + RZ CSPN = -CSPN if (KFLAG < 3) then C1R = REAL(C1) C1I = AIMAG(C1) C1R = ABS(C1R) C1I = ABS(C1I) C1M = MAX(C1R,C1I) if (C1M > BSCLE) then KFLAG = KFLAG + 1 BSCLE = BRY(KFLAG) S1 = S1*CS S2 = ST S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) CS = CSR(KFLAG) endif endif 20 continue endif endif return endif endif NZ = -1 if (NW == (-2)) NZ = -2 if (NW == (-3)) NZ = -3 return END INTEGER function P01ABE(IFAIL,IERROR,SRNAME,NREC,REC) ! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. ! MARK 13 REVISED. IER-621 (APR 1988). ! MARK 13B REVISED. IER-668 (AUG 1988). ! ! P01ABE is the error-handling routine for the NAG Library. ! ! P01ABE either returns the value of IERROR through the routine ! name (soft failure), or terminates execution of the program ! (hard failure). Diagnostic messages may be output. ! ! If IERROR = 0 (successful exit from the calling routine), ! the value 0 is returned through the routine name, and no ! message is output ! ! If IERROR is non-zero (abnormal exit from the calling routine), ! the action taken depends on the value of IFAIL. ! ! IFAIL = 1: soft failure, silent exit (i.e. no messages are ! output) ! IFAIL = -1: soft failure, noisy exit (i.e. messages are output) ! IFAIL =-13: soft failure, noisy exit but standard messages from ! P01ABE are suppressed ! IFAIL = 0: hard failure, noisy exit ! ! For compatibility with certain routines included before Mark 12 ! P01ABE also allows an alternative specification of IFAIL in which ! it is regarded as a decimal integer with least significant digits ! cba. Then ! ! a = 0: hard failure a = 1: soft failure ! b = 0: silent exit b = 1: noisy exit ! ! except that hard failure now always implies a noisy exit. ! ! S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. ! ! .. Scalar Arguments .. INTEGER IERROR, IFAIL, NREC CHARACTER*(*) SRNAME ! .. Array Arguments .. CHARACTER*(*) REC(*) ! .. Local Scalars .. INTEGER I, NERR CHARACTER*72 MESS ! .. External subroutines .. EXTERNAL ABZP01, X04AAE, X04BAE ! .. Intrinsic functions .. INTRINSIC ABS, MOD ! .. Executable Statements .. if (IERROR /= 0) then ! Abnormal exit from calling routine if (IFAIL == -1 .or. IFAIL == 0 .or. IFAIL == -13 .or. & (IFAIL > 0 .and. MOD(IFAIL/10,10) /= 0)) then ! Noisy exit CALL X04AAE(0,NERR) DO 20 I = 1, NREC CALL X04BAE(NERR,REC(I)) 20 continue if (IFAIL /= -13) then WRITE (MESS,FMT=99999) SRNAME, IERROR CALL X04BAE(NERR,MESS) if (ABS(MOD(IFAIL,10)) /= 1) then ! Hard failure CALL X04BAE(NERR, & ' ** NAG hard failure - execution terminated' & ) CALL ABZP01 ELSE ! Soft failure CALL X04BAE(NERR, & ' ** NAG soft failure - control returned') endif endif endif endif P01ABE = IERROR return ! 99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', & ' =',I6) END COMPLEX function S01EAE(Z,IFAIL) ! MARK 14 RELEASE. NAG COPYRIGHT 1989. ! returns exp(Z) for complex Z. ! .. Parameters .. REAL ONE, ZERO PARAMETER (ONE=1.0E0,ZERO=0.0E0) CHARACTER*6 SRNAME PARAMETER (SRNAME='S01EAE') ! .. Scalar Arguments .. COMPLEX Z INTEGER IFAIL ! .. Local Scalars .. REAL COSY, EXPX, LNSAFE, RECEPS, RESI, RESR, & RTSAFS, SAFE, SAFSIN, SINY, X, XPLNCY, & XPLNSY, Y INTEGER IER, NREC LOGICAL FIRST ! .. Local Arrays .. CHARACTER*80 REC(2) ! .. External functions .. REAL X02AHE, X02AJE, X02AME INTEGER P01ABE EXTERNAL X02AHE, X02AJE, X02AME, P01ABE ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, & REAL, SIGN, SIN, SQRT ! .. Save statement .. SAVE SAFE, LNSAFE, SAFSIN, RTSAFS, FIRST ! .. Data statements .. DATA FIRST/.true./ ! .. Executable Statements .. if (FIRST) then FIRST = .false. SAFE = ONE/X02AME() LNSAFE = LOG(SAFE) RECEPS = ONE/X02AJE() SAFSIN = MIN(X02AHE(ONE),RECEPS) if (SAFSIN < RECEPS**0.75E0) then ! Assume that SAFSIN is approximately sqrt(RECEPS), in which ! case IFAIL=4 cannot occur. RTSAFS = SAFSIN ELSE ! Set RTSAFS to the argument above which SINE and COSINE will ! return results of less than half precision, assuming that ! SAFSIN is approximately equal to RECEPS. RTSAFS = SQRT(SAFSIN) endif endif NREC = 0 IER = 0 X = REAL(Z) Y = AIMAG(Z) if (ABS(Y) > SAFSIN) then IER = 5 NREC = 2 WRITE (REC,FMT=99995) Z S01EAE = ZERO ELSE COSY = COS(Y) SINY = SIN(Y) if (X > LNSAFE) then if (COSY == ZERO) then RESR = ZERO ELSE XPLNCY = X + LOG(ABS(COSY)) if (XPLNCY > LNSAFE) then IER = 1 RESR = SIGN(SAFE,COSY) ELSE RESR = SIGN(EXP(XPLNCY),COSY) endif endif if (SINY == ZERO) then RESI = ZERO ELSE XPLNSY = X + LOG(ABS(SINY)) if (XPLNSY > LNSAFE) then IER = IER + 2 RESI = SIGN(SAFE,SINY) ELSE RESI = SIGN(EXP(XPLNSY),SINY) endif endif ELSE EXPX = EXP(X) RESR = EXPX*COSY RESI = EXPX*SINY endif S01EAE = CMPLX(RESR,RESI) if (IER == 3) then NREC = 2 WRITE (REC,FMT=99997) Z else if (ABS(Y) > RTSAFS) then IER = 4 NREC = 2 WRITE (REC,FMT=99996) Z else if (IER == 1) then NREC = 2 WRITE (REC,FMT=99999) Z else if (IER == 2) then NREC = 2 WRITE (REC,FMT=99998) Z endif endif IFAIL = P01ABE(IFAIL,IER,SRNAME,NREC,REC) return ! 99999 FORMAT (1X,'** Argument Z causes overflow in real part of result:' & ,/4X,'Z = (',1P,E13.5,',',E13.5,')') 99998 FORMAT (1X,'** Argument Z causes overflow in imaginary part of r', & 'esult:',/4X,'Z = (',1P,E13.5,',',E13.5,')') 99997 FORMAT (1X,'** Argument Z causes overflow in both real and imagi', & 'nary parts of result:',/4X,'Z = (',1P,E13.5,',',E13.5,')') 99996 FORMAT (1X,'** The imaginary part of argument Z is so large that', & ' the result is',/4X,'accurate to less than half precisio', & 'n: Z = (',1P,E13.5,',',E13.5,')') 99995 FORMAT (1X,'** The imaginary part of argument Z is so large that', & ' the result has no',/4X,'precision: Z = (',1P,E13.5,',', & E13.5,')') END REAL function S14ABE(X,IFAIL) ! MARK 8 RELEASE. NAG COPYRIGHT 1979. ! MARK 11.5(F77) REVISED. (SEPT 1985.) ! LNGAMMA(X) function ! ABRAMOWITZ AND STEGUN CH.6 ! ! ************************************************************** ! ! TO EXTRACT THE CORRECT CODE FOR A PARTICULAR MACHINE-RANGE, ! ACTIVATE THE STATEMENTS CONTAINED IN COMMENTS BEGINNING CDD , ! WHERE DD IS THE APPROXIMATE NUMBER OF SIGNIFICANT DECIMAL ! DIGITS REPRESENTED BY THE MACHINE ! DELETE THE ILLEGAL DUMMY STATEMENTS OF THE FORM ! * EXPANSION (NNNN) * ! ! ALSO INSERT APPROPRIATE DATA STATEMENTS TO DEFINE CONSTANTS ! WHICH DEPEND ON THE RANGE OF NUMBERS REPRESENTED BY THE ! MACHINE, RATHER THAN THE PRECISION (SUITABLE STATEMENTS FOR ! SOME MACHINES ARE CONTAINED IN COMMENTS BEGINNING CRD WHERE ! D IS A DIGIT WHICH SIMPLY DISTINGUISHES A GROUP OF MACHINES). ! DELETE THE ILLEGAL DUMMY DATA STATEMENTS WITH VALUES WRITTEN ! *VALUE* ! ! ************************************************************** ! ! IMPLEMENTATION DEPENDENT CONSTANTS ! ! if (X < XSMALL)GAMMA(X)=1/X ! I.E. XSMALL*EULGAM <= XRELPR ! LNGAM(XVBIG)=GBIG <= XOVFLO ! LNR2PI=LN(SQRT(2*PI)) ! if (X>XBIG)LNGAM(X)=(X-0.5)LN(X)-X+LNR2PI ! ! .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='S14ABE') ! .. Scalar Arguments .. REAL X INTEGER IFAIL ! .. Local Scalars .. REAL G, GBIG, LNR2PI, T, XBIG, XSMALL, XVBIG, Y INTEGER I, M ! .. Local Arrays .. CHARACTER*1 P01REC(1) ! .. External functions .. INTEGER P01ABE EXTERNAL P01ABE ! .. Intrinsic functions .. INTRINSIC LOG, REAL ! .. Data statements .. !08 DATA XSMALL,XBIG,LNR2PI/ !08 *1.0E-8,1.2E+3,9.18938533E-1/ !09 DATA XSMALL,XBIG,LNR2PI/ !09 *1.0E-9,4.8E+3,9.189385332E-1/ !12 DATA XSMALL,XBIG,LNR2PI/ !12 *1.0E-12,3.7E+5,9.189385332047E-1/ DATA XSMALL,XBIG,LNR2PI/ & 1.0E-15,6.8E+6,9.189385332046727E-1/ !17 DATA XSMALL,XBIG,LNR2PI/ !17 *1.0E-17,7.7E+7,9.18938533204672742E-1/ !19 DATA XSMALL,XBIG,LNR2PI/ !19 *1.0E-19,3.1E+8,9.189385332046727418E-1/ ! ! RANGE DEPENDENT CONSTANTS ! DK DK DATA XVBIG,GBIG/4.81E+2461,2.72E+2465/ DATA XVBIG,GBIG/4.08E+36,3.40E+38/ ! FOR IEEE SINGLE PRECISION !R0 DATA XVBIG,GBIG/4.08E+36,3.40E+38/ ! FOR IBM 360/370 AND SIMILAR MACHINES !R1 DATA XVBIG,GBIG/4.29E+73,7.231E+75/ ! FOR DEC10, HONEYWELL, UNIVAC 1100 (S.P.) !R2 DATA XVBIG,GBIG/2.05E36,1.69E38/ ! FOR ICL 1900 !R3 DATA XVBIG,GBIG/3.39E+74,5.784E+76/ ! FOR CDC 7600/CYBER !R4 DATA XVBIG,GBIG/1.72E+319,1.26E+322/ ! FOR UNIVAC 1100 (D.P.) !R5 DATA XVBIG,GBIG/1.28E305,8.98E+307/ ! FOR IEEE DOUBLE PRECISION !R7 DATA XVBIG,GBIG/2.54D+305,1.79D+308/ ! .. Executable Statements .. if (X > XSMALL) goto 20 ! VERY SMALL RANGE if (X <= 0.0) goto 160 IFAIL = 0 S14ABE = -LOG(X) goto 200 ! 20 if (X > 15.0) goto 120 ! MAIN SMALL X RANGE M = X T = X - FLOAT(M) M = M - 1 G = 1.0 if (M) 40, 100, 60 40 G = G/X goto 100 60 DO 80 I = 1, M G = (X-FLOAT(I))*G 80 continue 100 T = 2.0*T - 1.0 ! ! * EXPANSION (0026) * ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 08E.09 !08 Y = (((((((((((+1.88278283E-6*T-5.48272091E-6)*T+1.03144033E-5) !08 * *T-3.13088821E-5)*T+1.01593694E-4)*T-2.98340924E-4) !08 * *T+9.15547391E-4)*T-2.42216251E-3)*T+9.04037536E-3) !08 * *T-1.34119055E-2)*T+1.03703361E-1)*T+1.61692007E-2)*T + !08 * 8.86226925E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 09E.10 !09 Y = ((((((((((((-6.463247484E-7*T+1.882782826E-6) !09 * *T-3.382165478E-6)*T+1.031440334E-5)*T-3.393457634E-5) !09 * *T+1.015936944E-4)*T-2.967655076E-4)*T+9.155473906E-4) !09 * *T-2.422622002E-3)*T+9.040375355E-3)*T-1.341184808E-2) !09 * *T+1.037033609E-1)*T+1.616919866E-2)*T + 8.862269255E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 12E.13 !12 Y = ((((((((((((((((-8.965837291520E-9*T+2.612707393536E-8) !12 * *T-3.802866827264E-8)*T+1.173294768947E-7) !12 * *T-4.275076254106E-7)*T+1.276176602829E-6) !12 * *T-3.748495971011E-6)*T+1.123829871408E-5) !12 * *T-3.364018663166E-5)*T+1.009331480887E-4) !12 * *T-2.968895120407E-4)*T+9.157850115110E-4) !12 * *T-2.422595461409E-3)*T+9.040335037321E-3) !12 * *T-1.341185056618E-2)*T+1.037033634184E-1) !12 * *T+1.616919872437E-2)*T + 8.862269254528E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 15E.16 Y = (((((((((((((((-1.243191705600000E-10*T+ & 3.622882508800000E-10)*T-4.030909644800000E-10) & *T+1.265236705280000E-9)*T-5.419466096640000E-9) & *T+1.613133578240000E-8)*T-4.620920340480000E-8) & *T+1.387603440435200E-7)*T-4.179652784537600E-7) & *T+1.253148247777280E-6)*T-3.754930502328320E-6) & *T+1.125234962812416E-5)*T-3.363759801664768E-5) & *T+1.009281733953869E-4)*T-2.968901194293069E-4) & *T+9.157859942174304E-4)*T-2.422595384546340E-3 Y = ((((Y*T+9.040334940477911E-3)*T-1.341185057058971E-2) & *T+1.037033634220705E-1)*T+1.616919872444243E-2)*T + & 8.862269254527580E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 17E.18 !17 Y = (((((((((((((((-1.46381209600000000E-11*T+ !17 * 4.26560716800000000E-11)*T-4.01499750400000000E-11) !17 * *T+1.27679856640000000E-10)*T-6.13513953280000000E-10) !17 * *T+1.82243164160000000E-9)*T-5.11961333760000000E-9) !17 * *T+1.53835215257600000E-8)*T-4.64774927155200000E-8) !17 * *T+1.39383522590720000E-7)*T-4.17808776355840000E-7) !17 * *T+1.25281466396672000E-6)*T-3.75499034136576000E-6) !17 * *T+1.12524642975590400E-5)*T-3.36375833240268800E-5) !17 * *T+1.00928148823365120E-4)*T-2.96890121633200000E-4 !17 Y = ((((((Y*T+9.15785997288933120E-4)*T-2.42259538436268176E-3) !17 * *T+9.04033494028101968E-3)*T-1.34118505705967765E-2) !17 * *T+1.03703363422075456E-1)*T+1.61691987244425092E-2)*T + !17 * 8.86226925452758013E-1 ! ! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 19E.19 !19 Y = (((((((((((((((+6.710886400000000000E-13*T- !19 * 1.677721600000000000E-12)*T+6.710886400000000000E-13) !19 * *T-4.152360960000000000E-12)*T+2.499805184000000000E-11) !19 * *T-6.898581504000000000E-11)*T+1.859597107200000000E-10) !19 * *T-5.676387532800000000E-10)*T+1.725556326400000000E-9) !19 * *T-5.166307737600000000E-9)*T+1.548131827712000000E-8) !19 * *T-4.644574052352000000E-8)*T+1.393195837030400000E-7) !19 * *T-4.178233990758400000E-7)*T+1.252842254950400000E-6) !19 * *T-3.754985815285760000E-6)*T+1.125245651030528000E-5 !19 Y = (((((((((Y*T-3.363758423922688000E-5) !19 * *T+1.009281502108083200E-4) !19 * *T-2.968901215188000000E-4)*T+9.157859971435078400E-4) !19 * *T-2.422595384370689760E-3)*T+9.040334940288877920E-3) !19 * *T-1.341185057059651648E-2)*T+1.037033634220752902E-1) !19 * *T+1.616919872444250674E-2)*T + 8.862269254527580137E-1 ! S14ABE = LOG(Y*G) IFAIL = 0 goto 200 ! 120 if (X > XBIG) goto 140 ! MAIN LARGE X RANGE T = 450.0/(X*X) - 1.0 ! ! * EXPANSION (0059) * ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 08E.09 !08 Y = (+3.89980902E-9*T-6.16502533E-6)*T + 8.33271644E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 09E.10 !09 Y = (+3.899809019E-9*T-6.165025333E-6)*T + 8.332716441E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 12E.13 !12 Y = ((-6.451144077930E-12*T+3.899809018958E-9) !12 * *T-6.165020494506E-6)*T + 8.332716440658E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 15E.16 Y = (((+2.002019273379824E-14*T-6.451144077929628E-12) & *T+3.899788998764847E-9)*T-6.165020494506090E-6)*T + & 8.332716440657866E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 17E.18 !17 Y = ((((-9.94561064728159347E-17*T+2.00201927337982364E-14) !17 * *T-6.45101975779653651E-12)*T+3.89978899876484712E-9) !17 * *T-6.16502049453716986E-6)*T + 8.33271644065786580E-2 ! ! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 19E.19 !19 Y = (((((+7.196406678180202240E-19*T-9.945610647281593472E-17) !19 * *T+2.001911327279650935E-14)*T-6.451019757796536510E-12) !19 * *T+3.899788999169644998E-9)*T-6.165020494537169862E-6)*T + !19 * 8.332716440657865795E-2 ! S14ABE = (X-0.5)*LOG(X) - X + LNR2PI + Y/X IFAIL = 0 goto 200 ! 140 if (X > XVBIG) goto 180 ! ASYMPTOTIC LARGE X RANGE S14ABE = (X-0.5)*LOG(X) - X + LNR2PI IFAIL = 0 goto 200 ! ! FAILURE EXITS 160 IFAIL = P01ABE(IFAIL,1,SRNAME,0,P01REC) S14ABE = 0.0 goto 200 180 IFAIL = P01ABE(IFAIL,2,SRNAME,0,P01REC) S14ABE = GBIG ! 200 return ! END subroutine S17DGE(DERIV,Z,SCALE,AI,NZ,IFAIL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-770 (DEC 1989). ! ! Original name: CAIRY ! ! PURPOSE TO COMPUTE AIRY functionS AI(Z) AND DAI(Z) FOR COMPLEX Z ! ! DESCRIPTION ! =========== ! ! ON SCALE='U', S17DGE COMPUTES THE COMPLEX AIRY function AI(Z) ! OR ITS DERIVATIVE DAI(Z)/DZ ON DERIV='F' OR DERIV='D' ! RESPECTIVELY. ON SCALE='S', A SCALING OPTION ! CEXP(ZTA)*AI(Z) OR CEXP(ZTA)*DAI(Z)/DZ IS PROVIDED TO REMOVE ! THE EXPONENTIAL DECAY IN -PI/3 < ARG(Z) < PI/3 AND THE ! EXPONENTIAL GROWTH IN PI/3 < ABS(ARG(Z)) < PI WHERE ! ZTA=(2/3)*Z*CSQRT(Z) ! ! WHILE THE AIRY functionS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN ! THE WHOLE Z PLANE, THE CORRESPONDING SCALED functionS DEFINED ! FOR SCALE='S' HAVE A CUT ALONG THE NEGATIVE REAL AXIS. ! DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF ! MATHEMATICAL functionS (REF. 1). ! ! INPUT ! Z - Z=CMPLX(X,Y) ! DERIV - return function (DERIV='F') OR DERIVATIVE ! (DERIV='D') ! SCALE - A PARAMETER TO INDICATE THE SCALING OPTION ! SCALE = 'U' OR 'u' returnS ! AI=AI(Z) ON DERIV='F' OR ! AI=DAI(Z)/DZ ON DERIV='D' ! SCALE = 'S' OR 's' returnS ! AI=CEXP(ZTA)*AI(Z) ON DERIV='F' OR ! AI=CEXP(ZTA)*DAI(Z)/DZ ON DERIV='D' WHERE ! ZTA=(2/3)*Z*CSQRT(Z) ! ! OUTPUT ! AI - COMPLEX ANSWER DEPENDING ON THE CHOICES FOR DERIV ! AND SCALE ! NZ - UNDERFLOW INDICATOR ! NZ= 0 , NORMAL return ! NZ= 1 , AI=CMPLX(0.0,0.0) DUE TO UNDERFLOW IN ! -PI/3 < ARG(Z) < PI/3 ON SCALE='U' ! IFAIL - ERROR FLAG ! IFAIL=0, NORMAL return - COMPUTATION COMPLETED ! IFAIL=1, INPUT ERROR - NO COMPUTATION ! IFAIL=2, OVERFLOW - NO COMPUTATION, REAL(ZTA) ! TOO LARGE WITH SCALE = 'U' ! IFAIL=3, CABS(Z) LARGE - COMPUTATION COMPLETED ! LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION ! PRODUCE LESS THAN HALF OF MACHINE ACCURACY ! IFAIL=4, CABS(Z) TOO LARGE - NO COMPUTATION ! COMPLETE LOSS OF ACCURACY BY ARGUMENT ! REDUCTION ! IFAIL=5, ERROR - NO COMPUTATION, ! ALGORITHM TERMINATION CONDITION NOT MET ! ! LONG DESCRIPTION ! ================ ! ! AI AND DAI ARE COMPUTED FOR CABS(Z)>1.0 FROM THE K BESSEL ! functionS BY ! ! AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA) ! C=1.0/(PI*SQRT(3.0)) ! ZTA=(2/3)*Z**(3/2) ! ! WITH THE POWER SERIES FOR CABS(Z) <= 1.0. ! ! IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- ! MENTARY functionS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES ! OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF ! THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), ! THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR ! FLAG IFAIL=3 IS TRIGGERED WHERE UR=X02AJE()=UNIT ROUNDOFF. ! ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN ! ALL SIGNIFICANCE IS LOST AND IFAIL=4. IN ORDER TO USE THE INT ! function, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE ! LARGEST INTEGER, U3=X02BBE(). THUS, THE MAGNITUDE OF ZETA ! MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, ! AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE ! PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE ! PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- ! ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- ! NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN ! DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN ! EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, ! NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE ! PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER ! MACHINES. ! ! THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX ! BESSEL function CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT ! ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- ! SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE ! ELEMENTARY functionS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), ! ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF ! CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY ! HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN ! ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY ! SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER ! THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, ! 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS ! THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER ! COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY ! BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER ! COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE ! MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, ! THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, ! OR -PI/2+P. ! ! REFERENCES ! ========== ! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ ! AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF ! COMMERCE, 1955. ! ! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT ! AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 ! ! A subroutine PACKAGE FOR BESSEL functionS OF A COMPLEX ! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- ! 1018, MAY, 1985 ! ! A PORTABLE PACKAGE FOR BESSEL functionS OF A COMPLEX ! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. ! MATH. SOFTWARE, 1986 ! ! DATE WRITTEN 830501 (YYMMDD) ! REVISION DATE 830501 (YYMMDD) ! AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES ! ! .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='S17DGE') ! .. Scalar Arguments .. COMPLEX AI, Z INTEGER IFAIL, NZ CHARACTER DERIV, SCALE ! .. Local Scalars .. COMPLEX CONE, CSQ, S1, S2, TRM1, TRM2, Z3, ZTA REAL AA, AD, AK, ALAZ, ALIM, ATRM, AZ, AZ3, BB, BK, & C1, C2, CK, COEF, D1, D2, DIG, DK, ELIM, FID, & FNU, R1M5, RL, SAVAA, SFAC, TOL, TTH, Z3I, Z3R, & ZI, ZR INTEGER ID, IERR, IFL, IFLAG, K, K1, K2, KODE, MR, NN, & NREC ! .. Local Arrays .. COMPLEX CY(1) CHARACTER*80 REC(1) ! .. External functions .. COMPLEX S01EAE REAL X02AHE, X02AJE, X02AME INTEGER P01ABE, X02BBE, X02BHE, X02BJE, X02BKE, X02BLE EXTERNAL S01EAE, X02AHE, X02AJE, X02AME, P01ABE, X02BBE, & X02BHE, X02BJE, X02BKE, X02BLE ! .. External subroutines .. EXTERNAL DGXS17, DGZS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, LOG, LOG10, MAX, MIN, REAL, & SQRT ! .. Data statements .. DATA TTH, C1, C2, COEF/6.66666666666666667E-01, & 3.55028053887817240E-01, & 2.58819403792806799E-01, & 1.83776298473930683E-01/ DATA CONE/(1.0E0,0.0E0)/ ! .. Executable Statements .. IERR = 0 NREC = 0 NZ = 0 if (DERIV == 'F' .or. DERIV == 'f') then ID = 0 else if (DERIV == 'D' .or. DERIV == 'd') then ID = 1 ELSE ID = -1 endif if (SCALE == 'U' .or. SCALE == 'u') then KODE = 1 else if (SCALE == 'S' .or. SCALE == 's') then KODE = 2 ELSE KODE = -1 endif if (ID == -1) then IERR = 1 NREC = 1 WRITE (REC,FMT=99999) DERIV else if (KODE == -1) then IERR = 1 NREC = 1 WRITE (REC,FMT=99998) SCALE endif if (IERR == 0) then AZ = ABS(Z) TOL = MAX(X02AJE(),1.0E-18) FID = ID if (AZ > 1.0E0) then ! ------------------------------------------------------------ ! CASE FOR CABS(Z)>1.0 ! ------------------------------------------------------------ FNU = (1.0E0+FID)/3.0E0 ! ------------------------------------------------------------ ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW ! LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM)>EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS ! NEAR UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC ! IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR ! LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! ------------------------------------------------------------ K1 = X02BKE() K2 = X02BLE() R1M5 = LOG10(REAL(X02BHE())) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = X02BJE() - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) RL = 1.2E0*DIG + 3.0E0 ALAZ = LOG(AZ) ! ------------------------------------------------------------ ! TEST FOR RANGE ! ------------------------------------------------------------ AA = 0.5E0/TOL BB = X02BBE(1.0E0)*0.5E0 AA = MIN(AA,BB,X02AHE(1.0E0)) AA = AA**TTH if (AZ > AA) then NZ = 0 IERR = 4 NREC = 1 WRITE (REC,FMT=99997) AZ, AA ELSE AA = SQRT(AA) SAVAA = AA if (AZ > AA) then IERR = 3 NREC = 1 WRITE (REC,FMT=99996) AZ, AA endif CSQ = SQRT(Z) ZTA = Z*CSQ*CMPLX(TTH,0.0E0) ! --------------------------------------------------------- ! RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS ! SMALL ! --------------------------------------------------------- IFLAG = 0 SFAC = 1.0E0 ZI = AIMAG(Z) ZR = REAL(Z) AK = AIMAG(ZTA) if (ZR < 0.0E0) then BK = REAL(ZTA) CK = -ABS(BK) ZTA = CMPLX(CK,AK) endif if (ZI == 0.0E0) then if (ZR <= 0.0E0) ZTA = CMPLX(0.0E0,AK) endif AA = REAL(ZTA) if (AA >= 0.0E0 .and. ZR > 0.0E0) then if (KODE /= 2) then ! --------------------------------------------------- ! UNDERFLOW TEST ! --------------------------------------------------- if (AA >= ALIM) then AA = -AA - 0.25E0*ALAZ IFLAG = 2 SFAC = 1.0E0/TOL if (AA < (-ELIM)) then NZ = 1 AI = CMPLX(0.0E0,0.0E0) IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif endif endif CALL DGXS17(ZTA,FNU,KODE,1,CY,NZ,TOL,ELIM,ALIM) ELSE if (KODE /= 2) then ! --------------------------------------------------- ! OVERFLOW TEST ! --------------------------------------------------- if (AA <= (-ALIM)) then AA = -AA + 0.25E0*ALAZ IFLAG = 1 SFAC = TOL if (AA > ELIM) goto 20 endif endif ! ------------------------------------------------------ ! DGXS17 AND DGZS17 return EXP(ZTA)*K(FNU,ZTA) ON KODE=2 ! ------------------------------------------------------ MR = 1 if (ZI < 0.0E0) MR = -1 CALL DGZS17(ZTA,FNU,KODE,MR,1,CY,NN,RL,TOL,ELIM,ALIM) if (NN >= 0) then NZ = NZ + NN goto 40 else if (NN == (-3)) then NZ = 0 IERR = 4 NREC = 1 WRITE (REC,FMT=99997) AZ, SAVAA IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return else if (NN /= (-1)) then NZ = 0 IERR = 5 NREC = 1 WRITE (REC,FMT=99995) IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif 20 NZ = 0 IERR = 2 NREC = 1 WRITE (REC,FMT=99994) IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif 40 S1 = CY(1)*CMPLX(COEF,0.0E0) if (IFLAG /= 0) then S1 = S1*CMPLX(SFAC,0.0E0) if (ID == 1) then S1 = -S1*Z AI = S1*CMPLX(1.0E0/SFAC,0.0E0) ELSE S1 = S1*CSQ AI = S1*CMPLX(1.0E0/SFAC,0.0E0) endif else if (ID == 1) then AI = -Z*S1 ELSE AI = CSQ*S1 endif endif ELSE ! ------------------------------------------------------------ ! POWER SERIES FOR CABS(Z) <= 1. ! ------------------------------------------------------------ S1 = CONE S2 = CONE if (AZ < TOL) then AA = 1.0E+3*X02AME() S1 = CMPLX(0.0E0,0.0E0) if (ID == 1) then AI = -CMPLX(C2,0.0E0) AA = SQRT(AA) if (AZ > AA) S1 = Z*Z*CMPLX(0.5E0,0.0E0) AI = AI + S1*CMPLX(C1,0.0E0) ELSE if (AZ > AA) S1 = CMPLX(C2,0.0E0)*Z AI = CMPLX(C1,0.0E0) - S1 endif ELSE AA = AZ*AZ if (AA >= TOL/AZ) then TRM1 = CONE TRM2 = CONE ATRM = 1.0E0 Z3 = Z*Z*Z AZ3 = AZ*AA AK = 2.0E0 + FID BK = 3.0E0 - FID - FID CK = 4.0E0 - FID DK = 3.0E0 + FID + FID D1 = AK*DK D2 = BK*CK AD = MIN(D1,D2) AK = 24.0E0 + 9.0E0*FID BK = 30.0E0 - 9.0E0*FID Z3R = REAL(Z3) Z3I = AIMAG(Z3) DO 60 K = 1, 25 TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) S1 = S1 + TRM1 TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) S2 = S2 + TRM2 ATRM = ATRM*AZ3/AD D1 = D1 + AK D2 = D2 + BK AD = MIN(D1,D2) if (ATRM < TOL*AD) then goto 80 ELSE AK = AK + 18.0E0 BK = BK + 18.0E0 endif 60 continue endif 80 if (ID == 1) then AI = -S2*CMPLX(C2,0.0E0) if (AZ > TOL) AI = AI + Z*Z*S1*CMPLX(C1/(1.0E0+FID), & 0.0E0) if (KODE /= 1) then ZTA = Z*SQRT(Z)*CMPLX(TTH,0.0E0) ! AI = AI*EXP(ZTA) IFL = 1 AI = AI*S01EAE(ZTA,IFL) endif ELSE AI = S1*CMPLX(C1,0.0E0) - Z*S2*CMPLX(C2,0.0E0) if (KODE /= 1) then ZTA = Z*SQRT(Z)*CMPLX(TTH,0.0E0) ! AI = AI*EXP(ZTA) IFL = 1 AI = AI*S01EAE(ZTA,IFL) endif endif endif endif endif IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return ! 99999 FORMAT (1X,'** On entry, DERIV has illegal value: DERIV = ''',A, & '''') 99998 FORMAT (1X,'** On entry, SCALE has illegal value: SCALE = ''',A, & '''') 99997 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' > ', & E13.5) 99996 FORMAT (1X,'** Results lack precision because abs(Z) =',1P,E13.5, & ' > ',E13.5) 99995 FORMAT (1X,'** No computation - algorithm termination condition ', & 'not met.') 99994 FORMAT (1X,'** No computation because real(ZTA) too large, where', & ' ZTA = (2/3)*Z**(3/2).') END subroutine S17DLE(M,FNU,Z,N,SCALE,CY,NZ,IFAIL) ! MARK 13 RELEASE. NAG COPYRIGHT 1988. ! MARK 14 REVISED. IER-781 (DEC 1989). ! ! Original name: CBESH ! ! PURPOSE TO COMPUTE THE H-BESSEL functionS OF A COMPLEX ARGUMENT ! ! DESCRIPTION ! =========== ! ! ON SCALE='U', S17DLE COMPUTES AN N MEMBER SEQUENCE OF COMPLEX ! HANKEL (BESSEL) functionS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 ! OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX ! Z /= CMPLX(0.0E0,0.0E0) IN THE CUT PLANE -PI < ARG(Z) <= PI. ! ON SCALE='S', S17DLE COMPUTES THE SCALED HANKEL functionS ! ! CY(I)=H(M,FNU+J-1,Z)*EXP(-MM*Z*I) MM=3-2M, I**2=-1. ! ! WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER ! AND LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN ! THE NBS HANDBOOK OF MATHEMATICAL functionS (REF. 1). ! ! INPUT ! Z - Z=CMPLX(X,Y), Z /= CMPLX(0.,0.),-PI < ARG(Z) <= PI ! FNU - ORDER OF INITIAL H function, FNU >= 0.0E0 ! SCALE - A PARAMETER TO INDICATE THE SCALING OPTION ! SCALE = 'U' OR SCALE = 'u' returnS ! CY(J)=H(M,FNU+J-1,Z), J=1,...,N ! = 'S' OR SCALE = 's' returnS ! CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) ! J=1,...,N , I**2=-1 ! M - KIND OF HANKEL function, M=1 OR 2 ! N - NUMBER OF MEMBERS OF THE SEQUENCE, N >= 1 ! ! OUTPUT ! CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN ! VALUES FOR THE SEQUENCE ! CY(J)=H(M,FNU+J-1,Z) OR ! CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N ! DEPENDING ON SCALE, I**2=-1. ! NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, ! NZ= 0 , NORMAL return ! NZ>0 , FIRST NZ COMPONENTS OF CY SET TO ZERO ! DUE TO UNDERFLOW, CY(J)=CMPLX(0.0,0.0) ! J=1,...,NZ WHEN Y>0.0 AND M=1 OR ! Y < 0.0 AND M=2. FOR THE COMPLMENTARY ! HALF PLANES, NZ STATES ONLY THE NUMBER ! OF UNDERFLOWS. ! IERR -ERROR FLAG ! IERR=0, NORMAL return - COMPUTATION COMPLETED ! IERR=1, INPUT ERROR - NO COMPUTATION ! IERR=2, OVERFLOW - NO COMPUTATION, ! CABS(Z) TOO SMALL ! IERR=3 OVERFLOW - NO COMPUTATION, ! FNU+N-1 TOO LARGE ! IERR=4, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE ! BUT LOSSES OF SIGNIFCANCE BY ARGUMENT ! REDUCTION PRODUCE LESS THAN HALF OF MACHINE ! ACCURACY ! IERR=5, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- ! TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- ! CANCE BY ARGUMENT REDUCTION ! IERR=6, ERROR - NO COMPUTATION, ! ALGORITHM TERMINATION CONDITION NOT MET ! ! LONG DESCRIPTION ! ================ ! ! THE COMPUTATION IS CARRIED OUT BY THE RELATION ! ! H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP)) ! MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1 ! ! FOR M=1 OR 2 WHERE THE K BESSEL function IS COMPUTED FOR THE ! RIGHT HALF PLANE RE(Z) >= 0.0. THE K function IS continueD ! TO THE LEFT HALF PLANE BY THE RELATION ! ! K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) ! MP=MR*PI*I, MR=+1 OR -1, RE(Z)>0, I**2=-1 ! ! WHERE I(FNU,Z) IS THE I BESSEL function. ! ! EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z ! PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL ! GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING ! BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE ! WHOLE Z PLANE FOR Z TO INFINITY. ! ! FOR NEGATIVE ORDERS,THE FORMULAE ! ! H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I) ! H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) ! I**2=-1 ! ! CAN BE USED. ! ! IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- ! MENTARY functionS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS ! LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. ! CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN ! LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG ! IERR=4 IS TRIGGERED WHERE UR=X02AJE()=UNIT ROUNDOFF. ALSO ! IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS ! LOST AND IERR=5. IN ORDER TO USE THE INT function, ARGUMENTS ! MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE ! INTEGER, U3=X02BBE(). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS ! RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 ! ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION ! ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION ! ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN ! THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT ! TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS ! IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. ! SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. ! ! THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX ! BESSEL function CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT ! ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- ! SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE ! ELEMENTARY functionS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), ! ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF ! CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY ! HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN ! ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY ! SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER ! THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, ! 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS ! THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER ! COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY ! BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER ! COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE ! MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, ! THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, ! OR -PI/2+P. ! ! REFERENCES ! ========== ! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ ! AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF ! COMMERCE, 1955. ! ! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT ! BY D. E. AMOS, SAND83-0083, MAY, 1983. ! ! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT ! AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 ! ! A subroutine PACKAGE FOR BESSEL functionS OF A COMPLEX ! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- ! 1018, MAY, 1985 ! ! A PORTABLE PACKAGE FOR BESSEL functionS OF A COMPLEX ! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. ! MATH. SOFTWARE, 1986 ! ! DATE WRITTEN 830501 (YYMMDD) ! REVISION DATE 830501 (YYMMDD) ! AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES ! ! .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='S17DLE') ! .. Scalar Arguments .. COMPLEX Z REAL FNU INTEGER IFAIL, M, N, NZ CHARACTER*1 SCALE ! .. Array Arguments .. COMPLEX CY(N) ! .. Local Scalars .. COMPLEX CSGN, ZN, ZT REAL AA, ALIM, ALN, ARG, ASCLE, ATOL, AZ, BB, CPN, & DIG, ELIM, FMM, FN, FNUL, HPI, R1M5, RHPI, RL, & RTOL, SGN, SPN, TOL, UFL, XN, XX, YN, YY INTEGER I, IERR, INU, INUH, IR, K, K1, K2, KODE, MM, MR, & NN, NREC, NUF, NW ! .. Local Arrays .. CHARACTER*80 REC(1) ! .. External functions .. REAL X02AHE, X02AJE INTEGER P01ABE, X02BBE, X02BHE, X02BJE, X02BKE, X02BLE EXTERNAL X02AHE, X02AJE, P01ABE, X02BBE, X02BHE, X02BJE, & X02BKE, X02BLE ! .. External subroutines .. EXTERNAL DEVS17, DGXS17, DLYS17, DLZS17 ! .. Intrinsic functions .. INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, LOG, LOG10, & MAX, MIN, MOD, REAL, SIGN, SIN, SQRT ! .. Data statements .. ! DATA HPI/1.57079632679489662E0/ ! .. Executable Statements .. NZ = 0 NREC = 0 XX = REAL(Z) YY = AIMAG(Z) IERR = 0 if (SCALE == 'U' .or. SCALE == 'u') then KODE = 1 else if (SCALE == 'S' .or. SCALE == 's') then KODE = 2 ELSE KODE = -1 endif if (XX == 0.0E0 .and. YY == 0.0E0) then IERR = 1 NREC = 1 WRITE (REC,FMT=99999) else if (FNU < 0.0E0) then IERR = 1 NREC = 1 WRITE (REC,FMT=99998) FNU else if (KODE == -1) then IERR = 1 NREC = 1 WRITE (REC,FMT=99997) SCALE else if (N < 1) then IERR = 1 NREC = 1 WRITE (REC,FMT=99996) N else if (M < 1 .or. M > 2) then IERR = 1 NREC = 1 WRITE (REC,FMT=99995) M endif if (IERR == 0) then NN = N ! --------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM)>EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR ! LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE ! FNU ! --------------------------------------------------------------- TOL = MAX(X02AJE(),1.0E-18) K1 = X02BKE() K2 = X02BLE() R1M5 = LOG10(REAL(X02BHE())) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = X02BJE() - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) RL = 1.2E0*DIG + 3.0E0 FN = FNU + NN - 1 MM = 3 - M - M FMM = MM ZN = Z*CMPLX(0.0E0,-FMM) XN = REAL(ZN) YN = AIMAG(ZN) AZ = ABS(Z) ! --------------------------------------------------------------- ! TEST FOR RANGE ! --------------------------------------------------------------- AA = 0.5E0/TOL BB = X02BBE(1.0E0)*0.5E0 AA = MIN(AA,BB,X02AHE(1.0E0)) if (AZ <= AA) then if (FN <= AA) then AA = SQRT(AA) if (AZ > AA) then IERR = 4 NREC = 1 WRITE (REC,FMT=99994) AZ, AA else if (FN > AA) then IERR = 4 NREC = 1 WRITE (REC,FMT=99993) FN, AA endif ! --------------------------------------------------------- ! OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE ! --------------------------------------------------------- UFL = EXP(-ELIM) if (AZ >= UFL) then if (FNU > FNUL) then ! --------------------------------------------------- ! UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU>FNUL ! --------------------------------------------------- MR = 0 if ((XN < 0.0E0) .or. (XN == 0.0E0 .and. YN <& 0.0E0 .and. M == 2)) then MR = -MM if (XN == 0.0E0 .and. YN < 0.0E0) ZN = -ZN endif CALL DLYS17(ZN,FNU,KODE,MR,NN,CY,NW,TOL,ELIM,ALIM) if (NW < 0) then goto 40 ELSE NZ = NZ + NW endif ELSE if (FN > 1.0E0) then if (FN > 2.0E0) then CALL DEVS17(ZN,FNU,KODE,2,NN,CY,NUF,TOL,ELIM, & ALIM) if (NUF < 0) then goto 60 ELSE NZ = NZ + NUF NN = NN - NUF ! ------------------------------------------ ! HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ! ON return FROM DEVS17 ! IF NUF=NN, THEN CY(I)=CZERO FOR ALL I ! ------------------------------------------ if (NN == 0) then if (XN < 0.0E0) then goto 60 ELSE IFAIL = P01ABE(IFAIL,IERR,SRNAME, & NREC,REC) return endif endif endif else if (AZ <= TOL) then ARG = 0.5E0*AZ ALN = -FN*LOG(ARG) if (ALN > ELIM) goto 60 endif endif if ((XN < 0.0E0) .or. (XN == 0.0E0 .and. YN <& 0.0E0 .and. M == 2)) then ! ------------------------------------------------ ! LEFT HALF PLANE COMPUTATION ! ------------------------------------------------ MR = -MM CALL DLZS17(ZN,FNU,KODE,MR,NN,CY,NW,RL,FNUL,TOL, & ELIM,ALIM) if (NW < 0) then goto 40 ELSE NZ = NW endif ELSE ! ------------------------------------------------ ! RIGHT HALF PLANE COMPUTATION, XN >= 0. .and. ! (XN /= 0. .or. YN >= 0. .or. M=1) ! ------------------------------------------------ CALL DGXS17(ZN,FNU,KODE,NN,CY,NZ,TOL,ELIM,ALIM) endif endif ! ------------------------------------------------------ ! H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) ! ! ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 ! ------------------------------------------------------ SGN = SIGN(HPI,-FMM) ! ------------------------------------------------------ ! CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF ! SIGNIFICANCE WHEN FNU IS LARGE ! ------------------------------------------------------ INU = INT(FNU) INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-INU+IR)*SGN RHPI = 1.0E0/SGN CPN = RHPI*COS(ARG) SPN = RHPI*SIN(ARG) ! ZN = CMPLX(-SPN,CPN) CSGN = CMPLX(-SPN,CPN) ! if (MOD(INUH,2)==1) ZN = -ZN if (MOD(INUH,2) == 1) CSGN = -CSGN ZT = CMPLX(0.0E0,-FMM) RTOL = 1.0E0/TOL ASCLE = UFL*RTOL DO 20 I = 1, NN ! CY(I) = CY(I)*ZN ! ZN = ZN*ZT ZN = CY(I) AA = REAL(ZN) BB = AIMAG(ZN) ATOL = 1.0E0 if (MAX(ABS(AA),ABS(BB)) <= ASCLE) then ZN = ZN*RTOL ATOL = TOL endif ZN = ZN*CSGN CY(I) = ZN*ATOL CSGN = CSGN*ZT 20 continue IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return 40 if (NW == (-3)) then NZ = 0 IERR = 5 NREC = 1 WRITE (REC,FMT=99988) AZ, AA IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return else if (NW /= (-1)) then NZ = 0 IERR = 6 NREC = 1 WRITE (REC,FMT=99992) IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif 60 IERR = 3 NZ = 0 NREC = 1 WRITE (REC,FMT=99991) FN IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return ELSE IERR = 2 NZ = 0 NREC = 1 WRITE (REC,FMT=99990) AZ, UFL IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return endif ELSE NZ = 0 IERR = 5 NREC = 1 WRITE (REC,FMT=99989) FN, AA endif ELSE NZ = 0 IERR = 5 NREC = 1 WRITE (REC,FMT=99988) AZ, AA endif endif IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC) return ! 99999 FORMAT (1X,'** On entry, Z = (0.0,0.0)') 99998 FORMAT (1X,'** On entry, FNU < 0: FNU = ',E13.5) 99997 FORMAT (1X,'** On entry, SCALE has an illegal value: SCALE = ''', & A,'''') 99996 FORMAT (1X,'** On entry, N <= 0: N = ',I16) 99995 FORMAT (1X,'** On entry, M has illegal value: M = ',I16) 99994 FORMAT (1X,'** Results lack precision because abs(Z) =',1P,E13.5, & ' > ',E13.5) 99993 FORMAT (1X,'** Results lack precision, FNU+N-1 =',1P,E13.5, & ' > ',E13.5) 99992 FORMAT (1X,'** No computation - algorithm termination condition ', & 'not met.') 99991 FORMAT (1X,'** No computation because FNU+N-1 =',1P,E13.5,' is t', & 'oo large.') 99990 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' < ', & E13.5) 99989 FORMAT (1X,'** No computation because FNU+N-1 =',1P,E13.5,' > ', & E13.5) 99988 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' > ', & E13.5) END REAL function X02AHE(X) ! MARK 9 RELEASE. NAG COPYRIGHT 1981. ! MARK 11.5(F77) REVISED. (SEPT 1985.) ! ! * MAXIMUM ARGUMENT FOR SIN AND COS * ! returnS THE LARGEST POSITIVE REAL NUMBER MAXSC SUCH THAT ! SIN(MAXSC) AND COS(MAXSC) CAN BE SUCCESSFULLY COMPUTED ! BY THE COMPILER SUPPLIED SIN AND COS ROUTINES. ! ! .. Scalar Arguments .. REAL X REAL CONX02 DATA CONX02 /1.677721600000E+7 / ! .. Executable Statements .. X02AHE = CONX02 return END REAL function X02AJE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS (1/2)*B**(1-P) IF ROUNDS IS .true. ! returnS B**(1-P) OTHERWISE ! REAL CONX02 DATA CONX02 /1.4210854715202E-14 / !bc DATA CONX02 /1.421090000020E-14 / ! .. Executable Statements .. X02AJE = CONX02 return END REAL function X02ALE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS (1 - B**(-P)) * B**EMAX (THE LARGEST POSITIVE MODEL ! NUMBER) ! REAL CONX02 ! DK DK DK DATA CONX02 /0577757777777777777777B / DATA CONX02 /1.e30/ ! .. Executable Statements .. X02ALE = CONX02 return END REAL function X02AME() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE 'SAFE RANGE' PARAMETER ! I.E. THE SMALLEST POSITIVE MODEL NUMBER Z SUCH THAT ! FOR ANY X WHICH SATISFIES X >= Z AND X <= 1/Z ! THE FOLLOWING CAN BE COMPUTED WITHOUT OVERFLOW, UNDERFLOW OR OTHER ! ERROR ! ! -X ! 1.0/X ! SQRT(X) ! LOG(X) ! EXP(LOG(X)) ! Y**(LOG(X)/LOG(Y)) FOR ANY Y ! REAL CONX02 ! DK DK DK DATA CONX02 /0200044000000000000004B / DATA CONX02 /1.e-27/ ! .. Executable Statements .. X02AME = CONX02 return END REAL function X02ANE() ! MARK 15 RELEASE. NAG COPYRIGHT 1991. ! ! returns the 'safe range' parameter for complex numbers, ! i.e. the smallest positive model number Z such that ! for any X which satisfies X >= Z and X <= 1/Z ! the following can be computed without overflow, underflow or other ! error ! ! -W ! 1.0/W ! SQRT(W) ! LOG(W) ! EXP(LOG(W)) ! Y**(LOG(W)/LOG(Y)) for any Y ! ABS(W) ! ! where W is any of cmplx(X,0), cmplx(0,X), cmplx(X,X), ! cmplx(1/X,0), cmplx(0,1/X), cmplx(1/X,1/X). ! REAL CONX02 !bc DATA CONX02 /0000006220426276611547B / !! DK DK DATA CONX02 / 2.708212596942E-1233 / DATA CONX02 / 2.708212596942E-30 / ! .. Executable Statements .. X02ANE = CONX02 return END INTEGER function X02BBE(X) ! NAG COPYRIGHT 1975 ! MARK 4.5 RELEASE ! MARK 11.5(F77) REVISED. (SEPT 1985.) ! * MAXINT * ! returnS THE LARGEST INTEGER REPRESENTABLE ON THE COMPUTER ! THE X PARAMETER IS NOT USED ! .. Scalar Arguments .. REAL X ! .. Executable Statements .. ! FOR ICL 1900 ! X02BBE = 8388607 ! DK DK DK X02BBE = 70368744177663 X02BBE = 744177663 return END INTEGER function X02BHE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE MODEL PARAMETER, B. ! ! .. Executable Statements .. X02BHE = 2 return END INTEGER function X02BJE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE MODEL PARAMETER, p. ! ! .. Executable Statements .. X02BJE = 47 return END INTEGER function X02BKE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE MODEL PARAMETER, EMIN. ! ! .. Executable Statements .. X02BKE = -8192 return END INTEGER function X02BLE() ! MARK 12 RELEASE. NAG COPYRIGHT 1986. ! ! returnS THE MODEL PARAMETER, EMAX. ! ! .. Executable Statements .. X02BLE = 8189 return END subroutine X04AAE(I,NERR) ! MARK 7 RELEASE. NAG COPYRIGHT 1978 ! MARK 7C REVISED IER-190 (MAY 1979) ! MARK 11.5(F77) REVISED. (SEPT 1985.) ! MARK 14 REVISED. IER-829 (DEC 1989). ! IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER ! (STORED IN NERR1). ! IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO ! VALUE SPECIFIED BY NERR. ! ! .. Scalar Arguments .. INTEGER I, NERR ! .. Local Scalars .. INTEGER NERR1 ! .. Save statement .. SAVE NERR1 ! .. Data statements .. DATA NERR1/0/ ! .. Executable Statements .. if (I == 0) NERR = NERR1 if (I == 1) NERR1 = NERR return END subroutine X04BAE(NOUT,REC) ! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. ! ! X04BAE writes the contents of REC to the unit defined by NOUT. ! ! Trailing blanks are not output, except that if REC is entirely ! blank, a single blank character is output. ! If NOUT < 0, i.e. if NOUT is not a valid Fortran unit identifier, ! then no output occurs. ! ! .. Scalar Arguments .. INTEGER NOUT CHARACTER*(*) REC ! .. Local Scalars .. INTEGER I ! .. Intrinsic functions .. INTRINSIC LEN ! .. Executable Statements .. if (NOUT >= 0) then ! Remove trailing blanks DO 20 I = LEN(REC), 2, -1 if (REC(I:I) /= ' ') goto 40 20 continue ! Write record to external file 40 WRITE (NOUT,FMT=99999) REC(1:I) endif return ! 99999 FORMAT (A) END ================================================ FILE: attenuation_model_with_SolvOpt.f90 ================================================ ! use of SolvOpt to compute attenuation relaxation mechanisms, ! from Emilie Blanc, Bruno Lombard and Dimitri Komatitsch, CNRS Marseille, France, for a Generalized Zener body model. ! The SolvOpt algorithm was developed by Franz Kappel and Alexei V. Kuntsevich ! and is available open source at http://www.uni-graz.at/imawww/kuntsevich/solvopt ! ! It is described in Kappel and Kuntsevich, An Implementation of Shor's r-Algorithm, ! Computational Optimization and Applications, vol. 15, p. 193-205 (2000). ! If you use this code for your own research, please cite some (or all) of these articles: ! ! @Article{BlKoChLoXi15, ! Title = {Positivity-preserving highly-accurate optimization of the {Z}ener viscoelastic model, with application ! to wave propagation in the presence of strong attenuation}, ! Author = {\'Emilie Blanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard and Zhinan Xie}, ! Journal = {Geophysical Journal International}, ! Year = {2015}, ! Note = {in press.}} !------------------------------------------------------------------------- ! From Bruno Lombard, May 2014: ! En interne dans le code ci-dessous on travaille en (Theta, Kappa). ! Les Theta sont les points et les Kappa sont les poids. ! Pour repasser en (Tau_Sigma, Tau_Epsilon), on doit appliquer les formules: ! ! Tau_Sigma = 1 / Theta ! Tau_Epsilon = (1 / Theta) * (1 + Nrelax * Kappa) = Tau_Sigma * (1 + Nrelax * Kappa) ! The system to solve can be found in equation (7) of: ! Lombard and Piraux, Numerical modeling of transient two-dimensional viscoelastic waves, ! Journal of Computational Physics, Volume 230, Issue 15, Pages 6099-6114 (2011) ! Suivant les compilateurs et les options de compilation utilisees, ! il peut y avoir des differences au 4eme chiffre significatif. C'est sans consequences sur la precision du calcul : ! l'erreur est de 0.015 % avec optimization non lineaire, a comparer a 1.47 % avec Emmerich and Korn (1987). ! Si je relance le calcul en initialisant avec le resultat precedent, ce chiffre varie a nouveau tres legerement. !------------------------------------------------------------------------- ! From Bruno Lombard, June 2014: ! j'ai relu en detail : ! [1] Carcione, Kosslof, Kosslof, "Viscoacoustic wave propagation simulation in the Earth", ! Geophysics 53-6 (1988), 769-777 ! ! [2] Carcione, Kosslof, Kosslof, "Wave propagation simulation in a linear viscoelastic medium", ! Geophysical Journal International 95 (1988), 597-611 ! ! [3] Moczo, Kristek, "On the rheological models used for time-domain methods of seismic wave propagation", ! Geophysical Research Letters 32 (2005). ! Le probleme provient probablement d'une erreur recurrente dans [1,2] et datant de Liu et al 1976 : ! l'oubli du facteur 1/N dans la fonction de relaxation d'un modele de Zener a N elements. ! Il est effectivement facile de faire l'erreur. Voir l'equation (12) de [3], et le paragraphe qui suit. ! Du coup le module de viscoelasticite est faux dans [1,2], et donc le facteur de qualite, ! et donc les temps de relaxation tau_sigma... ! Apres, [2] calcule une solution analytique juste, mais avec des coefficients sans sens physique. ! Et quand SPECFEM2D obtient un bon accord avec cette solution analytique, ca valide SPECFEM, mais pas le calcul des coefficients. ! Il y a donc une erreur dans [1,2], et [3] a raison. ! Sa solution analytique decoule d'un travail sur ses fonctions de relaxation (A4), ! qu'il injecte ensuite dans la relation de comportement (A1) et travaille en Fourier. ! Le probleme est que sa fonction de relaxation (A4) est fausse : il manque 1/N. ! De ce fait, sa solution analytique est coherente avec sa solution numerique. ! Dans les deux cas, ce sont les memes temps de relaxation qui sont utilises. Mais ces temps sont calcules de facon erronee. !------------------------------------------------------------------------- ! From Dimitri Komatitsch, June 2014: ! In [2] Carcione, Kosslof, Kosslof, "Wave propagation simulation in a linear viscoelastic medium", ! Geophysical Journal International 95 (1988), 597-611 ! there is another mistake: in Appendix B page 611 Carcione writes omega/(r*v), ! but that is not correct, it should be omega*r/v instead. !--------------------------------------------------- ! From Emilie Blanc, April 2014: ! le programme SolvOpt d'optimization non-lineaire ! avec contrainte. Ce programme prend quatre fonctions en entree : ! - fun() est la fonction a minimiser ! - grad() est le gradient de la fonction a minimiser par rapport a chaque parametre ! - func() est le maximum des residus (= 0 si toutes les contraintes sont satisfaites) ! - gradc() est le gradient du maximum des residus (= 0 si toutes les ! contraintes sont satisfaites) ! Ce programme a ete developpe par Kappel et Kuntsevich. Leur article decrit l'algorithme. ! J'ai utilise ce code pour la poroelasticite haute-frequence, et aussi en ! viscoelasticite fractionnaire (modele d'Andrade, avec Bruno Lombard et ! Cedric Bellis). Nous pouvons interagir sur l'algorithme d'optimization ! pour votre modele visco, et etudier l'effet des coefficients ainsi obtenus. !--------------------------------------------------- ! From Emilie Blanc, March 2014: ! Les entrees du programme principal sont le nombre de variables ! diffusives, le facteur de qualite voulu Qref et la frequence centrale f0. ! Cependant, pour l'optimization non-lineaire, j'ai mis theta_max=100*f0 ! et non pas theta_max=2*pi*100*f0. En effet, dans le programme, on ! travaille sur les frequences, et non pas sur les frequences angulaires. ! Cela dit, dans les deux cas j'obtiens les memes coefficients... !--------------------------------------------------- subroutine compute_attenuation_coeffs(N,Qref,f0,f_min,f_max,tau_epsilon,tau_sigma) implicit none ! pi double precision, parameter :: PI = 3.141592653589793d0 double precision, parameter :: TWO_PI = 2.d0 * PI integer, intent(in) :: N double precision, intent(in) :: Qref,f_min,f_max,f0 double precision, dimension(1:N), intent(out) :: tau_epsilon,tau_sigma integer i double precision, dimension(1:N) :: point,weight ! nonlinear optimization with constraints call nonlinear_optimization(N,Qref,f0,point,weight,f_min,f_max) do i = 1,N tau_sigma(i) = 1.d0 / point(i) tau_epsilon(i) = tau_sigma(i) * (1.d0 + N * weight(i)) enddo ! print *,'points = ' ! do i = 1,N ! print *,point(i) ! enddo ! print * ! print *,'weights = ' ! do i = 1,N ! print *,weight(i) ! enddo ! print * print *,'tau_epsilon computed by SolvOpt() = ' do i = 1,N print *,tau_epsilon(i) enddo print * print *,'tau_sigma computed by SolvOpt() = ' do i = 1,N print *,tau_sigma(i) enddo print * end subroutine compute_attenuation_coeffs !--------------------------------------------------- ! classical calculation of the coefficients based on linear least squares subroutine decomposition_LU(a,i_min,n,indx,d) implicit none integer, intent(in) :: i_min,n double precision, intent(out) :: d integer, dimension(i_min:n), intent(inout) :: indx double precision, dimension(i_min:n,i_min:n), intent(inout) :: a integer i,imax,j,k double precision big,dum,somme,eps double precision, dimension(i_min:n) :: vv imax = 0 d = 1. eps = 1.e-20 do i = i_min,n big = 0. do j = i_min,n if (abs(a(i,j)) > big) then big = abs(a(i,j)) endif enddo if (big == 0.) then print *,'Singular matrix in routine decomposition_LU' endif vv(i) = 1./big enddo do j = i_min,n do i = i_min,j-1 somme = a(i,j) do k = i_min,i-1 somme = somme - a(i,k)*a(k,j) enddo a(i,j) = somme enddo big = 0. do i = j,n somme = a(i,j) do k = i_min,j-1 somme = somme - a(i,k)*a(k,j) enddo a(i,j) = somme dum = vv(i)*abs(somme) if (dum >= big) then big = dum imax = i endif enddo if (j /= imax) then do k = i_min,n dum = a(imax,k) a(imax,k) = a(j,k) a(j,k) = dum enddo d = -d vv(imax) = vv(j) endif indx(j) = imax if (a(j,j) == 0.) then a(j,j) = eps endif if (j /= n) then dum = 1./a(j,j) do i = j+1,n a(i,j) = a(i,j)*dum enddo endif enddo end subroutine decomposition_LU subroutine LUbksb(a,i_min,n,indx,b,m) implicit none integer, intent(in) :: i_min,n,m integer, dimension(i_min:n), intent(in) :: indx double precision, dimension(i_min:n,i_min:n), intent(in) :: a double precision, dimension(i_min:n,i_min:m), intent(inout) :: b integer i,ip,j,ii,k double precision somme do k = i_min,m ii = -1 do i = i_min,n ip = indx(i) somme = b(ip,k) b(ip,k) = b(i,k) if (ii /= -1) then do j = ii,i-1 somme = somme - a(i,j)*b(j,k) enddo else if (somme /= 0.) then ii = i endif b(i,k) = somme enddo do i = n,i_min,-1 somme = b(i,k) do j = i+1,n somme = somme - a(i,j)*b(j,k) enddo b(i,k) = somme/a(i,i) enddo enddo end subroutine LUbksb subroutine syst_LU(a,i_min,n,b,m) implicit none integer, intent(in) :: i_min,n,m double precision, dimension(i_min:n,i_min:n), intent(in) :: a double precision, dimension(i_min:n,i_min:m), intent(inout) :: b integer i,j integer, dimension(i_min:n) :: indx double precision d double precision, dimension(i_min:n,i_min:n) :: aux do j = i_min,n indx(j) = 0 do i = i_min,n aux(i,j) = a(i,j) enddo enddo call decomposition_LU(aux,i_min,n,indx,d) call LUbksb(aux,i_min,n,indx,b,m) end subroutine syst_LU subroutine lfit_zener(x,y,sig,ndat,poids,ia,covar,chisq,ma,Qref,point) ! ma = nombre de variable diffusive ! ndat = m = K nombre d'abcisse freq_k implicit none integer, intent(in) :: ndat,ma logical, dimension(1:ma), intent(in) :: ia double precision, intent(in) :: Qref double precision, intent(out) :: chisq double precision, dimension(1:ndat), intent(in) :: x,y,sig double precision, dimension(1:ma), intent(in) :: point double precision, dimension(1:ma), intent(out) :: poids double precision, dimension(1:ma,1:ma), intent(out) :: covar integer i,j,k,l,mfit double precision ym,wt,sig2i double precision, dimension(1:ma) :: afunc double precision, dimension(1:ma,1:1) :: beta mfit = 0 do j = 1,ma if (ia(j)) then mfit = mfit + 1 endif enddo if (mfit == 0) then print *,'lfit: no parameters to be fitted' endif do j=1,mfit beta(j,1) = 0. do k=1,mfit covar(j,k) = 0. enddo enddo do i=1,ndat call func_zener(x(i),afunc,ma,Qref,point) ym = y(i) if (mfit < ma) then do j=1,ma if (.not. ia(j)) then ym = ym - poids(j) * afunc(j) endif enddo endif sig2i = 1. / (sig(i) * sig(i)) j = 0 do l=1,ma if (ia(l)) then j = j+1 wt = afunc(l) * sig2i k = count(ia(1:l)) covar(j,1:k) = covar(j,1:k) + wt * pack(afunc(1:l),ia(1:l)) beta(j,1) = beta(j,1) + ym * wt endif enddo enddo do j=2,mfit,1 do k=1,j-1,1 covar(k,j) = covar(j,k) enddo enddo if (ma == 1) then poids(1) = beta(1,1)/covar(1,1) else if (ma > 1) then call syst_LU(covar,1,mfit,beta,1) poids(1:ma) = unpack(beta(1:ma,1),ia,poids(1:ma)) endif chisq = 0. do i=1,ndat call func_zener(x(i),afunc,ma,Qref,point) chisq=chisq+((y(i)-dot_product(poids(1:ma),afunc(1:ma)))/sig(i))**2 enddo end subroutine lfit_zener subroutine func_zener(x,afunc,N,Qref,point) implicit none integer, intent(in) :: N double precision, intent(in) :: x,Qref double precision, dimension(1:N), intent(in) :: point double precision, dimension(1:N), intent(out) :: afunc integer k double precision num,deno do k = 1,N num = x * (point(k) - x / Qref) deno = point(k) * point(k) + x * x afunc(k) = num / deno enddo end subroutine func_zener subroutine remplit_point(fmin,fmax,N,point) implicit none ! pi double precision, parameter :: PI = 3.141592653589793d0 double precision, parameter :: TWO_PI = 2.d0 * PI integer, intent(in) :: N double precision, intent(in) :: fmin,fmax double precision, dimension(1:N), intent(out) :: point integer l if (N == 1) then point(1) = sqrt(fmin * fmax) ELSE do l = 1, N, 1 point(l) = (fmax/fmin) ** ((l-1.)/(N-1.)) point(l) = TWO_PI * point(l) * fmin enddo endif end subroutine remplit_point subroutine classical_linear_least_squares(Qref,poids,point,N,fmin,fmax) implicit none ! pi double precision, parameter :: PI = 3.141592653589793d0 double precision, parameter :: TWO_PI = 2.d0 * PI integer, intent(in) :: N double precision, intent(in) :: Qref,fmin,fmax double precision, dimension(1:N), intent(out) :: point,poids integer k,m logical, dimension(1:N) :: ia double precision ref,freq,chi2 double precision, dimension(1:N,1:N) :: covar double precision, dimension(1:2*N-1) :: x,y_ref,sig m = 2*N-1 call remplit_point(fmin,fmax,N,point) ref = 1.0 / Qref do k=1,m freq = (fmax/fmin) ** ((k - 1.)/(m - 1.)) freq = TWO_PI * fmin * freq x(k) = freq y_ref(k) = ref sig(k) = 1. enddo do k=1,N ia(k) = .true. enddo call lfit_zener(x,y_ref,sig,m,poids,ia,covar,chi2,N,Qref,point) end subroutine classical_linear_least_squares ! Calcul des coefficients par optimization non-lineaire avec contraintes subroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,theta_min,theta_max,f_min,f_max) !----------------------------------------------------------------------------- ! The subroutine SOLVOPT performs a modified version of Shor's r-algorithm in ! order to find a local minimum resp. maximum of a nonlinear function ! defined on the n-dimensional Euclidean space ! or ! a local minimum for a nonlinear constrained problem: ! min { f(x): g(x) ( < )= 0, g(x) in R(m), x in R(n) }. ! Arguments: ! n is the space dimension (integer*4), ! x is the n-vector, the coordinates of the starting point ! at a call to the subroutine and the optimizer at regular return ! (double precision), ! f returns the optimum function value ! (double precision), ! fun is the entry name of a subroutine which computes the value ! of the function < fun> at a point x, should be declared as external ! in a calling routine, ! synopsis: fun(x,f) ! grad is the entry name of a subroutine which computes the gradient ! vector of the function < fun> at a point x, should be declared as ! external in a calling routine, ! synopsis: grad(x,g) ! func is the entry name of a subroutine which computes the MAXIMAL ! RESIDIAL!!! (a scalar) for a set of constraints at a point x, ! should be declared as external in a calling routine, ! synopsis: func(x,fc) ! gradc is the entry name of a subroutine which computes the gradient ! vector for a constraint with the MAXIMAL RESIDUAL at a point x, ! should be declared as external in a calling routine, ! synopsis: gradc(x,gc) ! flg, (logical) is a flag for the use of a subroutine < grad>: ! .true. means gradients are calculated by the user-supplied routine. ! flfc, (logical) is a flag for a constrained problem: ! .true. means the maximal residual for a set of constraints ! is calculated by < func>. ! flgc, (logical) is a flag for the use of a subroutine < gradc>: ! .true. means gradients of the constraints are calculated ! by the user-supplied routine. ! options is a vector of optional parameters (double precision): ! options(1)= H, where sign(H)=-1 resp. sign(H)=+1 means minimize resp. ! maximize < fun> (valid only for an unconstrained problem) and ! H itself is a factor for the initial trial step size ! (options(1)=-1.d0 by default), ! options(2)= relative error for the argument in terms of the infinity-norm ! (1.d-4 by default), ! options(3)= relative error for the function value (1.d-6 by default), ! options(4)= limit for the number of iterations (1.5d4 by default), ! options(5)= control of the display of intermediate results and error ! resp. warning messages (default value is 0.d0, i.e., no intermediate ! output but error and warning messages, see the manual for more), ! options(6)= maximal admissible residual for a set of constraints ! (options(6)=1.d-8 by default, see the manual for more), ! *options(7)= the coefficient of space dilation (2.5d0 by default), ! *options(8)= lower bound for the stepsize used for the difference ! approximation of gradients (1.d-11 by default,see the manual for more). ! (* ... changes should be done with care) ! returned optional values: ! options(9), the number of iterations, if positive, ! or an abnormal stop code, if negative (see manual for more), ! -1: allocation error, ! -2: improper space dimension, ! -3: < fun> returns an improper value, ! -4: < grad> returns a zero vector or improper value at the ! starting point, ! -5: < func> returns an improper value, ! -6: < gradc> returns an improper value, ! -7: function is unbounded, ! -8: gradient is zero at the point, ! but stopping criteria are not fulfilled, ! -9: iterations limit exceeded, ! -11: Premature stop is possible, ! -12: Result may not provide the true optimum, ! -13: function is flat: result may be inaccurate ! in view of a point. ! -14: function is steep: result may be inaccurate ! in view of a function value, ! options(10), the number of objective function evaluations, and ! options(11), the number of gradient evaluations. ! options(12), the number of constraint function evaluations, and ! options(13), the number of constraint gradient evaluations. ! ____________________________________________________________________________ ! implicit none !include 'messages.inc' integer, intent(in) :: Kopt double precision, intent(in) :: Qref,theta_min,theta_max,f_min,f_max logical flg,flgc,flfc, constr, app, appconstr logical FsbPnt, FsbPnt1, termflag, stopf logical stopping, dispwarn, Reset, ksm,knan,obj integer n, kstore, ajp,ajpp,knorms, k, kcheck, numelem integer dispdata, ld, mxtc, termx, limxterm, nzero, krerun integer warnno, kflat, stepvanish, i,j,ni,ii, kd,kj,kc,ip integer iterlimit, kg,k1,k2, kless, allocerr double precision options(13),doptions(13) double precision x(n),f double precision nsteps(3), gnorms(10), kk, nx double precision ajb,ajs, des, dq,du20,du10,du03 double precision n_float, cnteps double precision low_bound, ZeroGrad, ddx, y double precision lowxbound, lowfbound, detfr, detxr, grbnd double precision fp,fp1,fc,f1,f2,fm,fopt,frec,fst, fp_rate double precision PenCoef, PenCoefNew double precision gamma,w,wdef,h1,h,hp double precision dx,ng,ngc,nng,ngt,nrmz,ng1,d,dd, laststep double precision zero,one,two,three,four,five,six,seven double precision eight,nine,ten,hundr double precision infty, epsnorm,epsnorm2,powerm12 double precision, dimension(:,:), allocatable :: B double precision, dimension(:), allocatable :: g double precision, dimension(:), allocatable :: g0 double precision, dimension(:), allocatable :: g1 double precision, dimension(:), allocatable :: gt double precision, dimension(:), allocatable :: gc double precision, dimension(:), allocatable :: z double precision, dimension(:), allocatable :: x1 double precision, dimension(:), allocatable :: xopt double precision, dimension(:), allocatable :: xrec double precision, dimension(:), allocatable :: grec double precision, dimension(:), allocatable :: xx double precision, dimension(:), allocatable :: deltax integer, dimension(:), allocatable :: idx character(len=100) :: endwarn character(len=19) :: allocerrstr external fun,grad,func,gradc data zero/0.d0/, one/1.d0/, two/2.d0/, three/3.d0/, four/4.d0/, & five/5.d0/, six/6.d0/, seven/7.d0/, eight/8.d0/, nine/9.d0/, & ten/1.d1/, hundr/1.d2/, powerm12/1.d-12/, & infty /1.d100/, epsnorm /1.d-15/, epsnorm2 /1.d-30/, & allocerrstr/'Allocation Error = '/ ! Check the dimension: if (n < 2) then print *, 'SolvOpt error:' print *, 'Improper space dimension.' stop 'error in allocate statement in SolvOpt' options(9)=-one goto 999 endif n_float=dble(n) ! allocate working arrays: allocate (B(n,n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (g(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (g0(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (g1(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (gt(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (gc(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (z(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (x1(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (xopt(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (xrec(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (grec(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (xx(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (deltax(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif allocate (idx(n),stat=allocerr) if (allocerr /= 0) then options(9)=-one print *,allocerrstr,allocerr stop 'error in allocate statement in SolvOpt' endif ! store flags: app= .not. flg constr=flfc appconstr= .not. flgc ! Default values for options: call soptions(doptions) do i=1,8 if (options(i) == zero) then options(i)=doptions(i) else if (i == 2 .or. i == 3 .or. i == 6) then options(i)=dmax1(options(i),powerm12) options(i)=dmin1(options(i),one) if (i == 2)options(i)=dmax1(options(i),options(8)*hundr) else if (i == 7) then options(7)=dmax1(options(i),1.5d0) endif enddo ! WORKING CONSTANTS AND COUNTERS ----{ options(10)=zero !! counter for function calculations options(11)=zero !! counter for gradient calculations options(12)=zero !! counter for constraint function calculations options(13)=zero !! counter for constraint gradient calculations iterlimit=idint(options(4)) if (constr) then h1=-one !! NLP: restricted to minimization cnteps=options(6) else h1=dsign(one,options(1)) !! Minimize resp. maximize a function endif k=0 !! Iteration counter wdef=one/options(7)-one !! Default space transf. coeff. ! Gamma control ---{ ajb=one+1.d-1/n_float**2 !! Base I ajp=20 ajpp=ajp !! Start value for the power ajs=1.15d0 !! Base II knorms=0 do i=1,10 gnorms(i)=zero enddo !---} ! Display control ---{ if (options(5) <= zero) then dispdata=0 if (options(5) == -one) then dispwarn=.false. else dispwarn=.true. endif else dispdata=idnint(options(5)) dispwarn=.true. endif ld=dispdata !---} ! Stepsize control ---{ dq=5.1d0 !! Step divider (at f_{i+1} > gamma*f_{i}) du20=two du10=1.5d0 du03=1.05d0 !! Step multipliers (at certain steps made) kstore=3 do i=1,kstore nsteps(i)=zero !! Steps made at the last 'kstore' iterations enddo if (app) then des=6.3d0 !! Desired number of steps per 1-D search else des=3.3d0 endif mxtc=3 !! Number of trial cycles (steep wall detect) !---} termx=0 limxterm=50 !! Counter and limit for x-criterion ! stepsize for gradient approximation ddx=dmax1(1.d-11,options(8)) low_bound=-one+1.d-4 !! Lower bound cosine used to detect a ravine ZeroGrad=n_float*1.d-16 !! Lower bound for a gradient norm nzero=0 !! Zero-gradient events counter ! Low bound for the values of variables to take into account lowxbound=dmax1(options(2),1.d-3) ! Lower bound for function values to be considered as making difference lowfbound=options(3)**2 krerun=0 !! Re-run events counter detfr=options(3)*hundr !! Relative error for f/f_{record} detxr=options(2)*ten !! Relative error for norm(x)/norm(x_{record}) warnno=0 !! the number of warn.mess. to end with kflat=0 !! counter for points of flatness stepvanish=0 !! counter for vanished steps stopf=.false. ! ----} End of setting constants ! ----} End of the preamble !-------------------------------------------------------------------- ! COMPUTE THE function ( FIRST TIME ) ----{ call fun(x,f,Qref,n/2,n,Kopt,f_min,f_max) options(10)=options(10)+one if (dabs(f) >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,'function equals infinity at the point.' print *,'Choose another starting point.' endif options(9)=-three goto 999 endif do i=1,n xrec(i)=x(i) enddo frec=f !! record point and function value ! Constrained problem if (constr) then kless=0 fp=f call func(x,fc,n/2,n,theta_min,theta_max) options(12)=options(12)+one if (dabs(fc) >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,' < FUNC > returns infinite value at the point.' print *,'Choose another starting point.' endif options(9)=-five goto 999 endif PenCoef=one !! first rough approximation if (fc <= cnteps) then FsbPnt=.true. !! feasible point fc=zero else FsbPnt=.false. endif f=f+PenCoef*fc endif ! ----} ! COMPUTE THE GRADIENT ( FIRST TIME ) ----{ if (app) then do i=1,n deltax(i)=h1*ddx enddo obj=.true. !if (constr) then !call apprgrdn() !else !call apprgrdn() !endif options(10)=options(10)+n_float else call grad(x,g,Qref,n/2,n,Kopt,f_min,f_max) options(11)=options(11)+one endif ng=zero do i=1,n ng=ng+g(i)*g(i) enddo ng=dsqrt(ng) if (ng >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,'Gradient equals infinity at the starting point.' print *,'Choose another starting point.' endif options(9)=-four goto 999 else if (ng < ZeroGrad) then if (dispwarn) then print *,'SolvOpt error:' print *,'Gradient equals zero at the starting point.' print *,'Choose another starting point.' endif options(9)=-four goto 999 endif if (constr) then if (.not. FsbPnt) then !if (appconstr) then !do j=1,n !if (x(j) >= zero) then !deltax(j)=ddx !else !deltax(j)=-ddx !endif !enddo !obj=.false. !call apprgrdn() if (.not. appconstr) then call gradc(x,gc,n/2,n,theta_min,theta_max) endif ngc=zero do i=1,n ngc=ngc+gc(i)*gc(i) enddo ngc=dsqrt(ngc) if (ng >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,' < GRADC > returns infinite vector at the point.' print *,'Choose another starting point.' endif options(9)=-six goto 999 else if (ng < ZeroGrad) then if (dispwarn) then print *,'SolvOpt error:' print *,' < GRADC > returns zero vector at an infeasible point.' endif options(9)=-six goto 999 endif do i=1,n g(i)=g(i)+PenCoef*gc(i) enddo ng=zero do i=1,n ng=ng+g(i)*g(i) grec(i)=g(i) enddo ng=dsqrt(ng) endif endif do i=1,n grec(i)=g(i) enddo nng=ng ! ----} ! INITIAL STEPSIZE d=zero do i=1,n if (d < dabs(x(i))) d=dabs(x(i)) enddo h=h1*dsqrt(options(2))*d !! smallest possible stepsize if (dabs(options(1)) /= one) then h=h1*dmax1(dabs(options(1)),dabs(h)) !! user-supplied stepsize else h=h1*dmax1(one/dlog(ng+1.1d0),dabs(h)) !! calculated stepsize endif ! RESETTING LOOP ----{ do while (.true.) kcheck=0 !! Set checkpoint counter. kg=0 !! stepsizes stored kj=0 !! ravine jump counter do i=1,n do j=1,n B(i,j)=zero enddo B(i,i)=one !! re-set transf. matrix to identity g1(i)=g(i) enddo fst=f dx=0 ! ----} ! MAIN ITERATIONS ----{ do while (.true.) k=k+1 kcheck=kcheck+1 laststep=dx ! ADJUST GAMMA --{ gamma=one+dmax1(ajb**((ajp-kcheck)*n),two*options(3)) gamma=dmin1 ( gamma,ajs**dmax1(one,dlog10(nng+one)) ) ! --} ngt=zero ng1=zero dd=zero do i=1,n d=zero do j=1,n d=d+B(j,i)*g(j) enddo gt(i)=d dd=dd+d*g1(i) ngt=ngt+d*d ng1=ng1+g1(i)*g1(i) enddo ngt=dsqrt(ngt) ng1=dsqrt(ng1) dd=dd/ngt/ng1 w=wdef ! JUMPING OVER A RAVINE ----{ if (dd < low_bound) then if (kj == 2) then do i=1,n xx(i)=x(i) enddo endif if (kj == 0) kd=4 kj=kj+1 w=-.9d0 !! use large coef. of space dilation h=h*two if (kj > 2*kd) then kd=kd+1 warnno=1 endwarn='Premature stop is possible. Try to re-run the routine from the obtained point.' do i=1,n if (dabs(x(i)-xx(i)) < epsnorm*dabs(x(i))) then if (dispwarn) then print *,'SolvOpt warning:' print *,'Ravine with a flat bottom is detected.' endif endif enddo endif else kj=0 endif ! ----} ! DILATION ----{ nrmz=zero do i=1,n z(i)=gt(i)-g1(i) nrmz=nrmz+z(i)*z(i) enddo nrmz=dsqrt(nrmz) if (nrmz > epsnorm*ngt) then do i=1,n z(i)=z(i)/nrmz enddo ! New direction in the transformed space: g1=gt+w*(z*gt')*z and ! new inverse matrix: B = B ( I + (1/alpha -1)zz' ) d = zero do i=1,n d=d+z(i)*gt(i) enddo ng1=zero d = d*w do i=1,n dd=zero g1(i)=gt(i)+d*z(i) ng1=ng1+g1(i)*g1(i) do j=1,n dd=dd+B(i,j)*z(j) enddo dd=w*dd do j=1,n B(i,j)=B(i,j)+dd*z(j) enddo enddo ng1=dsqrt(ng1) else do i=1,n z(i)=zero g1(i)=gt(i) enddo nrmz=zero endif do i=1,n gt(i)=g1(i)/ng1 enddo do i=1,n d=zero do j=1,n d=d+B(i,j)*gt(j) enddo g0(i)=d enddo ! ----} ! RESETTING ----{ if (kcheck > 1) then numelem=0 do i=1,n if (dabs(g(i)) > ZeroGrad) then numelem=numelem+1 idx(numelem)=i endif enddo if (numelem > 0) then grbnd=epsnorm*dble(numelem**2) ii=0 do i=1,numelem j=idx(i) if (dabs(g1(j)) <= dabs(g(j))*grbnd) ii=ii+1 enddo if (ii == n .or. nrmz == zero) then if (dispwarn) then print *,'SolvOpt warning:' print *,'Normal re-setting of a transformation matrix.' endif if (dabs(fst-f) < dabs(f)*1.d-2) then ajp=ajp-10*n else ajp=ajpp endif h=h1*dx/three k=k-1 exit endif endif endif ! ----} ! STORE THE CURRENT VALUES AND SET THE COUNTERS FOR 1-D SEARCH do i=1,n xopt(i)=x(i) enddo fopt=f k1=0 k2=0 ksm=.false. kc=0 knan=.false. hp=h if (constr) Reset=.false. ! 1-D SEARCH ----{ do while (.true.) do i=1,n x1(i)=x(i) enddo f1=f if (constr) then FsbPnt1=FsbPnt fp1=fp endif ! NEW POINT do i=1,n x(i)=x(i)+hp*g0(i) enddo ii=0 do i=1,n if (dabs(x(i)-x1(i)) < dabs(x(i))*epsnorm) ii=ii+1 enddo ! function VALUE call fun(x,f,Qref,n/2,n,Kopt,f_min,f_max) options(10)=options(10)+one if (h1*f >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,'function is unbounded.' endif options(9)=-seven goto 999 endif if (constr) then fp=f call func(x,fc,n/2,n,theta_min,theta_max) options(12)=options(12)+one if (dabs(fc) >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,' < FUNC > returns infinite value at the point.' print *,'Choose another starting point.' endif options(9)=-five goto 999 endif if (fc <= cnteps) then FsbPnt=.true. fc=zero else FsbPnt=.false. fp_rate=fp-fp1 if (fp_rate < -epsnorm) then if (.not. FsbPnt1) then d=zero do i=1,n d=d+(x(i)-x1(i))**2 enddo d=dsqrt(d) PenCoefNew=-1.5d1*fp_rate/d if (PenCoefNew > 1.2d0*PenCoef) then PenCoef=PenCoefNew Reset=.true. kless=0 f=f+PenCoef*fc exit endif endif endif endif f=f+PenCoef*fc endif if (dabs(f) >= infty) then if (dispwarn) then print *,'SolvOpt warning:' print *,'function equals infinity at the point.' endif if (ksm .or. kc >= mxtc) then options(9)=-three goto 999 else k2=k2+1 k1=0 hp=hp/dq do i=1,n x(i)=x1(i) enddo f=f1 knan=.true. if (constr) then FsbPnt=FsbPnt1 fp=fp1 endif endif ! STEP SIZE IS ZERO TO THE EXTENT OF EPSNORM else if (ii == n) then stepvanish=stepvanish+1 if (stepvanish >= 5) then options(9)=-ten-four if (dispwarn) then print *,'SolvOpt: Termination warning:' print *,'Stopping criteria are not fulfilled. The function is very steep at the solution.' endif goto 999 else do i=1,n x(i)=x1(i) enddo f=f1 hp=hp*ten ksm=.true. if (constr) then FsbPnt=FsbPnt1 fp=fp1 endif endif ! USE SMALLER STEP else if (h1*f < h1*gamma**idint(dsign(one,f1))*f1) then if (ksm) exit k2=k2+1 k1=0 hp=hp/dq do i=1,n x(i)=x1(i) enddo f=f1 if (constr) then FsbPnt=FsbPnt1 fp=fp1 endif if (kc >= mxtc) exit ! 1-D OPTIMIZER IS LEFT BEHIND else if (h1*f <= h1*f1) exit ! USE LARGER STEP k1=k1+1 if (k2 > 0) kc=kc+1 k2=0 if (k1 >= 20) then hp=du20*hp else if (k1 >= 10) then hp=du10*hp else if (k1 >= 3) then hp=du03*hp endif endif enddo ! ----} End of 1-D search ! ADJUST THE TRIAL STEP SIZE ----{ dx=zero do i=1,n dx=dx+(xopt(i)-x(i))**2 enddo dx=dsqrt(dx) if (kg < kstore) kg=kg+1 if (kg >= 2) then do i=kg,2,-1 nsteps(i)=nsteps(i-1) enddo endif d=zero do i=1,n d=d+g0(i)*g0(i) enddo d=dsqrt(d) nsteps(1)=dx/(dabs(h)*d) kk=zero d=zero do i=1,kg dd=dble(kg-i+1) d=d+dd kk=kk+nsteps(i)*dd enddo kk=kk/d if (kk > des) then if (kg == 1) then h=h*(kk-des+one) else h=h*dsqrt(kk-des+one) endif else if (kk < des) then h=h*dsqrt(kk/des) endif if (ksm) stepvanish=stepvanish+1 ! ----} ! COMPUTE THE GRADIENT ----{ if (app) then do j=1,n if (g0(j) >= zero) then deltax(j)=h1*ddx else deltax(j)=-h1*ddx endif enddo obj=.true. !if (constr) then !call apprgrdn() !else !call apprgrdn() !endif !options(10)=options(10)+n_float else call grad(x,g,Qref,n/2,n,Kopt,f_min,f_max) options(11)=options(11)+one endif ng=zero do i=1,n ng=ng+g(i)*g(i) enddo ng=dsqrt(ng) if (ng >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,'Gradient equals infinity at the starting point.' endif options(9)=-four goto 999 else if (ng < ZeroGrad) then if (dispwarn) then print *,'SolvOpt warning:' print *,'Gradient is zero, but stopping criteria are not fulfilled.' endif ng=ZeroGrad endif ! Constraints: if (constr) then if (.not. FsbPnt) then if (ng < 1.d-2*PenCoef) then kless=kless+1 if (kless >= 20) then PenCoef=PenCoef/ten Reset=.true. kless=0 endif else kless=0 endif !if (appconstr) then !do j=1,n !if (x(j) >= zero) then !deltax(j)=ddx !else !deltax(j)=-ddx !endif !enddo !obj=.false. !call apprgrdn() !options(12)=options(12)+n_float if (.not. appconstr) then call gradc(x,gc,n/2,n,theta_min,theta_max) options(13)=options(13)+one endif ngc=zero do i=1,n ngc=ngc+gc(i)*gc(i) enddo ngc=dsqrt(ngc) if (ngc >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,' < GRADC > returns infinite vector at the point.' endif options(9)=-six goto 999 else if (ngc < ZeroGrad .and. .not. appconstr) then if (dispwarn) then print *,'SolvOpt error:' print *,' < GRADC > returns zero vector at an infeasible point.' endif options(9)=-six goto 999 endif do i=1,n g(i)=g(i)+PenCoef*gc(i) enddo ng=zero do i=1,n ng=ng+g(i)*g(i) enddo ng=dsqrt(ng) if (Reset) then if (dispwarn) then print *,'SolvOpt warning:' print *,'Re-setting due to the use of a new penalty coefficient.' endif h=h1*dx/three k=k-1 nng=ng exit endif endif endif if (h1*f > h1*frec) then frec=f do i=1,n xrec(i)=x(i) grec(i)=g(i) enddo endif ! ----} if (ng > ZeroGrad) then if (knorms < 10) knorms=knorms+1 if (knorms >= 2) then do i=knorms,2,-1 gnorms(i)=gnorms(i-1) enddo endif gnorms(1)=ng nng=one do i=1,knorms nng=nng*gnorms(i) enddo nng=nng**(one/dble(knorms)) endif ! Norm X: nx=zero do i=1,n nx=nx+x(i)*x(i) enddo nx=dsqrt(nx) ! DISPLAY THE CURRENT VALUES ----{ if (k == ld) then print *, & 'Iteration # ..... function Value ..... ', & 'Step Value ..... Gradient Norm' print '(5x,i5,7x,g13.5,6x,g13.5,7x,g13.5)', k,f,dx,ng ld=k+dispdata endif !----} ! CHECK THE STOPPING CRITERIA ----{ termflag=.true. if (constr) then if (.not. FsbPnt) termflag=.false. endif if (kcheck <= 5 .or. kcheck <= 12 .and. ng > one)termflag=.false. if (kc >= mxtc .or. knan)termflag=.false. ! ARGUMENT if (termflag) then ii=0 stopping=.true. do i=1,n if (dabs(x(i)) >= lowxbound) then ii=ii+1 idx(ii)=i if (dabs(xopt(i)-x(i)) > options(2)*dabs(x(i))) then stopping=.false. endif endif enddo if (ii == 0 .or. stopping) then stopping=.true. termx=termx+1 d=zero do i=1,n d=d+(x(i)-xrec(i))**2 enddo d=dsqrt(d) ! function if (dabs(f-frec) > detfr*dabs(f) .and. & dabs(f-fopt) <= options(3)*dabs(f) .and. & krerun <= 3 .and. .not. constr) then stopping=.false. if (ii > 0) then do i=1,ii j=idx(i) if (dabs(xrec(j)-x(j)) > detxr*dabs(x(j))) then stopping=.true. exit endif enddo endif if (stopping) then if (dispwarn) then print *,'SolvOpt warning:' print *,'Re-run from recorded point.' endif ng=zero do i=1,n x(i)=xrec(i) g(i)=grec(i) ng=ng+g(i)*g(i) enddo ng=dsqrt(ng) f=frec krerun=krerun+1 h=h1*dmax1(dx,detxr*nx)/dble(krerun) warnno=2 endwarn='Result may not provide the optimum. The function apparently has many extremum points.' exit else h=h*ten endif else if (dabs(f-frec) > options(3)*dabs(f) .and. & d < options(2)*nx .and. constr) then continue else if (dabs(f-fopt) <= options(3)*dabs(f) .or. & dabs(f) <= lowfbound .or. & (dabs(f-fopt) <= options(3) .and. & termx >= limxterm )) then if (stopf) then if (dx <= laststep) then if (warnno == 1 .and. ng < dsqrt(options(3))) then warnno=0 endif if (.not. app) then do i=1,n if (dabs(g(i)) <= epsnorm2) then warnno=3 endwarn='Result may be inaccurate in the coordinates. The function is flat at the solution.' exit endif enddo endif if (warnno /= 0) then options(9)=-dble(warnno)-ten if (dispwarn) then print *,'SolvOpt: Termination warning:' print *,endwarn if (app) print *,'The above warning may be reasoned by inaccurate gradient approximation' endif else options(9)=dble(k) !! DK DK if (dispwarn) print *,'SolvOpt: Normal termination.' endif goto 999 endif else stopf=.true. endif else if (dx < powerm12*dmax1(nx,one) .and. & termx >= limxterm ) then options(9)=-four-ten if (dispwarn) then print *,'SolvOpt: Termination warning:' print *,'Stopping criteria are not fulfilled. The function is very steep at the solution.' if (app) print *,'The above warning may be reasoned by inaccurate gradient approximation' f=frec do i=1,n x(i)=xrec(i) enddo endif goto 999 endif endif endif ! ITERATIONS LIMIT if (k == iterlimit) then options(9)=-nine if (dispwarn) then print *,'SolvOpt warning:' print *,'Iterations limit exceeded.' endif goto 999 endif ! ----} ! ZERO GRADIENT ----{ if (constr) then if (ng <= ZeroGrad) then if (dispwarn) then print *,'SolvOpt: Termination warning:' print *,'Gradient is zero, but stopping criteria are not fulfilled.' endif options(9)=-eight goto 999 endif else if (ng <= ZeroGrad) then nzero=nzero+1 if (dispwarn) then print *,'SolvOpt warning:' print *,'Gradient is zero, but stopping criteria are not fulfilled.' endif if (nzero >= 3) then options(9)=-eight goto 999 endif do i=1,n g0(i)=-h*g0(i)/two enddo do i=1,10 do j=1,n x(j)=x(j)+g0(j) enddo call fun(x,f,Qref,n/2,n,Kopt,f_min,f_max) options(10)=options(10)+one if (dabs(f) >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,'function equals infinity at the point.' endif options(9)=-three goto 999 endif !if (app) then !do j=1,n !if (g0(j) >= zero) then !deltax(j)=h1*ddx !else !deltax(j)=-h1*ddx !endif !enddo !obj=.true. !call apprgrdn() !options(10)=options(10)+n_float if (.not. app) then call grad(x,g,Qref,n/2,n,Kopt,f_min,f_max) options(11)=options(11)+one endif ng=zero do j=1,n ng=ng+g(j)*g(j) enddo ng=dsqrt(ng) if (ng >= infty) then if (dispwarn) then print *,'SolvOpt error:' print *,'Gradient equals infinity at the starting point.' endif options(9)=-four goto 999 endif if (ng > ZeroGrad) exit enddo if (ng <= ZeroGrad) then if (dispwarn) then print *,'SolvOpt: Termination warning:' print *,'Gradient is zero, but stopping criteria are not fulfilled.' endif options(9)=-eight goto 999 endif h=h1*dx exit endif endif ! ----} ! function IS FLAT AT THE POINT ----{ if (.not. constr .and. & dabs(f-fopt) < dabs(fopt)*options(3) .and. & kcheck > 5 .and. ng < one ) then ni=0 do i=1,n if (dabs(g(i)) <= epsnorm2) then ni=ni+1 idx(ni)=i endif enddo if (ni >= 1 .and. ni <= n/2 .and. kflat <= 3) then kflat=kflat+1 if (dispwarn) then print *,'SolvOpt warning:' print *,'The function is flat in certain directions.' endif warnno=1 endwarn='Premature stop is possible. Try to re-run the routine from the obtained point.' do i=1,n x1(i)=x(i) enddo fm=f do i=1,ni j=idx(i) f2=fm y=x(j) if (y == zero) then x1(j)=one else if (dabs(y) < one) then x1(j)=dsign(one,y) else x1(j)=y endif do ip=1,20 x1(j)=x1(j)/1.15d0 call fun(x1,f1,Qref,n/2,n,Kopt,f_min,f_max) options(10)=options(10)+one if (dabs(f1) < infty) then if (h1*f1 > h1*fm) then y=x1(j) fm=f1 else if (h1*f2 > h1*f1) then exit else if (f2 == f1) then x1(j)=x1(j)/1.5d0 endif f2=f1 endif enddo x1(j)=y enddo if (h1*fm > h1*f) then !if (app) then !do j=1,n !deltax(j)=h1*ddx !enddo !obj=.true. !call apprgrdn() !options(10)=options(10)+n_float if (.not. app) then call grad(x1,gt,Qref,n/2,n,Kopt,f_min,f_max) options(11)=options(11)+one endif ngt=zero do i=1,n ngt=ngt+gt(i)*gt(i) enddo if (ngt > epsnorm2 .and. ngt < infty) then if (dispwarn) print *,'Trying to recover by shifting insensitive variables.' do i=1,n x(i)=x1(i) g(i)=gt(i) enddo ng=ngt f=fm h=h1*dx/three options(3)=options(3)/five exit endif !! regular gradient endif !! a better value has been found endif !! function is flat endif !! pre-conditions are fulfilled ! ----} enddo !! iterations enddo !! restart 999 continue ! deallocate working arrays: deallocate (idx,deltax,xx,grec,xrec,xopt,x1,z,gc,gt,g1,g0,g,B) end subroutine solvopt subroutine soptions(default) ! SOPTIONS returns the default values for the optional parameters ! used by SolvOpt. implicit none double precision default(13) default(1) = -1.d0 default(2) = 1.d-4 default(3) = 1.d-6 default(4) = 15.d3 default(5) = 0.d0 default(6) = 1.d-8 default(7) = 2.5d0 default(8) = 1.d-12 default(9) = 0.d0 default(10) = 0.d0 default(11) = 0.d0 default(12) = 0.d0 default(13) = 0.d0 end subroutine soptions subroutine func_objective(x,res,freq,Qref,N,Nopt) implicit none integer, intent(in) :: N,Nopt double precision, intent(in) :: freq,Qref double precision, intent(out) :: res double precision, dimension(1:Nopt), intent(in) :: x integer i double precision num,deno res = 0.d0 do i=1,N num = x(N+i)*x(N+i)*freq*Qref*(x(i)*x(i) - freq/qref) deno = (x(i) ** 4.) + freq*freq res = res + num/deno enddo end subroutine func_objective subroutine func_mini(x,res,Qref,N,Nopt,K,f_min,f_max) ! Nopt=2*N : nombre de coefficients a optimiser implicit none ! pi double precision, parameter :: PI = 3.141592653589793d0 double precision, parameter :: TWO_PI = 2.d0 * PI integer, intent(in) :: N,Nopt,K double precision, intent(in) :: Qref,f_min,f_max double precision, intent(out) :: res double precision, dimension(1:Nopt), intent(in) :: x integer i double precision d,freq,aux res = 0. do i=1,K freq = TWO_PI * f_min*((f_max/f_min)**((i-1.)/(K-1.))) call func_objective(x,aux,freq,Qref,N,Nopt) d = aux - 1. res = res + d*d enddo end subroutine func_mini subroutine grad_func_mini(x,grad,Qref,N,Nopt,K,f_min,f_max) implicit none ! pi double precision, parameter :: PI = 3.141592653589793d0 double precision, parameter :: TWO_PI = 2.d0 * PI integer, intent(in) :: N,Nopt,K double precision, intent(in) :: Qref,f_min,f_max double precision, dimension(1:Nopt), intent(in) :: x double precision, dimension(1:Nopt), intent(out) :: grad integer i,l double precision R,temp0,temp1,temp2,temp3,tamp,aux1,aux2,aux3,aux4 double precision, dimension(1:N) :: point,poids double precision, dimension(1:K) :: freq do i=1,K freq(i) = TWO_PI * f_min*((f_max/f_min)**((i-1.)/(K-1.))) enddo do l=1,N point(l) = x(l) poids(l) = x(N+l) enddo do l=1,N grad(l) = 0. grad(N+l) = 0. do i=1,K call func_objective(x,R,freq(i),Qref,N,Nopt) temp3 = R - 1. temp0 = freq(i)*Qref !derivee par rapport aux poids temp1 = temp0*(point(l)*point(l) - freq(i)/qref) temp1 = temp1*2.*poids(l) temp2 = (point(l)**4.) + freq(i)*freq(i) temp1 = temp1/temp2 tamp = 2.*temp3*temp1 grad(N+l) = grad(N+l) + tamp !derivee par rapport aux points aux1 = -2.*(point(l)**5.) + 2.*point(l)*freq(i)*freq(i) + 4.*(point(l)**3.)*freq(i)/Qref aux3 = temp2*temp2 aux4 = aux1/aux3 aux4 = aux4*temp0 aux2 = aux4*poids(l)*poids(l) tamp = 2.*temp3*aux2 grad(l) = grad(l) + tamp enddo enddo end subroutine grad_func_mini subroutine max_residu(x,res,N,Nopt,theta_min,theta_max) implicit none integer, intent(in) :: N,Nopt double precision, intent(in) :: theta_min,theta_max double precision, intent(out) :: res double precision, dimension(1:Nopt), intent(in) :: x integer l double precision temp,aux temp = 0.d0 res = 0.d0 do l=1,N aux = res temp = max(0.d0,x(l)*x(l)-(theta_max-theta_min)) res = max(temp,aux) enddo end subroutine max_residu subroutine grad_max_residu(x,grad,N,Nopt,theta_min,theta_max) implicit none integer, intent(in) :: N,Nopt double precision, intent(in) :: theta_min,theta_max double precision, dimension(1:Nopt), intent(in) :: x double precision, dimension(1:Nopt), intent(out) :: grad integer l,l0 double precision temp,res,aux,temp2 double precision, dimension(1:N) :: point temp = 0.d0 res = 0.d0 do l=1,N point(l) = x(l) enddo l0 = 1 do l=1,N aux = res temp = max(0.d0,point(l)*point(l) - (theta_max-theta_min)) res = max(temp,aux) if (temp > aux) then l0 = l endif enddo do l=1,N grad(N+l) = 0.d0 if (l /= l0) then grad(l) = 0.d0 else call max_residu(x,temp2,N,Nopt,theta_min,theta_max) if (temp2 == 0.d0) then grad(l0) = 0.d0 else grad(l0) = 2.d0*point(l0) endif endif enddo end subroutine grad_max_residu subroutine nonlinear_optimization(N,Qref,f0,point,poids,f_min,f_max) implicit none ! pi double precision, parameter :: PI = 3.141592653589793d0 double precision, parameter :: TWO_PI = 2.d0 * PI integer, intent(in) :: N double precision, intent(in) :: Qref,f0,f_min,f_max double precision, dimension(1:N), intent(out) :: point,poids external func_mini,grad_func_mini,max_residu,grad_max_residu integer K,i logical flg,flfc,flgc double precision theta_min,theta_max,res double precision, dimension(1:2*N) :: x double precision, dimension(1:13) :: options flg = .true. flgc = .true. flfc = .true. K = 4*N theta_min = TWO_PI*0.d0 theta_max = TWO_PI*100.d0*f0 ! this is used as a first guess call classical_linear_least_squares(Qref,poids,point,N,f_min,f_max) ! what follows is the nonlinear optimization part do i=1,N x(i) = sqrt(abs(point(i)) - theta_min) x(N+i) = sqrt(abs(poids(i))) enddo call soptions(options) call solvopt(2*N,x,res,func_mini,flg,grad_func_mini,options,flfc, & max_residu,flgc,grad_max_residu,Qref,K,theta_min,theta_max,f_min,f_max) do i=1,N point(i) = theta_min + x(i)*x(i) poids(i) = x(N+i)*x(N+i) enddo end subroutine nonlinear_optimization ================================================ FILE: conversion_between_Qp_Qs_and_Qkappa_Qmu_from_Dahlen_Tromp_959_960_in_3D_and_in_2D_plane_strain.f90 ================================================ program conversion ! Dimitri Komatitsch, CNRS Marseille, France, July 2018 ! see formulas 9.59 and 9.60 in the book of Dahlen and Tromp, 1998 ! (in that book, P is called alpha and S is called beta). ! See also file formulas_to_convert_between_Qkappa_Qmu_and_Qp_Qs_in_3D_and_in_2D_plane_strain.pdf in this directory. implicit none integer :: iconversion_type integer :: idimension double precision :: Qkappa,Qmu,Qp,Qs,cp,cs double precision :: inverse_of_Qp,inverse_of_Qmu,inverse_of_Qkappa,COEFFICIENT print *,'1 = you want to perform the conversion in 3D' print *,'2 = you want to perform the conversion in 2D plane strain' read(*,*) idimension if (idimension < 1 .or. idimension > 2) stop 'error: incorrect value of idimension' if (idimension == 1) then COEFFICIENT = 4.d0 / 3.d0 else COEFFICIENT = 1.d0 endif print * print *,'1 = you want to convert from (Qp,Qs) to (QKappa,Qmu)' print *,'2 = you want to convert from (QKappa,Qmu) to (Qp,Qs)' read(*,*) iconversion_type if (iconversion_type < 1 .or. iconversion_type > 2) stop 'error: incorrect value of iconversion_type' print * ! get the input values from the user if (iconversion_type == 1) then print *,'enter Qp:' read(*,*) Qp print *,'enter Qs:' read(*,*) Qs print * else print *,'enter QKappa:' read(*,*) QKappa print *,'enter Qmu:' read(*,*) Qmu print * endif ! enter the cp and cs velocities of the medium, at the frequency at which you want this conversion to be performed print *,'enter the cp and cs velocities of the medium, at the frequency at which you want this conversion to be performed:' print *,'enter cp:' read(*,*) cp print *,'enter cs:' read(*,*) cs print * if (iconversion_type == 1) then ! Qmu is always the same as Qs Qmu = Qs ! for QKappa the formula is more complex inverse_of_Qp = 1.d0 / Qp inverse_of_Qmu = 1.d0 / Qmu inverse_of_Qkappa = (inverse_of_Qp - COEFFICIENT*(cs**2)/(cp**2) * inverse_of_Qmu) / (1.d0 - COEFFICIENT*(cs**2)/(cp**2)) Qkappa = 1.d0/inverse_of_Qkappa ! print the result print *,'Qkappa = ',Qkappa print *,'Qmu = ',Qmu else ! if (iconversion_type == 2) then ! Qs is always the same as Qmu Qs = Qmu ! for Qp the formula is more complex inverse_of_Qp = (1.d0 - COEFFICIENT*(cs**2)/(cp**2))/Qkappa + COEFFICIENT*(cs**2)/(cp**2)/Qmu Qp = 1.d0/inverse_of_Qp ! print the result print *,'Qp = ',Qp print *,'Qs = ',Qs endif end program conversion ================================================ FILE: email_from_Youshan_Liu_about_bug_in_the_original_fourth_order_Runge_Kutta_scheme.txt ================================================ Subject: some questions about your CPML code From: ysliu Date: 08/03/2015 05:22 AM To: komatitsch Dear Prof. Komatitsch, Please allow me to introduce myself. My name is Youshan Liu, and I am a doctor student at Institute of Geology and Geophysics of Chinese Academy of Sciences. Ocassionally, I read your code of CPML software package (seismic_ADEPML_2D_elastic_RK4_eighth_order). Unfortunately, I found that your code with Runge-Kutta scheme may be not correct. For ordinary equation: y'(x) = f(x,y). The Runge-Kutta integration include the following four steps: y_n+1 = y_n + h/6*( K_1 + 2*K_2 + 2*K_3 + K_4) K_1 = f(x_n, y_n) K_2 = f(x_n + h/2, y_n + h/2*K_1) K_3 = f(x_n + h/2, y_n + h/2*K_2) K_4 = f(x_n + h , y_n + h*K_3) In your code, K_inc stored in dvx(2,:,:). You may miss the proccess of the linear combination of y_n+1 = y_n + h/6*( K_1 + 2*K_2 + 2*K_3 + K_4). Although you defined the coefficient of the Runge-Kutta stored in array rk42, you never use them. I have modified your code, and I send you. I think that your code may be not correct ! I run the your code and your code modified by me with the identical parameters. Your results may be not correct. When I set the time interval dt = 3ms (Courant number is 0.8485), your original code is unstable, while your code modified me still work. The results have been uploaded in attachment. The su format files can be opened by Fimage.exe. In addition, your code titled by seismic_ADEPML_2D_viscoelastic_RK4_eighth_order may be also not correct. I also improve the code to save much more memory. I think the arrays of memory_dvx_dx, etc. can be allocated only in two dimension. I have try them again. It still work. Unfortunately, I check the original code several times. I found that it may be incorrect. The original coed can not work with the time interval of 3 ms. The modified code can work with the time interval of 3 ms. Best wishes, Youshan LiuS Attachments: elastic_rk4.zip 5.0 MB ================================================ FILE: plotall_fit_is_perfect_for_viscoelastic_fourth_order.gnu ================================================ # this is a comparison of the results of seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic.f90 # and of the analytical solution of analytical_solution_viscoelastic_2D_plane_strain_Carcione_correct_with_1_over_L.f90 seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic.f90 set term x11 set xrange [0:1.2] plot "Vx_file_001.dat" w l lc 1, "Vx_time_analytical_solution_viscoelastic.dat" w l lc 3 pause -1 "Hit any key..." plot "Vy_file_half_a_grid_cell_away_from_Vx_001.dat" w l lc 1, "Vz_time_analytical_solution_viscoelastic.dat" w l lc 3 pause -1 "Hit any key..." ================================================ FILE: seismic_ADEPML_2D_elastic_RK4_eighth_order.f90 ================================================ ! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributors: Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr ! and Youshan Liu, China. ! ! This software is a computer program whose purpose is to solve ! the two-dimensional isotropic elastic wave equation ! using a finite-difference method with Auxiliary Differential ! Equation Perfectly Matched Layer (ADE-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_ADEPML_2D_elastic_RK4_eighth_order ! High order 2D explicit-semi implicit-implicit elastic finite-difference code ! in velocity and stress formulation with Auxiliary Differential ! Equation Perfectly Matched Layer (ADE-PML) absorbing conditions for ! an isotropic elastic medium. It is fourth order Runge-Kutta (RK4) in time ! and 8th order in space using Holberg spatial discretization. ! Version 1.1.3 ! by Roland Martin, University of Pau, France, Jan 2010 ! with a major bug fix in the Runge-Kutta implementation ! and also significant memory usage optimization by Youshan Liu, China, August 2015. ! based on seismic_CPML_2D_isotropic_second_order.f90 ! by Dimitri Komatitsch and Roland Martin, University of Pau, France, 2007. ! The 8th-order staggered-grid formulation of Holberg is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! ! The ADE-PML implementation is based in part on formulas given in Roden and Gedney (2010) ! ! If you use this code for your own research, please cite some (or all) of these articles: ! ! @ARTICLE{MaKoGeBr10, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney and Emilien Bruthiaux}, ! title = {A high-order time and space formulation of the unsplit perfectly matched layer ! for the seismic wave equation using {Auxiliary Differential Equations (ADE-PML)}}, ! journal = {Comput. Model. Eng. Sci.}, ! year = {2010}, ! volume = {56}, ! pages = {17-42}, ! number = {1}} ! ! @ARTICLE{MaCo10, ! author = {Roland Martin and Carlos Couder-Casta{\~n}eda}, ! title = {An improved unsplit and convolutional Perfectly Matched Layer ! absorbing technique for the Navier-Stokes equations using cut-off frequency shift}, ! journal = {Comput. Model. Eng. Sci.}, ! pages ={47-77} ! year = {2010}, ! volume = {63}, ! number = {1}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdelaaziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! total number of grid points in each direction of the grid !integer, parameter :: NX = 101 !integer, parameter :: NY = 641 integer, parameter :: NX = 241 integer, parameter :: NY = 241 ! Explicit (epsn=1,epsn=0), implicit (epsn=0,epsn1=1), semi-implicit (epsn=0.5,epsn1=0.5) integer, parameter :: iexpl=0 integer, parameter :: iimpl=0 integer, parameter :: isemiimpl=1 double precision :: epsn,epsn1 ! size of a grid cell double precision, parameter :: DELTAX = 10.d0 double precision, parameter :: DELTAY = DELTAX ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! thickness of the PML layer in grid points. 8th order in space imposes to ! increase the thickness of the CPML integer, parameter :: NPOINTS_PML = 10 ! P-velocity, S-velocity and density double precision, parameter :: cp = 2000.d0 double precision, parameter :: cs = 1150.d0 double precision, parameter :: density = 2000.d0 !double precision, parameter :: cp = 3300.d0 !double precision, parameter :: cs = 1905.d0 !double precision, parameter :: density = 2800.d0 ! total number of time steps ! the time step is twice smaller for this fourth-order simulation, ! therefore let us double the number of time steps to keep the same total duration integer, parameter :: NSTEP = 2501 ! time step in seconds ! 8th-order in space and 4th-order in time finite-difference schemes ! are less stable than second-order in space and second-order in time, ! therefore let us divide the time step by 2 double precision, parameter :: DELTAT = 3.d-3 ! parameters for the source double precision, parameter :: f0 = 10.d0 double precision, parameter :: t0 = 1.0d0 / f0 double precision, parameter :: factor = 1.d4 ! source !integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1 integer, parameter :: ISOURCE = (NX-1)/2 integer, parameter :: JSOURCE = (NY-1)/2 double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY ! angle of source force clockwise with respect to vertical (Y) axis !double precision, parameter :: ANGLE_FORCE = 135.d0 double precision, parameter :: ANGLE_FORCE = 90.d0 ! receivers !integer, parameter :: NREC = 3 !double precision, parameter :: xdeb = xsource ! first receiver x in meters !double precision, parameter :: ydeb = ysource - 2000.d0 ! first receiver y in meters !double precision, parameter :: xfin = xsource ! last receiver x in meters !double precision, parameter :: yfin = ysource - 4000.d0 ! last receiver y in meters integer, parameter :: NREC = NX double precision, parameter :: xdeb = 0.d0 ! first receiver x in meters double precision, parameter :: ydeb = 50.d0 ! first receiver y in meters double precision, parameter :: xfin = (NX-1)*DELTAX ! last receiver x in meters double precision, parameter :: yfin = 50.d0 ! last receiver y in meters ! display information on the screen from time to time ! the time step is twice smaller for this fourth-order simulation, ! therefore let us double the interval in time steps at which we display information integer, parameter :: IT_DISPLAY = 200 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! Holberg (1987) coefficients, taken from ! @ARTICLE{Hol87, ! author = {O. Holberg}, ! title = {Computational aspects of the choice of operator and sampling interval ! for numerical differentiation in large-scale simulation of wave phenomena}, ! journal = {Geophysical Prospecting}, ! year = {1987}, ! volume = {35}, ! pages = {629-655}} double precision, parameter :: c1 = 1.231666d0 double precision, parameter :: c2 = -1.041182d-1 double precision, parameter :: c3 = 2.063707d-2 double precision, parameter :: c4 = -3.570998d-3 ! RK4 scheme coefficients, 2 per subloop, 8 in total double precision, dimension(4) :: rk41, rk42 ! main arrays double precision, dimension(-4:NX+4,-4:NY+4) :: lambda,mu,rho,vx,vy,sigmaxx,sigmayy,sigmaxy ! variables are stored in four indices in the first dimension to implement RK4 ! dv does not always indicate a derivative double precision, dimension(3,-4:NX+4,-4:NY+4) :: dvx,dvy,dsigmaxx,dsigmayy,dsigmaxy ! to interpolate material parameters at the right location in the staggered grid cell double precision lambda_half_x,mu_half_x,lambda_plus_two_mu_half_x,mu_half_y,rho_half_x_half_y ! for evolution of total energy in the medium double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 double precision, parameter :: NPOWER2 = 2.d0 ! Kappa must be strong enough to absorb energy and low enough to avoid ! reflections. ! Alpha1 must be low to absorb energy and high enough to have efficiency on ! grazing incident waves. double precision, parameter :: K_MAX_PML = 7.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here !!! Youshan Liu suppressed the two comment lines below !!!!!! not true anymore: We have as many memory variables as the number of frequency shift poles in the CPML !!!!!! not true anymore: Indices are 1 and 2 for the 2 frequency shift poles ! ==================== revised by Youshan Liu ================== double precision, dimension(-4:NX+4,-4:NY+4) :: memory_dvx_dx, memory_dvx_dy, memory_dvy_dx, memory_dvy_dy, & memory_dsigmaxx_dx, memory_dsigmayy_dy, & memory_dsigmaxy_dx, memory_dsigmaxy_dy double precision :: value_dvx_dx, value_dvx_dy, value_dvy_dx, value_dvy_dy, & value_dsigmaxx_dx, value_dsigmayy_dy, & value_dsigmaxy_dx, value_dsigmaxy_dy ! 1D arrays for the damping profiles double precision, dimension(-4:NX+4) :: d_x,K_x,alpha_x,g_x,ksi_x double precision, dimension(-4:NX+4) :: d_x_half,K_x_half,alpha_x_half,g_x_half,ksi_x_half double precision, dimension(-4:NY+4) :: d_y,K_y,alpha_y,g_y,ksi_y double precision, dimension(-4:NY+4) :: d_y_half,K_y_half,alpha_y_half,g_y_half,ksi_y_half ! coefficients that allow to reset the memory variables at each RK4 substep depend on the substepping and are then of dimension 4, ! 1D arrays for the damping profiles double precision, dimension(4,-4:NX+4) :: a_x,b_x double precision, dimension(4,-4:NX+4) :: a_x_half,b_x_half double precision, dimension(4,-4:NY+4) :: a_y,b_y double precision, dimension(4,-4:NY+4) :: a_y_half,b_y_half double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized ! for the source double precision :: a,t,force_x,force_y,source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy integer :: i,j,k,it,irec,inc double precision :: Courant_number !define by ysliu 8/2/2015 integer(2) head(1:120) character(80) :: routine real,dimension(NSTEP,NREC) :: seisvx, seisvy real,dimension(NX,NY) :: snapvx,snapvy !--- !--- program starts here !--- if (iexpl == 1) then epsn = 1.d0 epsn1 = 0.d0 endif if (iimpl == 1) then epsn = 0.d0 epsn1 = 1.d0 endif if (isemiimpl == 1) then epsn = 0.5d0 epsn1 = 0.5d0 endif print * print *,'2D elastic finite-difference code in velocity and stress formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.00001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_y) print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print * ! parameters involved in RK4 time expansion rk41(1) = ZERO rk41(2) = 0.5d0 rk41(3) = 0.5d0 rk41(4) = 1.d0 rk42(1) = 1.d0 / 6.d0 rk42(2) = 2.d0 / 6.d0 rk42(3) = 2.d0 / 6.d0 rk42(4) = 1.d0 / 6.d0 ksi_x(:) = ZERO ksi_x_half(:) = ZERO d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:,:) = ZERO a_x_half(:,:) = ZERO g_x(:) = 5.d-1 g_x_half(:) = 5.d-1 ksi_y(:) = ZERO ksi_y_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:,:) = ZERO a_y_half(:,:) = ZERO g_y(:) = 1.d0 g_y_half(:) = 1.d0 ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = -4,NX+4 ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2 alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2 alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2 alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2 alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO ! CPML damping parameters for the 4 sub time steps of RK4 algorithm do inc=1,4 b_x(inc,i) = (1.-epsn*DELTAT*rk41(inc)*(d_x(i)/K_x(i) + alpha_x(i)))/ & (1.+epsn1*DELTAT*rk41(inc)*(d_x(i)/K_x(i) + alpha_x(i))) b_x_half(inc,i) = (1.-epsn*DELTAT*rk41(inc)*(d_x_half(i)/K_x_half(i) & + alpha_x_half(i)))/(1. +epsn1*DELTAT*rk41(inc)*(d_x_half(i)/K_x_half(i) & + alpha_x_half(i))) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(inc,i) = - DELTAT*rk41(inc)*d_x(i) / (K_x(i)* K_x(i))/& (1. +epsn1*DELTAT*rk41(inc)*(d_x(i)/K_x(i) + alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(inc,i) =-DELTAT*rk41(inc)*d_x_half(i)/& (K_x_half(i)*K_x_half(i) )/& (1. +epsn1*DELTAT*rk41(inc)*(d_x_half(i)/K_x_half(i)& + alpha_x_half(i))) enddo enddo !do i = -4,NX+4 ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = -4,NY+4 ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2 alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2 alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2 alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2 alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_y(j) < ZERO) alpha_y(j) = ZERO if (alpha_y_half(j) < ZERO) alpha_y_half(j) = ZERO ! CPML damping parameters for the 4 sub time steps of RK4 algorithm do inc=1,4 b_y(inc,j) = (1.-epsn*DELTAT*rk41(inc)*(d_y(j)/K_y(j) + alpha_y(j)))/ & (1.+epsn1*DELTAT*rk41(inc)*(d_y(j)/K_y(j) + alpha_y(j))) b_y_half(inc,j) = (1.-epsn*DELTAT*rk41(inc)*(d_y_half(j)/K_y_half(j) + & alpha_y_half(j)))/(1.+epsn1*DELTAT*rk41(inc)*(d_y_half(j)/K_y_half(j) & + alpha_y_half(j))) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(inc,j) = - DELTAT*rk41(inc)*d_y(j) & / (K_y(j)* K_y(j))/& (1.+epsn1*DELTAT*rk41(inc)*(d_y(j)/K_y(j) + alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(inc,j) = -DELTAT*rk41(inc)*d_y_half(j) /& (K_y_half(j) * K_y_half(j) )/& (1.+epsn1*DELTAT*rk41(inc)*(d_y_half(j)/K_y_half(j) + alpha_y_half(j))) enddo enddo !do j = -4,NY+4 ! compute the Lame parameters and density do j = -4,NY+4 do i = -4,NX+4 rho(i,j) = density mu(i,j) = density*cs*cs lambda(i,j) = density*(cp*cp - 2.d0*cs*cs) enddo enddo ! print position of the source print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print *,'There are ',nrec,' receivers' print * xspacerec = (xfin-xdeb) / dble(NREC-1) yspacerec = (yfin-ydeb) / dble(NREC-1) do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo !do irec=1,nrec ! check the Courant stability condition for the explicit time scheme ! R. Courant and K. O. Friedrichs and H. Lewy (1928) Courant_number = cp * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2) print *,'Courant number is ',Courant_number print * if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable' ! suppress old files (can be commented out if "call system" is missing in your compiler) ! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif') ! initialize arrays dvx(:,:,:) = ZERO dvy(:,:,:) = ZERO dsigmaxx(:,:,:) = ZERO dsigmayy(:,:,:) = ZERO dsigmaxy(:,:,:) = ZERO vx(:,:) = ZERO vy(:,:) = ZERO sigmaxx(:,:) = ZERO sigmayy(:,:) = ZERO sigmaxy(:,:) = ZERO ! PML memory_dvx_dx(:,:) = ZERO memory_dvx_dy(:,:) = ZERO memory_dvy_dx(:,:) = ZERO memory_dvy_dy(:,:) = ZERO memory_dsigmaxx_dx(:,:) = ZERO memory_dsigmayy_dy(:,:) = ZERO memory_dsigmaxy_dx(:,:) = ZERO memory_dsigmaxy_dy(:,:) = ZERO ! initialize seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO ! initialize total energy total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO !--- !--- beginning of time loop !--- do it = 1,NSTEP !! v and sigma temporary variables of RK4 !====================================================== !====================revised by ysliu================== !backup the current snapshots dvx(2,:,:) = vx(:,:) dvy(2,:,:) = vy(:,:) dsigmaxx(2,:,:) = sigmaxx(:,:) dsigmayy(2,:,:) = sigmayy(:,:) dsigmaxy(2,:,:) = sigmaxy(:,:) dvx(3,:,:) = vx(:,:) dvy(3,:,:) = vy(:,:) dsigmaxx(3,:,:) = sigmaxx(:,:) dsigmayy(3,:,:) = sigmayy(:,:) dsigmaxy(3,:,:) = sigmaxy(:,:) !====================================================== ! RK4 loop (loop on the four RK4 substeps) do inc= 1,4 ! ==================== revised by Youshan Liu ================== ! The new values of the different variables v and sigma are computed dvx(1,:,:) = dvx(3,:,:) + rk41(inc) * dvx(2,:,:) * DELTAT dvy(1,:,:) = dvy(3,:,:) + rk41(inc) * dvy(2,:,:) * DELTAT dsigmaxx(1,:,:) = dsigmaxx(3,:,:) + rk41(inc) * dsigmaxx(2,:,:) * DELTAT dsigmayy(1,:,:) = dsigmayy(3,:,:) + rk41(inc) * dsigmayy(2,:,:) * DELTAT dsigmaxy(1,:,:) = dsigmaxy(3,:,:) + rk41(inc) * dsigmaxy(2,:,:) * DELTAT !------------------ ! compute velocity !------------------ do j = 2,NY do i = 2,NX value_dsigmaxx_dx = ( c1 * (dsigmaxx(1,i,j) - dsigmaxx(1,i-1,j)) + c2 * (dsigmaxx(1,i+1,j) - dsigmaxx(1,i-2,j)) + & c3 * (dsigmaxx(1,i+2,j) - dsigmaxx(1,i-3,j)) + c4 * (dsigmaxx(1,i+3,j) - dsigmaxx(1,i-4,j)) )/ DELTAX value_dsigmaxy_dy = ( c1 * (dsigmaxy(1,i,j) - dsigmaxy(1,i,j-1)) + c2* (dsigmaxy(1,i,j+1) - dsigmaxy(1,i,j-2)) + & c3 * (dsigmaxy(1,i,j+2) - dsigmaxy(1,i,j-3)) + c4 * (dsigmaxy(1,i,j+3) - dsigmaxy(1,i,j-4)) )/ DELTAY if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then ! ==================== revised by Youshan Liu ================== memory_dsigmaxx_dx(i,j) = b_x(inc,i) * memory_dsigmaxx_dx(i,j) + a_x(inc,i) * value_dsigmaxx_dx memory_dsigmaxy_dy(i,j) = b_y(inc,j) * memory_dsigmaxy_dy(i,j) + a_y(inc,j) * value_dsigmaxy_dy value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j) value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j) endif dvx(2,i,j) = (value_dsigmaxx_dx + value_dsigmaxy_dy) / rho(i,j) enddo enddo do j = 1,NY-1 do i = 1,NX-1 ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) value_dsigmaxy_dx = ( c1 * (dsigmaxy(1,i+1,j) - dsigmaxy(1,i,j)) + c2 * (dsigmaxy(1,i+2,j) - dsigmaxy(1,i-1,j)) + & c3 * (dsigmaxy(1,i+3,j) - dsigmaxy(1,i-2,j)) + c4 * (dsigmaxy(1,i+4,j) - dsigmaxy(1,i-3,j)) )/ DELTAX value_dsigmayy_dy = ( c1 * (dsigmayy(1,i,j+1) - dsigmayy(1,i,j)) + c2 * (dsigmayy(1,i,j+2) - dsigmayy(1,i,j-1)) + & c3 * (dsigmayy(1,i,j+3) - dsigmayy(1,i,j-2)) + c4 * (dsigmayy(1,i,j+4) - dsigmayy(1,i,j-3)) )/ DELTAY if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then ! ==================== revised by Youshan Liu ================== memory_dsigmaxy_dx(i,j) = b_x_half(inc,i) * memory_dsigmaxy_dx(i,j) + a_x_half(inc,i) * value_dsigmaxy_dx memory_dsigmayy_dy(i,j) = b_y_half(inc,j) * memory_dsigmayy_dy(i,j) + a_y_half(inc,j) * value_dsigmayy_dy value_dsigmaxy_dx = value_dsigmaxy_dx/K_x_half(i)+memory_dsigmaxy_dx(i,j) value_dsigmayy_dy = value_dsigmayy_dy/K_y_half(j)+memory_dsigmayy_dy(i,j) endif dvy(2,i,j) = (value_dsigmaxy_dx + value_dsigmayy_dy) / rho_half_x_half_y enddo enddo ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = (dble(it-1)+ rk41(inc)) * DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! ! first derivative of a Gaussian source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term ! define location of the source i = ISOURCE j = JSOURCE ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) dvx(2,i,j) = dvx(2,i,j) + force_x / rho(i,j) dvy(2,i,j) = dvy(2,i,j) + force_y / rho_half_x_half_y ! Dirichlet conditions (rigid boundaries) on all the edges of the grid dvx(:,-4:1,:) = ZERO dvx(:,NX:NX+4,:) = ZERO dvx(:,:,-4:1) = ZERO dvx(:,:,NY:NY+4) = ZERO dvy(:,-4:1,:) = ZERO dvy(:,NX:NX+4,:) = ZERO dvy(:,:,-4:1) = ZERO dvy(:,:,NY:NY+4) = ZERO !---------------------- ! compute stress sigma !---------------------- do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda(i+1,j) + lambda(i,j)) mu_half_x = 0.5d0 * (mu(i+1,j) + mu(i,j)) lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x value_dvx_dx = ( c1 * (dvx(1,i+1,j) - dvx(1,i,j)) + c2 * (dvx(1,i+2,j) - dvx(1,i-1,j)) + & c3 * (dvx(1,i+3,j) - dvx(1,i-2,j)) + c4 * (dvx(1,i+4,j) - dvx(1,i-3,j)) )/ DELTAX value_dvy_dy = ( c1 * (dvy(1,i,j) - dvy(1,i,j-1)) + c2 * (dvy(1,i,j+1) - dvy(1,i,j-2)) + & c3 * (dvy(1,i,j+2) - dvy(1,i,j-3)) + c4 * (dvy(1,i,j+3) - dvy(1,i,j-4)) )/ DELTAY if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then ! ==================== revised by Youshan Liu ================== memory_dvx_dx(i,j) = b_x_half(inc,i) * memory_dvx_dx(i,j) + a_x_half(inc,i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(inc,j) * memory_dvy_dy(i,j) + a_y(inc,j) * value_dvy_dy value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j) endif dsigmaxx(2,i,j) = (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) dsigmayy(2,i,j) = (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) enddo enddo do j = 1,NY-1 do i = 2,NX ! interpolate material parameters at the right location in the staggered grid cell mu_half_y = 0.5d0 * (mu(i,j+1) + mu(i,j)) value_dvx_dy = ( c1 * (dvx(1,i,j+1) - dvx(1,i,j)) + c2 * (dvx(1,i,j+2) - dvx(1,i,j-1)) + & c3 * (dvx(1,i,j+3) - dvx(1,i,j-2)) + c4 * (dvx(1,i,j+4) - dvx(1,i,j-3)) )/ DELTAY value_dvy_dx = ( c1 * (dvy(1,i,j) - dvy(1,i-1,j)) + c2 * (dvy(1,i+1,j) - dvy(1,i-2,j)) + & c3 * (dvy(1,i+2,j) - dvy(1,i-3,j)) + c4 * (dvy(1,i+3,j) - dvy(1,i-4,j)) )/ DELTAX if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then ! ==================== revised by Youshan Liu ================== memory_dvy_dx(i,j) = b_x(inc,i) * memory_dvy_dx(i,j) + a_x(inc,i) * value_dvy_dx memory_dvx_dy(i,j) = b_y_half(inc,j) * memory_dvx_dy(i,j) + a_y_half(inc,j) * value_dvx_dy value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j) value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j) endif dsigmaxy(2,i,j) = mu_half_y * (value_dvy_dx + value_dvx_dy) enddo enddo ! ==================== revised by Youshan Liu ================== ! the new values of the different variables v and sigma are computed vx(:,:) = vx(:,:) + rk42(inc) * dvx(2,:,:) * DELTAT vy(:,:) = vy(:,:) + rk42(inc) * dvy(2,:,:) * DELTAT sigmaxx(:,:) = sigmaxx(:,:) + rk42(inc) * dsigmaxx(2,:,:) * DELTAT sigmayy(:,:) = sigmayy(:,:) + rk42(inc) * dsigmayy(2,:,:) * DELTAT sigmaxy(:,:) = sigmaxy(:,:) + rk42(inc) * dsigmaxy(2,:,:) * DELTAT !! Dirichlet conditions (rigid boundaries) on all the edges of the grid vx(-4:1,:) = ZERO vx(:,-4:1) = ZERO vy(-4:1,:) = ZERO vy(:,-4:1) = ZERO vx(NX:NX+4,:) = ZERO vx(:,NY:NY+4) = ZERO vy(NX:NX+4,:) = ZERO vy(:,NY:NY+4) = ZERO enddo ! end of RK4 loop ! store seismograms do irec = 1,NREC sisvx(it,irec) = (vx(ix_rec(irec),iy_rec(irec))+ & vx(ix_rec(irec)+1,iy_rec(irec))+ & vx(ix_rec(irec),iy_rec(irec)+1)+ & vx(ix_rec(irec)+1,iy_rec(irec)+1))/4.d0 sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec)) enddo !! compute total energy in the medium (without the PML layers) ! !! compute kinetic energy first, defined as 1/2 rho ||v||^2 !! in principle we should use rho_half_x_half_y instead of rho for vy !! in order to interpolate density at the right location in the staggered grid cell !! but in a homogeneous medium we can safely ignore it ! total_energy_kinetic(it) = 0.5d0 * sum( & ! rho(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)*( & ! vx(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)**2 + & ! vy(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)**2)) ! !! add potential energy, defined as 1/2 epsilon_ij sigma_ij !! in principle we should interpolate the medium parameters at the right location !! in the staggered grid cell but in a homogeneous medium we can safely ignore it ! total_energy_potential(it) = ZERO ! do j = NPOINTS_PML+1, NY-NPOINTS_PML ! do i = NPOINTS_PML+1, NX-NPOINTS_PML ! epsilon_xx = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmaxx(i,j) - lambda(i,j) * & ! sigmayy(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j))) ! epsilon_yy = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmayy(i,j) - lambda(i,j) * & ! sigmaxx(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j))) ! epsilon_xy = sigmaxy(i,j) / (2.d0 * mu(i,j)) ! total_energy_potential(it) = total_energy_potential(it) + & ! 0.5d0 * (epsilon_xx * sigmaxx(i,j) + epsilon_yy * sigmayy(i,j) + 2.d0 * epsilon_xy * sigmaxy(i,j)) ! enddo ! enddo if (mod(it,IT_DISPLAY) == 0) then write(*,*) it, ' of ', nstep head=0 head(58) = NY head(59) = DELTAY * 1E3 snapvx = vx(1:NX,1:NY) snapvy = vy(1:NX,1:NY) write(routine,'(a12,i5.5,a9)') './snapshots/',it,'snapVx.su' open(21,file=routine,access='stream') do j = 1,NX,1 write(21) head,(real(snapvx(k,j)),k=1,NY) enddo close(21) write(routine,'(a12,i5.5,a9)') './snapshots/',it,'snapVy.su' open(21,file=routine,access='stream') do j = 1,NX,1 write(21) head,(real(snapvy(k,j)),k=1,NY) enddo close(21) endif !! output information ! if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! !! print maximum of norm of velocity ! velocnorm = maxval(sqrt(vx**2 + vy**2)) ! print *,'Time step # ',it ! print *,'Time: ',sngl((it-1)*DELTAT),' seconds' ! print *,'Max norm velocity vector V (m/s) = ',velocnorm ! print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) ! print * !! check stability of the code, exit if unstable ! if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' ! ! call create_color_image(vx(1:NX,1:NY),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & ! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1) ! call create_color_image(vy(1:NX,1:NY),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & ! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2) ! open(unit=20,file='energy.dat',status='unknown') ! do it2 = 1,NSTEP ! write(20,*) sngl(dble(it2-1)*DELTAT),sngl(total_energy_kinetic(it2)), & ! sngl(total_energy_potential(it2)),sngl(total_energy_kinetic(it2) + total_energy_potential(it2)) ! enddo ! close(20) ! call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) ! ! endif enddo ! end of time loop ! save seismograms !save seismogram in SU format write(*,*) NREC,nstep seisvx = sisvx seisvy = sisvy head=0 head(58)=nstep head(59)=deltat*1e6 open(21,file='./seismograms/seisVx.su',access='stream') do j=1,NREC,1 write(21) head,(real(seisvx(k,j)),k=1,nstep) enddo close(21) open(21,file='./seismograms/seisVy.su',access='stream') do j=1,NREC,1 write(21) head,(real(seisvy(k,j)),k=1,nstep) enddo close(21) !call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) !! save total energy !open(unit=20,file='energy.dat',status='unknown') ! do it = 1,NSTEP ! write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & ! sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it)) ! enddo !close(20) !! create script for Gnuplot for total energy ! open(unit=20,file='plot_energy',status='unknown') ! write(20,*) '# set term x11' ! write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' ! write(20,*) ! write(20,*) 'set xlabel "Time (s)"' ! write(20,*) 'set ylabel "Total energy"' ! write(20,*) ! write(20,*) 'set output "cpml_total_energy_semilog.eps"' ! write(20,*) 'set logscale y' ! write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & ! & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' ! write(20,*) 'pause -1 "Hit any key..."' ! write(20,*) ! close(20) ! ! open(unit=20,file='plot_comparison',status='unknown') ! write(20,*) '# set term x11' ! write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' ! write(20,*) ! write(20,*) 'set xlabel "Time (s)"' ! write(20,*) 'set ylabel "Total energy"' ! write(20,*) ! write(20,*) 'set output "compare_total_energy_semilog.eps"' ! write(20,*) 'set logscale y' ! write(20,*) 'plot "energy.dat" us 1:4 t ''Total energy CPML'' w l lc 1, & ! & "../collino/energy.dat" us 1:4 t ''Total energy Collino'' w l lc 2' ! write(20,*) 'pause -1 "Hit any key..."' ! write(20,*) ! close(20) ! !! create script for Gnuplot ! open(unit=20,file='plotgnu',status='unknown') ! write(20,*) 'set term x11' ! write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' ! write(20,*) ! write(20,*) 'set xlabel "Time (s)"' ! write(20,*) 'set ylabel "Amplitude (m / s)"' ! write(20,*) ! ! write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' ! write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' ! write(20,*) 'pause -1 "Hit any key..."' ! write(20,*) ! ! write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' ! write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' ! write(20,*) 'pause -1 "Hit any key..."' ! write(20,*) ! ! write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' ! write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' ! write(20,*) 'pause -1 "Hit any key..."' ! write(20,*) ! ! write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' ! write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' ! write(20,*) 'pause -1 "Hit any key..."' ! write(20,*) ! ! close(20) print * print *,'End of the simulation' print * end program seismic_ADEPML_2D_elastic_RK4_eighth_order !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT) implicit none integer nt,nrec double precision DELTAT double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_ADEPML_2D_viscoelastic_RK4_eighth_order.f90 ================================================ ! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributors: Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr ! and Ruiqi Shi and Youshan Liu, China. ! ! RK4 bug detected by Youshan Liu, China fixed by Quentin Brissaud, France and also Caltech (USA) in this version in March 2018. ! ! Ruiqi Shi, Department of Exploration Geophysics, China University of Petroleum, Beijing, China. ! Email: shiruiqi123 AT gmail DOT com ! ! This software is a computer program whose purpose is to solve ! the two-dimensional viscoelastic wave equation ! using a finite-difference method with Auxiliary Differential ! Equation Perfectly Matched Layer (ADE-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_ADEPML_2D_viscoelastic_RK4_eighth_order ! High order 2D explicit-semi implicit-implicit viscoelastic finite-difference code ! in velocity and stress formulation with Auxiliary Differential ! Equation Perfectly Matched Layer (ADE-PML) absorbing conditions for ! an SLS viscoelastic medium. It is fourth order Runge-Kutta (RK4) in time ! and 8th order in space using Holberg spatial discretization. ! Version 1.1.3 ! by Roland Martin, University of Pau, France, Jan 2010 ! with improvements by Ruiqi Shi and ! with a major bug fix in the Runge-Kutta implementation ! and also significant memory usage optimization by Youshan Liu, China, August 2015. ! based on seismic_CPML_2D_isotropic_second_order.f90 ! by Dimitri Komatitsch and Roland Martin, University of Pau, France, 2007. ! *BEWARE* that the attenuation model implemented below is that of J. M. Carcione, ! Seismic modeling in viscoelastic media, Geophysics, vol. 58(1), p. 110-120 (1993), which is NON causal, ! i.e., waves speed up instead of slowing down when turning attenuation on. ! This comes from the fact that in that model the relaxed state at zero frequency is used as a reference instead of ! the unrelaxed state at infinite frequency. These days a causal model should be used instead, ! i.e. one using the unrelaxed state at infinite frequency as a reference. ! The 8th-order staggered-grid formulation of Holberg is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! ! The ADE-PML implementation is based in part on formulas given in Roden and Gedney (2010) ! ! If you use this code for your own research, please cite some (or all) of these articles: ! ! @Article{BlKoChLoXi15, ! Title = {Positivity-preserving highly-accurate optimization of the {Z}ener viscoelastic model, with application ! to wave propagation in the presence of strong attenuation}, ! Author = {\'Emilie Blanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard and Zhinan Xie}, ! Journal = {Geophysical Journal International}, ! Year = {2015}, ! Note = {in press.}} ! ! @ARTICLE{MaKoGeBr10, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney and Emilien Bruthiaux}, ! title = {A high-order time and space formulation of the unsplit perfectly matched layer ! for the seismic wave equation using {Auxiliary Differential Equations (ADE-PML)}}, ! journal = {Comput. Model. Eng. Sci.}, ! year = {2010}, ! volume = {56}, ! pages = {17-42}, ! number = {1}} ! ! @ARTICLE{MaCo10, ! author = {Roland Martin and Carlos Couder-Casta{\~n}eda}, ! title = {An improved unsplit and convolutional Perfectly Matched Layer ! absorbing technique for the Navier-Stokes equations using cut-off frequency shift}, ! journal = {Comput. Model. Eng. Sci.}, ! pages ={47-77} ! year = {2010}, ! volume = {63}, ! number = {1}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdelaaziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! total number of grid points in each direction of the grid integer, parameter :: NX = 141 integer, parameter :: NY = 621 ! NY = 800 ! Explicit (epsn=1,epsn=0), implicit (epsn=0,epsn1=1), semi-implicit (epsn=0.5,epsn1=0.5) integer, parameter :: iexpl=0 integer, parameter :: iimpl=0 integer, parameter :: isemiimpl=1 ! size of a grid cell double precision, parameter :: DELTAX = 5.d0, ONE_OVER_DELTAX = 1.d0 / DELTAX double precision, parameter :: DELTAY = DELTAX double precision, parameter :: ONE_OVER_DELTAY = ONE_OVER_DELTAX double precision, parameter :: ONE=1.d0,TWO=2.d0, DIM=2.d0 ! P-velocity, S-velocity and density double precision, parameter :: cp_top = 3050.d0 double precision, parameter :: cs_top = 1950.d0 double precision, parameter :: rho_top = 2000.d0 double precision, parameter :: mu_top = rho_top*cs_top*cs_top double precision, parameter :: lambda_top = rho_top*(cp_top*cp_top - 2.d0*cs_top*cs_top) double precision, parameter :: lambdaplustwomu_top = rho_top*cp_top*cp_top double precision, parameter :: cp_bottom = 2600.d0 double precision, parameter :: cs_bottom = 1500.d0 double precision, parameter :: rho_bottom = 1500.d0 double precision, parameter :: mu_bottom = rho_bottom*cs_bottom*cs_bottom double precision, parameter :: lambda_bottom = rho_bottom*(cp_bottom*cp_bottom - 2.d0*cs_bottom*cs_bottom) double precision, parameter :: lambdaplustwomu_bottom = rho_bottom*cp_bottom*cp_bottom ! total number of time steps integer, parameter :: NSTEP = 5000 ! time step in seconds double precision, parameter :: DELTAT = 5.d-4 ! parameters for the source double precision, parameter :: f0 = 15.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d5 ! parameters for attenuation ! number of standard linear solids integer, parameter :: N_SLS = 2 ! Qp approximately equal to 13, Qkappa approximately to 20 and Qmu / Qs approximately to 10 double precision, parameter :: QKappa_att = 20.d0, QMu_att = 10.d0 double precision, parameter :: f0_attenuation = 16 ! in Hz ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! heterogeneous model and height of the interface logical, parameter :: HETEROGENEOUS_MODEL = .true. ! source ! integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1 integer, parameter :: ISOURCE = NPOINTS_PML+11 integer, parameter :: JSOURCE = 2*NY / 3 double precision, parameter :: xsource = (ISOURCE) * DELTAX double precision, parameter :: ysource = (JSOURCE) * DELTAY double precision, parameter :: INTERFACE_HEIGHT = ysource - 125*DELTAY integer, parameter:: JINTERFACE=INT(INTERFACE_HEIGHT/DELTAY)+1 ! angle of source force clockwise with respect to vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 45.d0 ! receivers integer, parameter :: NREC = 3 double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters double precision, parameter :: xfin = xsource ! last receiver x in meters double precision, parameter :: yfin = 300.d0 ! last receiver y in meters ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 500 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! Holberg (1987) coefficients, taken from ! @ARTICLE{Hol87, ! author = {O. Holberg}, ! title = {Computational aspects of the choice of operator and sampling interval ! for numerical differentiation in large-scale simulation of wave phenomena}, ! journal = {Geophysical Prospecting}, ! year = {1987}, ! volume = {35}, ! pages = {629-655}} double precision, parameter :: c1 = 1.231666d0 double precision, parameter :: c2 = -1.041182d-1 double precision, parameter :: c3 = 2.063707d-2 double precision, parameter :: c4 = -3.570998d-3 double precision, parameter :: coefficient_sum = abs(c1)+abs(c2)+abs(c3)+abs(c4) ! RK4 scheme coefficients, 2 per subloop, 8 in total double precision, dimension(4) :: rk41, rk42 ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 double precision, parameter :: NPOWER2 = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 !double precision, parameter :: K_MAX_PML = 7.d0 ! double precision, parameter :: ALPHA_MAX_PML = 0.d0 ! from Festa and Vilotte double precision, parameter :: ALPHA_MAX_PML_1 = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte double precision K_MAX_PML_1 ! double precision, parameter :: K_MAX_PML_2 = K_MAX_PML_1 / 15.d0 ! double precision, parameter :: K_MAX_PML_2 = K_MAX_PML_1 ! double precision, parameter :: ALPHA_MAX_PML_2 = ALPHA_MAX_PML_1 / 5.d0 ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here ! We have as many memory variables as the number of frequency shift poles in the CPML ! Indices are 1 and 2 for the 2 frequency shift poles double precision, dimension(4,-4:NX+4,-4:NY+4) :: & memory_dvx_dx_1, & memory_dvx_dy_1, & memory_dvy_dx_1, & memory_dvy_dy_1, & memory_dsigmaxx_dx_1, & memory_dsigmayy_dy_1, & memory_dsigmaxy_dx_1, & memory_dsigmaxy_dy_1 double precision, dimension(-4:NX+4,-4:NY+4) :: & memory_vx_dx_1, & memory_vx_dy_1, & memory_vy_dx_1, & memory_vy_dy_1, & memory_sigmaxx_dx_1, & memory_sigmayy_dy_1, & memory_sigmaxy_dx_1, & memory_sigmaxy_dy_1 double precision :: & value_dvx_dx, & value_dvx_dy, & value_dvy_dx, & value_dvy_dy, & value_dsigmaxx_dx, & value_dsigmayy_dy, & value_dsigmaxy_dx, & value_dsigmaxy_dy double precision :: duxdx,duxdy,duydx,duydy,div double precision :: epsn,epsn1,Sn ! 1D arrays for the damping profiles double precision, dimension(-4:NX+4) :: d_x_1,K_x_1,alpha_prime_x_1,g_x_1,ksi_x double precision, dimension(-4:NX+4) :: d_x_half_1,K_x_half_1,alpha_prime_x_half_1,g_x_half_1,ksi_x_half double precision, dimension(-4:NY+4) :: d_y_1,K_y_1,alpha_prime_y_1,g_y_1,ksi_y double precision, dimension(-4:NY+4) :: d_y_half_1,K_y_half_1,alpha_prime_y_half_1,g_y_half_1,ksi_y_half ! 1D arrays for the damping profiles double precision, dimension(-4:NX+4) :: d_x_2,K_x_2,alpha_prime_x_2,g_x_2 double precision, dimension(-4:NX+4) :: d_x_half_2,K_x_half_2,alpha_prime_x_half_2,g_x_half_2 double precision, dimension(-4:NY+4) :: d_y_2,K_y_2,alpha_prime_y_2,g_y_2 double precision, dimension(-4:NY+4) :: d_y_half_2,K_y_half_2,alpha_prime_y_half_2,g_y_half_2 ! coefficients that allow to reset the memory variables at each RK4 substep depend on the substepping and are then of dimension 4, ! 1D arrays for the damping profiles double precision, dimension(4,-4:NX+4) :: a_x_1,b_x_1 double precision, dimension(4,-4:NX+4) :: a_x_half_1,b_x_half_1 double precision, dimension(4,-4:NY+4) :: a_y_1,b_y_1 double precision, dimension(4,-4:NY+4) :: a_y_half_1,b_y_half_1 double precision, dimension(-4:NX+4) :: r_x_1,s_x_1 double precision, dimension(-4:NX+4) :: r_x_half_1,s_x_half_1 double precision, dimension(-4:NY+4) :: r_y_1,s_y_1 double precision, dimension(-4:NY+4) :: r_y_half_1,s_y_half_1 ! 1D arrays for the damping profiles double precision, dimension(4,-4:NX+4) :: a_x_2 double precision, dimension(4,-4:NX+4) :: a_x_half_2 double precision, dimension(4,-4:NY+4) :: a_y_2 double precision, dimension(4,-4:NY+4) :: a_y_half_2 ! PML double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized double precision, dimension(-4:NX+4,-4:NY+4) :: vx,vy,sigmaxx,sigmayy,sigmaxy double precision, dimension(-4:NX+4,-4:NY+4) :: sigmaxx_R,sigmayy_R,sigmaxy_R double precision, dimension(N_SLS,-4:NX+4,-4:NY+4) :: e1,e11,e22,e12 double precision, dimension(-4:NX+4,-4:NY+4) :: rho, mu,lambda,lambdaplustwomu double precision rho_half_x_half_y ! variables are stored in four indices in the first dimension to implement RK4 ! dv does not always indicate a derivative double precision, dimension(4,-4:NX+4,-4:NY+4) :: dvx,dvy,dsigmaxx,dsigmayy,dsigmaxy double precision, dimension(4,-4:NX+4,-4:NY+4) :: dsigmaxx_R,dsigmayy_R,dsigmaxy_R double precision, dimension(N_SLS,4,-4:NX+4,-4:NY+4) :: de1,de11,de12 integer, parameter :: number_of_2Darrays = 2*8 integer, parameter :: number_of_3Darrays = 32 ! for the source double precision a,t,force_x,force_y,source_term ! for attenuation double precision :: f_min_attenuation, f_max_attenuation double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,tau_epsilon_nu2,tau_sigma_nu2 ! for stability estimate double precision :: c_max,c_min ! for receivers double precision distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy ! max amplitude for color snapshots double precision max_amplitudeVx double precision max_amplitudeVy ! for evolution of total energy in the medium double precision :: epsilon_xx,epsilon_yy,epsilon_xy double precision, dimension(NSTEP) :: total_energy,total_energy_kinetic,total_energy_potential double precision :: local_energy_kinetic,local_energy_potential integer :: irec,inc double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed double precision :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed double precision :: Mu_nu1,Mu_nu2 double precision :: phi_nu1(N_SLS) double precision :: phi_nu2(N_SLS) double precision :: tauinv,inv_tau_sigma_nu1(N_SLS) double precision :: taumin,taumax, tau1, tau2, tau3, tau4 double precision :: inv_tau_sigma_nu2(N_SLS) integer :: i,j,it,it2 double precision :: Vsolidnorm double precision Courant_number_bottom,Courant_number_top double precision Dispersion_number_bottom,Dispersion_number_top ! timer to count elapsed time character(len=8) datein character(len=10) timein character(len=5) :: zone integer, dimension(8) :: time_values integer ihours,iminutes,iseconds,int_tCPU double precision :: time_start,time_end,tCPU ! names of the time stamp files character(len=150) outputname ! main I/O file integer, parameter :: IOUT = 41 !--- !--- the program starts here !--- if (iexpl == 1) then epsn = 1.d0 epsn1 = 0.d0 endif if (iimpl == 1) then epsn = 0.d0 epsn1 = 1.d0 endif if (isemiimpl == 1) then epsn = 0.5d0 epsn1 = 0.5d0 endif ! attenuation constants for standard linear solids ! nu1 is the dilatation/incompressibility mode (QKappa) ! nu2 is the shear mode (Qmu) ! array index (1) is the first standard linear solid, (2) is the second etc. ! from J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics, ! vol. 58(1), p. 110-120 (1993) for two memory-variable mechanisms (page 112). ! Beware: these values implement specific values of the quality factors: ! Qp approximately equal to 13, Qkappa approximately to 20 and Qmu / Qs approximately to 10, ! which means very high attenuation, see that paper for details. ! tau_epsilon_nu1(1) = 0.0334d0 ! tau_sigma_nu1(1) = 0.0303d0 ! tau_epsilon_nu2(1) = 0.0352d0 ! tau_sigma_nu2(1) = 0.0287d0 ! tau_epsilon_nu1(2) = 0.0028d0 ! tau_sigma_nu1(2) = 0.0025d0 ! tau_epsilon_nu2(2) = 0.0029d0 ! tau_sigma_nu2(2) = 0.0024d0 ! from J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation ! in a linear viscoelastic medium, Geophysical Journal International, ! vol. 95, p. 597-611 (1988) for two memory-variable mechanisms (page 604). ! Beware: these values implement specific values of the quality factors: ! Qkappa approximately to 27 and Qmu / Qs approximately to 20, ! which means very high attenuation, see that paper for details. ! tau_epsilon_nu1(1) = 0.0325305d0 ! tau_sigma_nu1(1) = 0.0311465d0 ! tau_epsilon_nu2(1) = 0.0332577d0 ! tau_sigma_nu2(1) = 0.0304655d0 ! tau_epsilon_nu1(2) = 0.0032530d0 ! tau_sigma_nu1(2) = 0.0031146d0 ! tau_epsilon_nu2(2) = 0.0033257d0 ! tau_sigma_nu2(2) = 0.0030465d0 ! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0) f_min_attenuation = exp(log(f0_attenuation)-log(12.d0)/2.d0) f_max_attenuation = 12.d0 * f_min_attenuation ! use new SolvOpt nonlinear optimization with constraints from Emilie Blanc, Bruno Lombard and Dimitri Komatitsch ! to compute attenuation mechanisms call compute_attenuation_coeffs(N_SLS,QKappa_att,f0_attenuation,f_min_attenuation,f_max_attenuation, & tau_epsilon_nu1,tau_sigma_nu1) call compute_attenuation_coeffs(N_SLS,QMu_att,f0_attenuation,f_min_attenuation,f_max_attenuation, & tau_epsilon_nu2,tau_sigma_nu2) print * print *,'with new SolvOpt routine for attenuation:' print * print *,'N_SLS, QKappa_att, QMu_att = ',N_SLS, QKappa_att, QMu_att print *,'f0_attenuation,f_min_attenuation,f_max_attenuation = ',f0_attenuation,f_min_attenuation,f_max_attenuation print *,'tau_epsilon_nu1 = ',tau_epsilon_nu1 print *,'tau_sigma_nu1 = ',tau_sigma_nu1 print *,'tau_epsilon_nu2 = ',tau_epsilon_nu2 print *,'tau_sigma_nu2 = ',tau_sigma_nu2 print * tau1 = tau_sigma_nu1(1)/tau_epsilon_nu1(1) tau2 = tau_sigma_nu2(1)/tau_epsilon_nu2(1) tau3 = tau_sigma_nu1(2)/tau_epsilon_nu1(2) tau4 = tau_sigma_nu2(2)/tau_epsilon_nu2(2) taumax = max(1.d0/tau1,1.d0/tau2,1.d0/tau3,1.d0/tau4) taumin = min(1.d0/tau1,1.d0/tau2,1.d0/tau3,1.d0/tau4) inv_tau_sigma_nu1(1) = ONE / tau_sigma_nu1(1) inv_tau_sigma_nu2(1) = ONE / tau_sigma_nu2(1) inv_tau_sigma_nu1(2) = ONE / tau_sigma_nu1(2) inv_tau_sigma_nu2(2) = ONE / tau_sigma_nu2(2) phi_nu1(1) = (ONE - tau_epsilon_nu1(1)/tau_sigma_nu1(1)) / tau_sigma_nu1(1) phi_nu2(1) = (ONE - tau_epsilon_nu2(1)/tau_sigma_nu2(1)) / tau_sigma_nu2(1) phi_nu1(2) = (ONE - tau_epsilon_nu1(2)/tau_sigma_nu1(2)) / tau_sigma_nu1(2) phi_nu2(2) = (ONE - tau_epsilon_nu2(2)/tau_sigma_nu2(2)) / tau_sigma_nu2(2) Mu_nu1 = ONE - (ONE - tau_epsilon_nu1(1)/tau_sigma_nu1(1)) - (ONE - tau_epsilon_nu1(2)/tau_sigma_nu1(2)) Mu_nu2 = ONE - (ONE - tau_epsilon_nu2(1)/tau_sigma_nu2(1)) - (ONE - tau_epsilon_nu2(2)/tau_sigma_nu2(2)) print * print *,'2D visco-elastic FD code in velocity and stress formulation with ADE in 8th an RK4' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print * print *,'size of the model along X = ',(NX+1) * DELTAX print *,'size of the model along Y = ',(NY+1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print *,'Number of points of all the arrays = ',dble(NX+4*2+1)*dble(NY+4*2+1)*number_of_2Darrays + & 4*dble(NX+4*2+1)*dble(NY+4*2+1)*number_of_3Darrays print *,'Size in GB of all the arrays = ',dble(NX+4*2+1)*dble(NY+4*2+1)*number_of_2Darrays*8.d0/(1024.d0*1024.d0*1024.d0) + & 4*dble(NX+4*2+1)*dble(NY+4*2+1)*number_of_3Darrays*8.d0/(1024.d0*1024.d0*1024.d0) !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 1.d-5 c_max = max(cp_bottom,cp_top) c_min = min(cs_bottom,cs_top) K_MAX_PML_1 = 1.d0 print *,'K_MAX_PML = ',K_MAX_PML_1 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf if (HETEROGENEOUS_MODEL) then d0_x = - (NPOWER + 1) * c_max *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * c_max *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_y) else d0_x = - (NPOWER + 1) * cp_bottom *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp_bottom *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_y) endif print * print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y ! parameters involved in RK4 time expansion rk41(1) = ZERO rk41(2) = 0.5d0 rk41(3) = 0.5d0 rk41(4) = 1.d0 rk42(1) = 1.d0 / 6.d0 rk42(2) = 2.d0 / 6.d0 rk42(3) = 2.d0 / 6.d0 rk42(4) = 1.d0 / 6.d0 ksi_x(:) = ZERO ksi_x_half(:) = ZERO d_x_1(:) = ZERO d_x_half_1(:) = ZERO K_x_1(:) = 1.d0 K_x_half_1(:) = 1.d0 alpha_prime_x_1(:) = ZERO alpha_prime_x_half_1(:) = ZERO a_x_1(:,:) = ZERO a_x_half_1(:,:) = ZERO g_x_1(:) = 5.d-1 g_x_half_1(:) = 5.d-1 ksi_y(:) = ZERO ksi_y_half(:) = ZERO d_y_1(:) = ZERO d_y_half_1(:) = ZERO K_y_1(:) = 1.d0 K_y_half_1(:) = 1.d0 alpha_prime_y_1(:) = ZERO alpha_prime_y_half_1(:) = ZERO a_y_1(:,:) = ZERO a_y_half_1(:,:) = ZERO g_y_1(:) = 1.d0 g_y_half_1(:) = 1.d0 d_x_2(:) = ZERO d_x_half_2(:) = ZERO K_x_2(:) = 1.d0 K_x_half_2(:) = 1.d0 alpha_prime_x_2(:) = ZERO alpha_prime_x_half_2(:) = ZERO a_x_2(:,:) = ZERO a_x_half_2(:,:) = ZERO g_x_2(:) = 1.d0 g_x_half_2(:) = 1.d0 d_y_2(:) = ZERO d_y_half_2(:) = ZERO K_y_2(:) = 1.d0 K_y_half_2(:) = 1.d0 alpha_prime_y_2(:) = ZERO alpha_prime_y_half_2(:) = ZERO a_y_2(:,:) = ZERO a_y_half_2(:,:) = ZERO g_y_2(:) = 1.d0 g_y_half_2(:) =1.d0 r_x_1(:) = ZERO s_x_1(:) = ZERO r_x_half_1(:) = ZERO s_x_half_1(:) = ZERO r_y_1(:) = ZERO s_y_1(:) = ZERO r_y_half_1(:) = ZERO s_y_half_1(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = -4,NX+4 ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_1(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_1(i) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2 alpha_prime_x_1(i) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half_1(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half_1(i) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2 alpha_prime_x_half_1(i) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_1(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_1(i) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2 alpha_prime_x_1(i) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half_1(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half_1(i) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2 alpha_prime_x_half_1(i) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized) endif endif ! 1 pole d_x_2(i) = 0.d0 d_x_half_2(i) = 0.d0 ! just in case, for -5 at the end if (alpha_prime_x_1(i) < ZERO) alpha_prime_x_1(i) = ZERO if (alpha_prime_x_half_1(i) < ZERO) alpha_prime_x_half_1(i) = ZERO ! just in case, for -5 at the end if (alpha_prime_x_2(i) < ZERO) alpha_prime_x_2(i) = ZERO if (alpha_prime_x_half_2(i) < ZERO) alpha_prime_x_half_2(i) = ZERO ! CPML damping parameters for the 4 sub time steps of RK4 algorithm do inc=1,4 b_x_1(inc,i) = (1.-epsn*DELTAT*rk41(inc)*(d_x_1(i)/K_x_1(i) + alpha_prime_x_1(i)))/& (1.+epsn1*DELTAT*rk41(inc)*(d_x_1(i)/K_x_1(i) + alpha_prime_x_1(i))) b_x_half_1(inc,i) = (1.-epsn*DELTAT*rk41(inc)*(d_x_half_1(i)/K_x_half_1(i) & + alpha_prime_x_half_1(i)))/(1. +epsn1*DELTAT*rk41(inc)*(d_x_half_1(i)/K_x_half_1(i) & + alpha_prime_x_half_1(i))) ! this to avoid division by zero outside the PML if (abs(d_x_1(i)) > 1.d-6) a_x_1(inc,i) = - DELTAT*rk41(inc)*d_x_1(i) / (K_x_1(i)* K_x_1(i))/& (1. +epsn1*DELTAT*rk41(inc)*(d_x_1(i)/K_x_1(i) + alpha_prime_x_1(i))) if (abs(d_x_half_1(i)) > 1.d-6) a_x_half_1(inc,i) =-DELTAT*rk41(inc)*d_x_half_1(i)/& (K_x_half_1(i)*K_x_half_1(i) )/& (1. +epsn1*DELTAT*rk41(inc)*(d_x_half_1(i)/K_x_half_1(i)& + alpha_prime_x_half_1(i))) r_x_1(i) = -(d_x_1(i)/K_x_1(i) + alpha_prime_x_1(i)) s_x_1(i) = - d_x_1(i)/K_x_1(i)/K_x_1(i) r_x_half_1(i) = -(d_x_half_1(i)/K_x_half_1(i) + alpha_prime_x_half_1(i)) s_x_half_1(i) = - d_x_half_1(i)/K_x_half_1(i)/K_x_half_1(i) enddo enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = -4,NY+4 ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_1(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_1(j) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2 alpha_prime_y_1(j) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half_1(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half_1(j) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2 alpha_prime_y_half_1(j) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_1(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_1(j) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2 alpha_prime_y_1(j) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half_1(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half_1(j) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2 alpha_prime_y_half_1(j) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_prime_y_1(j) < ZERO) alpha_prime_y_1(j) = ZERO if (alpha_prime_y_half_1(j) < ZERO) alpha_prime_y_half_1(j) = ZERO ! CPML damping parameters for the 4 sub time steps of RK4 algorithm do inc=1,4 b_y_1(inc,j) = (1.-epsn*DELTAT*rk41(inc)*(d_y_1(j)/K_y_1(j) + alpha_prime_y_1(j)))/& (1.+epsn1*DELTAT*rk41(inc)*(d_y_1(j)/K_y_1(j) + alpha_prime_y_1(j))) b_y_half_1(inc,j) = (1.-epsn*DELTAT*rk41(inc)*(d_y_half_1(j)/K_y_half_1(j) + & alpha_prime_y_half_1(j)))/(1.+epsn1*DELTAT*rk41(inc)*(d_y_half_1(j)/K_y_half_1(j)& + alpha_prime_y_half_1(j))) ! this to avoid division by zero outside the PML if (abs(d_y_1(j)) > 1.d-6) a_y_1(inc,j) = - DELTAT*rk41(inc)*d_y_1(j)& / (K_y_1(j)* K_y_1(j))/& (1.+epsn1*DELTAT*rk41(inc)*(d_y_1(j)/K_y_1(j) + alpha_prime_y_1(j))) if (abs(d_y_half_1(j)) > 1.d-6) a_y_half_1(inc,j) = -DELTAT*rk41(inc)*d_y_half_1(j) /& (K_y_half_1(j) * K_y_half_1(j) )/& (1.+epsn1*DELTAT*rk41(inc)*(d_y_half_1(j)/K_y_half_1(j) + alpha_prime_y_half_1(j))) enddo r_y_1(j) = -(d_y_1(j)/K_y_1(j) + alpha_prime_y_1(j)) s_y_1(j) = - d_y_1(j)/K_y_1(j)/K_y_1(j) r_y_half_1(j) = -(d_y_half_1(j)/K_y_half_1(j) + alpha_prime_y_half_1(j)) s_y_half_1(j) = - d_y_half_1(j)/K_y_half_1(j)/K_y_half_1(j) enddo ! compute the Lame parameters and density do j = -4,NY+4 do i = -4,NX+4 if (HETEROGENEOUS_MODEL .and. DELTAY*dble(j-1) > INTERFACE_HEIGHT) then rho(i,j)= rho_top mu(i,j)= mu_top lambda(i,j) = lambda_top lambdaplustwomu(i,j) = lambdaplustwomu_top else rho(i,j)= rho_bottom mu(i,j)= mu_bottom lambda(i,j) = lambda_bottom lambdaplustwomu(i,j) = lambdaplustwomu_bottom endif enddo enddo ! print position of the source print * print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print * print *,'There are ',nrec,' receivers' print * ! xspacerec = (xfin-xdeb) / dble(NREC-1) ! yspacerec = (yfin-ydeb) / dble(NREC-1) ! do irec=1,nrec ! xrec(irec) = xdeb + dble(irec-1)*xspacerec ! yrec(irec) = ydeb + dble(irec-1)*yspacerec ! enddo xrec(1) = xsource yrec(1) = ysource - 393*DELTAY xrec(2) = xsource yrec(2) = ysource + 191*DELTAY xrec(3) = xsource + 101*DELTAX yrec(3) = ysource ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i) - xrec(irec))**2 + (DELTAY*dble(j) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number_bottom = cp_bottom *dsqrt(taumax)* DELTAT*sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2) Dispersion_number_bottom=cs_bottom*dsqrt(taumin)/(2.5d0*f0*max(DELTAX,DELTAY)) print *,'Courant number at the bottom is ',Courant_number_bottom print *,'Dispersion number at the bottom is ',Dispersion_number_bottom print * !if (Courant_number_bottom > 1.d0/coefficient_sum) stop 'time step is too large, simulation will be unstable' if (HETEROGENEOUS_MODEL) then Courant_number_top = cp_top *dsqrt(taumax) * DELTAT* sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2 ) Dispersion_number_top= cs_top*dsqrt(taumin) /(2.5d0*f0*max(DELTAX,DELTAY)) print *,'Courant number at the top is ',Courant_number_top print * print *,'Dispersion number at the top is ',Dispersion_number_top !if (Courant_number_top > 1.d0/coefficient_sum) stop 'time step is too large, simulation will be unstable' endif ! erase main arrays vx(:,:) = ZERO vy(:,:) = ZERO sigmaxy(:,:) = ZERO sigmayy(:,:) = ZERO sigmaxx(:,:) = ZERO sigmaxy_R(:,:) = ZERO sigmayy_R(:,:) = ZERO sigmaxx_R(:,:) = ZERO dvx(:,:,:) = ZERO dvy(:,:,:) = ZERO dsigmaxy(:,:,:) = ZERO dsigmayy(:,:,:) = ZERO dsigmaxx(:,:,:) = ZERO dsigmaxy_R(:,:,:) = ZERO dsigmayy_R(:,:,:) = ZERO dsigmaxx_R(:,:,:) = ZERO e1(1,:,:)=ZERO e1(2,:,:)=ZERO e11(1,:,:)=ZERO e11(2,:,:)=ZERO e12(1,:,:)=ZERO e12(2,:,:)=ZERO e22(1,:,:)=ZERO e22(2,:,:)=ZERO de1(1,:,:,:)=ZERO de1(2,:,:,:)=ZERO de11(1,:,:,:)=ZERO de11(2,:,:,:)=ZERO de12(1,:,:,:)=ZERO de12(2,:,:,:)=ZERO ! PML memory_vx_dx_1(:,:) = ZERO memory_vx_dy_1(:,:) = ZERO memory_vy_dx_1(:,:) = ZERO memory_vy_dy_1(:,:) = ZERO memory_sigmaxx_dx_1(:,:) = ZERO memory_sigmayy_dy_1(:,:) = ZERO memory_sigmaxy_dx_1(:,:) = ZERO memory_sigmaxy_dy_1(:,:) = ZERO memory_dvx_dx_1(:,:,:) = ZERO memory_dvx_dy_1(:,:,:) = ZERO memory_dvy_dx_1(:,:,:) = ZERO memory_dvy_dy_1(:,:,:) = ZERO memory_dsigmaxx_dx_1(:,:,:) = ZERO memory_dsigmayy_dy_1(:,:,:) = ZERO memory_dsigmaxy_dx_1(:,:,:) = ZERO memory_dsigmaxy_dy_1(:,:,:) = ZERO ! erase seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO ! initialize total energy total_energy(:) = ZERO total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO call date_and_time(datein,timein,zone,time_values) ! time_values(3): day of the month ! time_values(5): hour of the day ! time_values(6): minutes of the hour ! time_values(7): seconds of the minute ! time_values(8): milliseconds of the second ! this fails if we cross the end of the month time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + & 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0 !--- !--- beginning of time loop !--- do it = 1,NSTEP ! v and sigma temporary variables of RK4 ! Save initial value for each field !dvx(1,:,:) = vx(:,:) !dvy(1,:,:) = vy(:,:) !dsigmaxx(1,:,:) = sigmaxx(:,:) !dsigmayy(1,:,:) = sigmayy(:,:) !dsigmaxy(1,:,:) = sigmaxy(:,:) !dsigmaxx_R(1,:,:) = sigmaxx_R(:,:) !dsigmayy_R(1,:,:) = sigmayy_R(:,:) !dsigmaxy_R(1,:,:) = sigmaxy_R(:,:) dvx(4,:,:) = vx(:,:) dvy(4,:,:) = vy(:,:) dsigmaxx(4,:,:) = sigmaxx(:,:) dsigmayy(4,:,:) = sigmayy(:,:) dsigmaxy(4,:,:) = sigmaxy(:,:) dsigmaxx_R(4,:,:) = sigmaxx_R(:,:) dsigmayy_R(4,:,:) = sigmayy_R(:,:) dsigmaxy_R(4,:,:) = sigmaxy_R(:,:) de1(1,4,:,:) = e1(1,:,:) de1(2,4,:,:) = e1(2,:,:) de11(1,4,:,:) = e11(1,:,:) de11(2,4,:,:) = e11(2,:,:) ! de22(1,4,:,:) = de22(1,1,:,:) ! de22(2,4,:,:) = de22(2,1,:,:) de12(1,4,:,:) = e12(1,:,:) de12(2,4,:,:) = e12(2,:,:) ! same thing for memory variables memory_dsigmaxx_dx_1(4,:,:) = memory_sigmaxx_dx_1(:,:) memory_dsigmaxy_dy_1(4,:,:) = memory_sigmaxy_dy_1(:,:) memory_dsigmaxy_dx_1(4,:,:) = memory_sigmaxy_dx_1(:,:) memory_dsigmayy_dy_1(4,:,:) = memory_sigmayy_dy_1(:,:) memory_dvx_dx_1(4,:,:) = memory_vx_dx_1(:,:) memory_dvy_dy_1(4,:,:) = memory_vy_dy_1(:,:) memory_dvy_dx_1(4,:,:) = memory_vy_dx_1(:,:) memory_dvx_dy_1(4,:,:) = memory_vx_dy_1(:,:) ! Initialization of time derivatives dvx(2,:,:) = ZERO dvy(2,:,:) = ZERO dsigmaxx(2,:,:) = ZERO dsigmayy(2,:,:) = ZERO dsigmaxy(2,:,:) = ZERO dsigmaxx_R(2,:,:) = ZERO dsigmayy_R(2,:,:) = ZERO dsigmaxy_R(2,:,:) = ZERO de1(1,2,:,:) = ZERO de1(2,2,:,:) = ZERO de11(1,2,:,:) = ZERO de11(2,2,:,:) = ZERO de12(1,2,:,:) = ZERO de12(2,2,:,:) = ZERO ! same thing for memory variables memory_dsigmaxx_dx_1(2,:,:) = ZERO memory_dsigmaxy_dy_1(2,:,:) = ZERO memory_dsigmaxy_dx_1(2,:,:) = ZERO memory_dsigmayy_dy_1(2,:,:) = ZERO memory_dvx_dx_1(2,:,:) = ZERO memory_dvy_dy_1(2,:,:) = ZERO memory_dvy_dx_1(2,:,:) = ZERO memory_dvx_dy_1(2,:,:) = ZERO ! RK4 loop (loop on the four RK4 substeps) do inc= 1,4 ! The new values of the different variables v and sigma are computed dvx(1,:,:) = dvx(4,:,:) + rk41(inc) * dvx(2,:,:) * DELTAT dvy(1,:,:) = dvy(4,:,:) + rk41(inc) * dvy(2,:,:) * DELTAT dsigmaxx(1,:,:) = dsigmaxx(4,:,:) + rk41(inc) * dsigmaxx(2,:,:) * DELTAT dsigmayy(1,:,:) = dsigmayy(4,:,:) + rk41(inc) * dsigmayy(2,:,:) * DELTAT dsigmaxy(1,:,:) = dsigmaxy(4,:,:) + rk41(inc) * dsigmaxy(2,:,:) * DELTAT dsigmaxx_R(1,:,:) = dsigmaxx_R(4,:,:) + rk41(inc) * dsigmaxx_R(2,:,:) * DELTAT dsigmayy_R(1,:,:) = dsigmayy_R(4,:,:) + rk41(inc) * dsigmayy_R(2,:,:) * DELTAT dsigmaxy_R(1,:,:) = dsigmaxy_R(4,:,:) + rk41(inc) * dsigmaxy_R(2,:,:) * DELTAT de1(1,1,:,:) = de1(1,4,:,:) + rk41(inc) * de1(1,2,:,:) * DELTAT de1(2,1,:,:) = de1(2,4,:,:) + rk41(inc) * de1(2,2,:,:) * DELTAT de11(1,1,:,:) = de11(1,4,:,:) + rk41(inc) * de11(1,2,:,:) * DELTAT de11(2,1,:,:) = de11(2,4,:,:) + rk41(inc) * de11(2,2,:,:) * DELTAT de12(1,1,:,:) = de12(1,4,:,:) + rk41(inc) * de12(1,2,:,:) * DELTAT de12(2,1,:,:) = de12(2,4,:,:) + rk41(inc) * de12(2,2,:,:) * DELTAT memory_dsigmaxx_dx_1(1,:,:) = memory_dsigmaxx_dx_1(4,:,:) + rk41(inc)*DELTAT*memory_dsigmaxx_dx_1(2,:,:) memory_dsigmaxy_dy_1(1,:,:) = memory_dsigmaxy_dy_1(4,:,:) + rk41(inc)*DELTAT*memory_dsigmaxy_dy_1(2,:,:) memory_dsigmaxy_dx_1(1,:,:) = memory_dsigmaxy_dx_1(4,:,:) + rk41(inc)*DELTAT*memory_dsigmaxy_dx_1(2,:,:) memory_dsigmayy_dy_1(1,:,:) = memory_dsigmayy_dy_1(4,:,:) + rk41(inc)*DELTAT*memory_dsigmayy_dy_1(2,:,:) memory_dvx_dx_1(1,:,:) = memory_dvx_dx_1(4,:,:) + rk41(inc)*DELTAT*memory_dvx_dx_1(2,:,:) memory_dvy_dy_1(1,:,:) = memory_dvy_dy_1(4,:,:) + rk41(inc)*DELTAT*memory_dvy_dy_1(2,:,:) memory_dvx_dy_1(1,:,:) = memory_dvx_dy_1(4,:,:) + rk41(inc)*DELTAT*memory_dvx_dy_1(2,:,:) memory_dvy_dx_1(1,:,:) = memory_dvy_dx_1(4,:,:) + rk41(inc)*DELTAT*memory_dvy_dx_1(2,:,:) !------------------ ! compute velocity !------------------ do j = 2,NY do i = 2,NX value_dsigmaxx_dx = ( c1 * (dsigmaxx(1,i,j) - dsigmaxx(1,i-1,j)) + c2 * (dsigmaxx(1,i+1,j) - dsigmaxx(1,i-2,j)) + & c3 * (dsigmaxx(1,i+2,j) - dsigmaxx(1,i-3,j)) + c4 * (dsigmaxx(1,i+3,j) - dsigmaxx(1,i-4,j)) ) * ONE_OVER_DELTAX value_dsigmaxy_dy = ( c1 * (dsigmaxy(1,i,j) - dsigmaxy(1,i,j-1)) + c2* (dsigmaxy(1,i,j+1) - dsigmaxy(1,i,j-2)) + & c3 * (dsigmaxy(1,i,j+2) - dsigmaxy(1,i,j-3)) + c4 * (dsigmaxy(1,i,j+3) - dsigmaxy(1,i,j-4)) ) * ONE_OVER_DELTAY if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then memory_dsigmaxx_dx_1(2,i,j) = r_x_1(i) * memory_dsigmaxx_dx_1(1,i,j) + s_x_1(i) * value_dsigmaxx_dx memory_dsigmaxy_dy_1(2,i,j) = r_y_1(j) * memory_dsigmaxy_dy_1(1,i,j) + s_y_1(j) * value_dsigmaxy_dy value_dsigmaxx_dx = value_dsigmaxx_dx / K_x_1(i) + memory_dsigmaxx_dx_1(1,i,j) value_dsigmaxy_dy = value_dsigmaxy_dy / K_y_1(j) + memory_dsigmaxy_dy_1(1,i,j) endif dvx(2,i,j) = (value_dsigmaxx_dx + value_dsigmaxy_dy)/rho(i,j) enddo enddo do j = 1,NY-1 do i = 1,NX-1 rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) value_dsigmaxy_dx = ( c1 * (dsigmaxy(1,i+1,j) - dsigmaxy(1,i,j)) + c2 * (dsigmaxy(1,i+2,j) - dsigmaxy(1,i-1,j)) + & c3 * (dsigmaxy(1,i+3,j) - dsigmaxy(1,i-2,j)) + c4 * (dsigmaxy(1,i+4,j) - dsigmaxy(1,i-3,j)) )* ONE_OVER_DELTAX value_dsigmayy_dy = ( c1 * (dsigmayy(1,i,j+1) - dsigmayy(1,i,j)) + c2 * (dsigmayy(1,i,j+2) - dsigmayy(1,i,j-1)) + & c3 * (dsigmayy(1,i,j+3) - dsigmayy(1,i,j-2)) + c4 * (dsigmayy(1,i,j+4) - dsigmayy(1,i,j-3)) )* ONE_OVER_DELTAY if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then memory_dsigmaxy_dx_1(2,i,j) = r_x_half_1(i) * memory_dsigmaxy_dx_1(1,i,j) + s_x_half_1(i) * value_dsigmaxy_dx memory_dsigmayy_dy_1(2,i,j) = r_y_half_1(j) * memory_dsigmayy_dy_1(1,i,j) + s_y_half_1(j) * value_dsigmayy_dy value_dsigmaxy_dx = value_dsigmaxy_dx/K_x_half_1(i)+memory_dsigmaxy_dx_1(1,i,j) value_dsigmayy_dy = value_dsigmayy_dy/K_y_half_1(j)+memory_dsigmayy_dy_1(1,i,j) endif dvy(2,i,j) = (value_dsigmaxy_dx + value_dsigmayy_dy) /rho_half_x_half_y enddo enddo ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0; t = (dble(it-1)+ rk41(inc)) * DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! first derivative of a Gaussian source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term ! define location of the source i = ISOURCE j = JSOURCE ! interpolate density at the right location in the staggered grid cell dvx(2,i,j) = dvx(2,i,j) + force_x/ rho(i,j) rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) dvy(2,i,j) = dvy(2,i,j) + force_y/ rho_half_x_half_y ! Dirichlet conditions (rigid boundaries) on all the edges of the grid dvx(:,-4:1,:) = ZERO dvx(:,NX:NX+4,:) = ZERO dvx(:,:,-4:1) = ZERO dvx(:,:,NY:NY+4) = ZERO dvy(:,-4:1,:) = ZERO dvy(:,NX:NX+4,:) = ZERO dvy(:,:,-4:1) = ZERO dvy(:,:,NY:NY+4) = ZERO !---------------------- ! compute stress sigma !---------------------- do j=2,NY do i=1,NX-1 mul_relaxed = 0.5d0 * (mu(i+1,j) + mu(i,j)) lambdal_relaxed = 0.5d0 * (lambda(i+1,j) + lambda(i,j)) lambdalplus2mul_relaxed = 0.5d0 * (lambdaplustwomu(i+1,j) + lambdaplustwomu(i,j)) lambdal_unrelaxed = (lambdal_relaxed + 2.d0/DIM*mul_relaxed) * Mu_nu1 - 2.d0/DIM*mul_relaxed * Mu_nu2 mul_unrelaxed = mul_relaxed * Mu_nu2 lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed value_dvx_dx = ( c1 * (dvx(1,i+1,j) - dvx(1,i,j)) + c2 * (dvx(1,i+2,j) - dvx(1,i-1,j)) + & c3 * (dvx(1,i+3,j) - dvx(1,i-2,j)) + c4 * (dvx(1,i+4,j) - dvx(1,i-3,j)) )* ONE_OVER_DELTAX value_dvy_dy = ( c1 * (dvy(1,i,j) - dvy(1,i,j-1)) + c2 * (dvy(1,i,j+1) - dvy(1,i,j-2)) + & c3 * (dvy(1,i,j+2) - dvy(1,i,j-3)) + c4 * (dvy(1,i,j+3) - dvy(1,i,j-4)) )* ONE_OVER_DELTAY duxdx = value_dvx_dx duydy = value_dvy_dy if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then memory_dvx_dx_1(2,i,j) = r_x_half_1(i) * memory_dvx_dx_1(1,i,j) + s_x_half_1(i) * value_dvx_dx memory_dvy_dy_1(2,i,j) = r_y_1(j) * memory_dvy_dy_1(1,i,j) + s_y_1(j) * value_dvy_dy duxdx = value_dvx_dx / K_x_half_1(i) + memory_dvx_dx_1(1,i,j) duydy = value_dvy_dy / K_y_1(j) + memory_dvy_dy_1(1,i,j) endif div=duxdx+duydy !evolution e1(1) tauinv = - inv_tau_sigma_nu1(1) Sn = div * phi_nu1(1) de1(1,2,i,j) = tauinv * de1(1,1,i,j) + Sn !evolution e1(2) tauinv = - inv_tau_sigma_nu1(2) Sn = div * phi_nu1(2) de1(2,2,i,j) = tauinv * de1(2,1,i,j) + Sn ! evolution e11(1) tauinv = - inv_tau_sigma_nu2(1) Sn = (duxdx - div/DIM) * phi_nu2(1) de11(1,2,i,j) = tauinv * de11(1,1,i,j) + Sn ! evolution e11(2) tauinv = - inv_tau_sigma_nu2(2) Sn = (duxdx - div/DIM) * phi_nu2(2) de11(2,2,i,j) = tauinv * de11(2,1,i,j) + Sn !add the memory variables using the relaxed parameters (Carcione page 111) ! there is a bug in Carcione's equation for sigma_zz dsigmaxx(2,i,j) = ((lambdal_relaxed + 2.d0/DIM*mul_relaxed)* & (de1(1,1,i,j) + de1(2,1,i,j)) + TWO * mul_relaxed * (de11(1,1,i,j) + de11(2,1,i,j))+ & (lambdalplus2mul_unrelaxed * (duxdx) + lambdal_unrelaxed* (duydy) )) dsigmayy(2,i,j) = ((lambdal_relaxed + 2.d0*mul_relaxed)* & (de1(1,1,i,j) + de1(2,1,i,j)) - TWO/DIM * mul_relaxed * (de11(1,1,i,j) + de11(2,1,i,j)) + & (lambdal_unrelaxed * (duxdx) + lambdalplus2mul_unrelaxed* (duydy) )) ! compute the stress using the unrelaxed Lame parameters (Carcione page 111) dsigmaxx_R(2,i,j) = lambdalplus2mul_relaxed * (duxdx) + lambdal_relaxed* (duydy) dsigmayy_R(2,i,j) = lambdal_relaxed * (duxdx) + lambdalplus2mul_relaxed* (duydy) enddo enddo do j=1,NY-1 do i=2,NX mul_relaxed = 0.5d0 * (mu(i,j+1) + mu(i,j)) mul_unrelaxed = mul_relaxed * Mu_nu2 value_dvy_dx = ( c1 * (dvy(1,i,j) - dvy(1,i-1,j)) + c2 * (dvy(1,i+1,j) - dvy(1,i-2,j)) + & c3 * (dvy(1,i+2,j) - dvy(1,i-3,j)) + c4 * (dvy(1,i+3,j) - dvy(1,i-4,j)) )* ONE_OVER_DELTAX value_dvx_dy = ( c1 * (dvx(1,i,j+1) - dvx(1,i,j)) + c2 * (dvx(1,i,j+2) - dvx(1,i,j-1)) + & c3 * (dvx(1,i,j+3) - dvx(1,i,j-2)) + c4 * (dvx(1,i,j+4) - dvx(1,i,j-3)) )* ONE_OVER_DELTAY duydx = value_dvy_dx duxdy = value_dvx_dy if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then memory_dvy_dx_1(2,i,j) = r_x_1(i) * memory_dvy_dx_1(1,i,j) + s_x_1(i) * value_dvy_dx memory_dvx_dy_1(2,i,j) = r_y_half_1(j) * memory_dvx_dy_1(1,i,j) + s_y_half_1(j) * value_dvx_dy duydx = value_dvy_dx / K_x_1(i) + memory_dvy_dx_1(1,i,j) duxdy = value_dvx_dy / K_y_half_1(j) + memory_dvx_dy_1(1,i,j) endif ! evolution e12(1) tauinv = - inv_tau_sigma_nu2(1) Sn = (duxdy+duydx) * phi_nu2(1) de12(1,2,i,j) = tauinv * de12(1,1,i,j) + Sn ! evolution e12(2) tauinv = - inv_tau_sigma_nu2(2) Sn = (duxdy+duydx) * phi_nu2(2) de12(2,2,i,j) = tauinv * de12(2,1,i,j) + Sn dsigmaxy(2,i,j) = mul_relaxed * (de12(1,1,i,j) + de12(2,1,i,j))+mul_unrelaxed * (duxdy+duydx) dsigmaxy_R(2,i,j) = mul_relaxed * (duxdy+duydx) enddo enddo ! Update solution for next time step Delta_t vx(:,:) = vx(:,:) + rk42(inc) * dvx(2,:,:) * DELTAT vy(:,:) = vy(:,:) + rk42(inc) * dvy(2,:,:) * DELTAT sigmaxx(:,:) = sigmaxx(:,:) + rk42(inc) * dsigmaxx(2,:,:) * DELTAT sigmayy(:,:) = sigmayy(:,:) + rk42(inc) * dsigmayy(2,:,:) * DELTAT sigmaxy(:,:) = sigmaxy(:,:) + rk42(inc) * dsigmaxy(2,:,:) * DELTAT sigmaxx_R(:,:) = sigmaxx_R(:,:) + rk42(inc) * dsigmaxx_R(2,:,:) * DELTAT sigmayy_R(:,:) = sigmayy_R(:,:) + rk42(inc) * dsigmayy_R(2,:,:) * DELTAT sigmaxy_R(:,:) = sigmaxy_R(:,:) + rk42(inc) * dsigmaxy_R(2,:,:) * DELTAT e1(1,:,:) = e1(1,:,:) + rk42(inc) * de1(1,2,:,:) * DELTAT e1(2,:,:) = e1(2,:,:) + rk42(inc) * de1(2,2,:,:) * DELTAT e11(1,:,:) = e11(1,:,:) + rk42(inc) * de11(1,2,:,:) * DELTAT e11(2,:,:) = e11(2,:,:) + rk42(inc) * de11(2,2,:,:) * DELTAT e12(1,:,:) = e12(1,:,:) + rk42(inc) * de12(1,2,:,:) * DELTAT e12(2,:,:) = e12(2,:,:) + rk42(inc) * de12(2,2,:,:) * DELTAT memory_vx_dx_1(:,:) = memory_vx_dx_1(:,:) + rk42(inc) * memory_dvx_dx_1(2,:,:) * DELTAT memory_vx_dy_1(:,:) = memory_vx_dy_1(:,:) + rk42(inc) * memory_dvx_dy_1(2,:,:) * DELTAT memory_vy_dx_1(:,:) = memory_vy_dx_1(:,:) + rk42(inc) * memory_dvy_dx_1(2,:,:) * DELTAT memory_vy_dy_1(:,:) = memory_vy_dy_1(:,:) + rk42(inc) * memory_dvy_dy_1(2,:,:) * DELTAT memory_sigmaxx_dx_1(:,:) = memory_sigmaxx_dx_1(:,:) + rk42(inc) * memory_dsigmaxx_dx_1(2,:,:) * DELTAT memory_sigmayy_dy_1(:,:) = memory_sigmayy_dy_1(:,:) + rk42(inc) * memory_dsigmayy_dy_1(2,:,:) * DELTAT memory_sigmaxy_dx_1(:,:) = memory_sigmaxy_dx_1(:,:) + rk42(inc) * memory_dsigmaxy_dx_1(2,:,:) * DELTAT memory_sigmaxy_dy_1(:,:) = memory_sigmaxy_dy_1(:,:) + rk42(inc) * memory_dsigmaxy_dy_1(2,:,:) * DELTAT ! Dirichlet conditions (rigid boundaries) on all the edges of the grid dvx(:,-4:1,:) = ZERO dvx(:,NX:NX+4,:) = ZERO dvx(:,:,-4:1) = ZERO dvx(:,:,NY:NY+4) = ZERO dvy(:,-4:1,:) = ZERO dvy(:,NX:NX+4,:) = ZERO dvy(:,:,-4:1) = ZERO dvy(:,:,NY:NY+4) = ZERO vx(-4:1,:) = ZERO vx(:,-4:1) = ZERO vy(-4:1,:) = ZERO vy(:,-4:1) = ZERO vx(NX:NX+4,:) = ZERO vx(:,NY:NY+4) = ZERO vy(NX:NX+4,:) = ZERO vy(:,NY:NY+4) = ZERO enddo !vx(:,:) = dvx(1,:,:) !vy(:,:) = dvy(1,:,:) !sigmaxx(:,:) = dsigmaxx(1,:,:) !sigmayy(:,:) = dsigmayy(1,:,:) !sigmaxy(:,:) = dsigmaxy(1,:,:) !sigmaxx_R(:,:) = dsigmaxx_R(1,:,:) !sigmayy_R(:,:) = dsigmayy_R(1,:,:) !sigmaxy_R(:,:) = dsigmaxy_R(1,:,:) !e1(1,:,:) = de1(1,1,:,:) !e1(2,:,:) = de1(2,1,:,:) !e11(1,:,:) = de11(1,1,:,:) !e11(2,:,:) = de11(2,1,:,:) !e12(1,:,:) = de12(1,1,:,:) !e12(2,:,:) = de12(2,1,:,:) ! end of RK4 loop ! store seismograms do irec = 1,NREC sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec)) sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec)) enddo ! compute total energy in the medium (without the PML layers) local_energy_kinetic = ZERO local_energy_potential = ZERO do j = NPOINTS_PML, NY-NPOINTS_PML+1 do i = NPOINTS_PML, NX-NPOINTS_PML+1 ! compute kinetic energy first, defined as 1/2 rho ||v||^2 ! in principle we should use rho_half_x_half_y instead of rho for vy ! in order to interpolate density at the right location in the staggered grid cell ! but in a homogeneous medium we can safely ignore it local_energy_kinetic = local_energy_kinetic + 0.5d0 * rho(i,j)*( & vx(i,j)**2 + vy(i,j)**2) total_energy_kinetic(it) = local_energy_kinetic ! add potential energy, defined as 1/2 epsilon_ij sigma_ij ! in principle we should interpolate the medium parameters at the right location ! in the staggered grid cell but in a homogeneous medium we can safely ignore it ! compute total field from split components epsilon_xx = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmaxx_R(i,j) - lambda(i,j) * sigmayy_R(i,j)) / & (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j))) epsilon_yy = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmayy_R(i,j) - lambda(i,j) * sigmaxx_R(i,j)) / & (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j))) epsilon_xy = sigmaxy_R(i,j) / (2.d0 * mu(i,j)) local_energy_potential = local_energy_potential + & 0.5d0 * (epsilon_xx * sigmaxx_R(i,j) + epsilon_yy * sigmayy_R(i,j) + & epsilon_yy * sigmayy_R(i,j)+ 2.d0 * epsilon_xy * sigmaxy_R(i,j)) total_energy_potential(it) = local_energy_potential enddo enddo total_energy(it) = total_energy_kinetic(it) + total_energy_potential(it) ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then Vsolidnorm = maxval(sqrt(vx**2 + vy**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',Vsolidnorm print *,'Total energy = ',total_energy(it) ! check stability of the code, exit if unstable if (Vsolidnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up in solid' ! save energy open(unit=21,file='energy.dat',status='unknown') do it2=1,NSTEP write(21,*) sngl(dble(it2-1)*DELTAT),total_energy_kinetic(it2), & total_energy_potential(it2),total_energy(it2) enddo close(21) ! save seismograms print *,'saving seismograms' print * call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT,t0) call create_color_image(vx(1:NX,1:NY),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1,max_amplitudeVx,JINTERFACE) call create_color_image(vy(1:NX,1:NY),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2,max_amplitudeVy,JINTERFACE) endif ! --- end of time loop enddo ! save seismograms call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT,t0) ! save total energy open(unit=20,file='RK4_energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & sngl(total_energy_potential(it)),sngl(total_energy(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='RK4_plot_energy',status='unknown') write(20,*) 'set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "ADEPML2D_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "RK4_energy.dat" t ''Total energy'' w l 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "RK4_Vx_file_001.dat" t ''Vx ADE-PML RK4'' w l 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "RK4_Vy_file_001.dat" t ''Vy ADE-PML RK4'' w l 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "RK4_Vx_file_002.dat" t ''Vx ADE-PML RK4'' w l 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "RK4_Vy_file_002.dat" t ''Vy ADE-PML RK4'' w l 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_003.eps"' write(20,*) 'plot "RK4_Vx_file_003.dat" t ''Vx ADE-PML RK4'' w l 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_003.eps"' write(20,*) 'plot "RK4_Vy_file_003.dat" t ''Vy ADE-PML RK4'' w l 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) ! time_values(3): day of the month ! time_values(5): hour of the day ! time_values(6): minutes of the hour ! time_values(7): seconds of the minute ! time_values(8): milliseconds of the second ! this fails if we cross the end of the month time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + & 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0 ! elapsed time since beginning of the simulation tCPU = time_end - time_start int_tCPU = int(tCPU) ihours = int_tCPU / 3600 iminutes = (int_tCPU - 3600*ihours) / 60 iseconds = int_tCPU - 3600*ihours - 60*iminutes write(*,*) 'Elapsed time in seconds = ',tCPU write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it) write(*,*) ! write time stamp file to give information about progression of simulation write(outputname,"('timestamp',i6.6)") it open(unit=IOUT,file=outputname,status='unknown') write(IOUT,*) 'Time step # ',it write(IOUT,*) 'Time: ',sngl((it-1)*DELTAT),' seconds' write(IOUT,*) 'Max norm velocity vector V (m/s) = ',Vsolidnorm write(IOUT,*) 'Total energy = ',total_energy(it) write(IOUT,*) 'Elapsed time in seconds = ',tCPU write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it) close(IOUT) print * print *,'End of the simulation' print * end program seismic_ADEPML_2D_viscoelastic_RK4_eighth_order ! include the SolvOpt routines include "attenuation_model_with_SolvOpt.f90" !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT,t0) implicit none integer nt,nrec double precision DELTAT,t0 double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('RK4_Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT-t0),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component do irec=1,nrec write(file_name,"('RK4_Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT-t0),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM,USE_PML_TOP,field_number,max_amplitude,JINTERFACE) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM,USE_PML_TOP double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer ix,iy,irec,JINTERFACE double precision max_amplitude character(len=100) file_name,system_command double precision normalized_value integer :: R, G, B ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it endif if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif if (field_number == 3) then write(file_name,"('image',i6.6,'_Vnorm.pnm')") it write(system_command,"('convert image',i6.6,'_Vnorm.pnm image',i6.6,'_Vnorm.gif ; rm image',i6.6,'_Vnorm.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_LEFT .and. ix == NPOINTS_PML) .or. & (USE_PML_RIGHT .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_BOTTOM .and. iy == NPOINTS_PML) .or. & (USE_PML_TOP .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 else if (iy == JINTERFACE) then R = 0 G = 0 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to JPEG ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_CPML_2D_anisotropic.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.1, November 2009. ! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributors: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! and Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr ! ! This software is a computer program whose purpose is to solve ! the two-dimensional anisotropic elastic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_2D_aniso ! 2D elastic finite-difference code in velocity and stress formulation ! with Convolutional-PML (C-PML) absorbing conditions for an anisotropic medium ! Dimitri Komatitsch, University of Pau, France, April 2007. ! Anisotropic implementation by Roland Martin and Dimitri Komatitsch, University of Pau, France, April 2007. ! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these ! articles: ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! If you use the anisotropic implementation, please cite this article, ! in which the anisotropic parameters are described, as well: ! ! @ARTICLE{KoBaTr00, ! author = {D. Komatitsch and C. Barnes and J. Tromp}, ! title = {Simulation of anisotropic wave propagation based upon a spectral element method}, ! journal = {Geophysics}, ! year = {2000}, ! volume = {65}, ! number = {4}, ! pages = {1251-1260}, ! doi = {10.1190/1.1444816}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! total number of grid points in each direction of the grid integer, parameter :: NX = 401 integer, parameter :: NY = 401 ! size of a grid cell double precision, parameter :: DELTAX = 0.0625d-2 double precision, parameter :: DELTAY = DELTAX ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! Velocity of qP along horizontal axis = sqrt(c11/rho) ! Velocity of qP along vertical axis = sqrt(c22/rho) ! Velocity of qSV along horizontal axis = sqrt(c33/rho) ! Velocity of qSV along vertical axis = sqrt(c33/rho), same as along horizontal axis ! zinc, from Komatitsch et al. (2000) ! double precision, parameter :: c11 = 16.5d10 ! double precision, parameter :: c12 = 5.d10 ! double precision, parameter :: c22 = 6.2d10 ! double precision, parameter :: c33 = 3.96d10 ! double precision, parameter :: rho = 7100.d0 ! double precision, parameter :: f0 = 170.d3 ! apatite, from Komatitsch et al. (2000) ! double precision, parameter :: c11 = 16.7d10 ! double precision, parameter :: c12 = 6.6d10 ! double precision, parameter :: c22 = 14.d10 ! double precision, parameter :: c33 = 6.63d10 ! double precision, parameter :: rho = 3200.d0 ! double precision, parameter :: f0 = 300.d3 ! isotropic material a bit similar to apatite ! double precision, parameter :: c11 = 16.7d10 ! double precision, parameter :: c12 = c11/3.d0 ! double precision, parameter :: c22 = c11 ! double precision, parameter :: c33 = (c11-c12)/2.d0 ! = c11/3.d0 ! double precision, parameter :: rho = 3200.d0 ! double precision, parameter :: f0 = 300.d3 ! model I from Becache, Fauqueux and Joly, which is stable double precision, parameter :: scale_aniso = 1.d10 double precision, parameter :: c11 = 4.d0 * scale_aniso double precision, parameter :: c12 = 3.8d0 * scale_aniso double precision, parameter :: c22 = 20.d0 * scale_aniso double precision, parameter :: c33 = 2.d0 * scale_aniso double precision, parameter :: rho = 4000.d0 ! used to be 1. double precision, parameter :: f0 = 200.d3 ! model II from Becache, Fauqueux and Joly, which is stable ! double precision, parameter :: scale_aniso = 1.d10 ! double precision, parameter :: c11 = 20.d0 * scale_aniso ! double precision, parameter :: c12 = 3.8d0 * scale_aniso ! double precision, parameter :: c22 = c11 ! double precision, parameter :: c33 = 2.d0 * scale_aniso ! double precision, parameter :: rho = 4000.d0 ! used to be 1. ! double precision, parameter :: f0 = 200.d3 ! model III from Becache, Fauqueux and Joly, which is unstable ! double precision, parameter :: scale_aniso = 1.d10 ! double precision, parameter :: c11 = 4.d0 * scale_aniso ! double precision, parameter :: c12 = 4.9d0 * scale_aniso ! double precision, parameter :: c22 = 20.d0 * scale_aniso ! double precision, parameter :: c33 = 2.d0 * scale_aniso ! double precision, parameter :: rho = 4000.d0 ! used to be 1. ! double precision, parameter :: f0 = 250.d3 ! model IV from Becache, Fauqueux and Joly, which is unstable ! double precision, parameter :: scale_aniso = 1.d10 ! double precision, parameter :: c11 = 4.d0 * scale_aniso ! double precision, parameter :: c12 = 7.5d0 * scale_aniso ! double precision, parameter :: c22 = 20.d0 * scale_aniso ! double precision, parameter :: c33 = 2.d0 * scale_aniso ! double precision, parameter :: rho = 4000.d0 ! used to be 1. ! double precision, parameter :: f0 = 170.d3 ! total number of time steps integer, parameter :: NSTEP = 3000 ! time step in seconds double precision, parameter :: DELTAT = 50.d-9 ! parameters for the source double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d7 ! source integer, parameter :: ISOURCE = NX / 2 integer, parameter :: JSOURCE = NY / 2 double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY ! angle of source force clockwise with respect to vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 0.d0 ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 100 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays double precision, dimension(NX,NY) :: vx,vy,sigmaxx,sigmayy,sigmaxy ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(NX,NY) :: & memory_dvx_dx, & memory_dvx_dy, & memory_dvy_dx, & memory_dvy_dy, & memory_dsigmaxx_dx, & memory_dsigmayy_dy, & memory_dsigmaxy_dx, & memory_dsigmaxy_dy double precision :: & value_dvx_dx, & value_dvx_dy, & value_dvy_dx, & value_dvy_dy, & value_dsigmaxx_dx, & value_dsigmayy_dy, & value_dsigmaxy_dx, & value_dsigmaxy_dy ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized ! for the source double precision :: a,t,force_x,force_y,source_term integer :: i,j,it double precision :: Courant_number,velocnorm ! for stability estimate double precision :: quasi_cp_max,aniso_stability_criterion,aniso2,aniso3 !--- !--- program starts here !--- print * print *,'2D elastic finite-difference code in velocity and stress formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * print *,'Velocity of qP along vertical axis. . . . =',sqrt(c22/rho) print *,'Velocity of qP along horizontal axis. . . =',sqrt(c11/rho) print * print *,'Velocity of qSV along vertical axis . . . =',sqrt(c33/rho) print *,'Velocity of qSV along horizontal axis . . =',sqrt(c33/rho) print * ! from Becache et al., INRIA report, equation 7 page 5 http://hal.inria.fr/docs/00/07/22/83/PDF/RR-4304.pdf if (c11*c22 - c12*c12 <= 0.d0) stop 'problem in definition of orthotropic material' ! check intrinsic mathematical stability of PML model for an anisotropic material ! from E. B\'ecache, S. Fauqueux and P. Joly, Stability of Perfectly Matched Layers, group ! velocities and anisotropic waves, Journal of Computational Physics, 188(2), p. 399-433 (2003) aniso_stability_criterion = ((c12+c33)**2 - c11*(c22-c33)) * ((c12+c33)**2 + c33*(c22-c33)) print *,'PML anisotropy stability criterion from Becache et al. 2003 = ',aniso_stability_criterion if (aniso_stability_criterion > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) & print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 1' print * aniso2 = (c12 + 2*c33)**2 - c11*c22 print *,'PML aniso2 stability criterion from Becache et al. 2003 = ',aniso2 if (aniso2 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) & print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 2' print * aniso3 = (c12 + c33)**2 - c11*c22 - c33**2 print *,'PML aniso3 stability criterion from Becache et al. 2003 = ',aniso3 if (aniso3 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) & print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 3' print * ! to compute d0 below, and for stability estimate quasi_cp_max = max(sqrt(c22/rho),sqrt(c11/rho)) !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * quasi_cp_max * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * quasi_cp_max * log(Rcoef) / (2.d0 * thickness_PML_y) print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print * d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! print position of the source print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number = quasi_cp_max * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2) print *,'Courant number is ',Courant_number print * if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable' ! suppress old files (can be commented out if "call system" is missing in your compiler) ! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif') ! initialize arrays vx(:,:) = ZERO vy(:,:) = ZERO sigmaxx(:,:) = ZERO sigmayy(:,:) = ZERO sigmaxy(:,:) = ZERO ! PML memory_dvx_dx(:,:) = ZERO memory_dvx_dy(:,:) = ZERO memory_dvy_dx(:,:) = ZERO memory_dvy_dy(:,:) = ZERO memory_dsigmaxx_dx(:,:) = ZERO memory_dsigmayy_dy(:,:) = ZERO memory_dsigmaxy_dx(:,:) = ZERO memory_dsigmaxy_dy(:,:) = ZERO !--- !--- beginning of time loop !--- do it = 1,NSTEP !------------------------------------------------------------ ! compute stress sigma and update memory variables for C-PML !------------------------------------------------------------ do j = 2,NY do i = 1,NX-1 value_dvx_dx = (vx(i+1,j) - vx(i,j)) / DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) / DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j) sigmaxx(i,j) = sigmaxx(i,j) + (c11 * value_dvx_dx + c12 * value_dvy_dy) * DELTAT sigmayy(i,j) = sigmayy(i,j) + (c12 * value_dvx_dx + c22 * value_dvy_dy) * DELTAT enddo enddo do j = 1,NY-1 do i = 2,NX value_dvy_dx = (vy(i,j) - vy(i-1,j)) / DELTAX value_dvx_dy = (vx(i,j+1) - vx(i,j)) / DELTAY memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j) value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j) sigmaxy(i,j) = sigmaxy(i,j) + c33 * (value_dvy_dx + value_dvx_dy) * DELTAT enddo enddo !-------------------------------------------------------- ! compute velocity and update memory variables for C-PML !-------------------------------------------------------- do j = 2,NY do i = 2,NX value_dsigmaxx_dx = (sigmaxx(i,j) - sigmaxx(i-1,j)) / DELTAX value_dsigmaxy_dy = (sigmaxy(i,j) - sigmaxy(i,j-1)) / DELTAY memory_dsigmaxx_dx(i,j) = b_x(i) * memory_dsigmaxx_dx(i,j) + a_x(i) * value_dsigmaxx_dx memory_dsigmaxy_dy(i,j) = b_y(j) * memory_dsigmaxy_dy(i,j) + a_y(j) * value_dsigmaxy_dy value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j) value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j) vx(i,j) = vx(i,j) + (value_dsigmaxx_dx + value_dsigmaxy_dy) * DELTAT / rho enddo enddo do j = 1,NY-1 do i = 1,NX-1 value_dsigmaxy_dx = (sigmaxy(i+1,j) - sigmaxy(i,j)) / DELTAX value_dsigmayy_dy = (sigmayy(i,j+1) - sigmayy(i,j)) / DELTAY memory_dsigmaxy_dx(i,j) = b_x_half(i) * memory_dsigmaxy_dx(i,j) + a_x_half(i) * value_dsigmaxy_dx memory_dsigmayy_dy(i,j) = b_y_half(j) * memory_dsigmayy_dy(i,j) + a_y_half(j) * value_dsigmayy_dy value_dsigmaxy_dx = value_dsigmaxy_dx / K_x_half(i) + memory_dsigmaxy_dx(i,j) value_dsigmayy_dy = value_dsigmayy_dy / K_y_half(j) + memory_dsigmayy_dy(i,j) vy(i,j) = vy(i,j) + (value_dsigmaxy_dx + value_dsigmayy_dy) * DELTAT / rho enddo enddo ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! first derivative of a Gaussian source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term ! define location of the source i = ISOURCE j = JSOURCE vx(i,j) = vx(i,j) + force_x * DELTAT / rho vy(i,j) = vy(i,j) + force_y * DELTAT / rho ! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers vx(1,:) = ZERO vx(NX,:) = ZERO vx(:,1) = ZERO vx(:,NY) = ZERO vy(1,:) = ZERO vy(NX,:) = ZERO vy(:,1) = ZERO vy(:,NY) = ZERO ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! print maximum of norm of velocity velocnorm = maxval(sqrt(vx**2 + vy**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',velocnorm print * ! check stability of the code, exit if unstable if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1) call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2) endif enddo ! end of time loop print * print *,'End of the simulation' print * end program seismic_CPML_2D_aniso !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer :: ix,iy character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_CPML_2D_isotropic_fourth_order.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.1, November 2009. ! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributors: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! and Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr ! ! This software is a computer program whose purpose is to solve ! the two-dimensional isotropic elastic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_2D_iso_fourth ! 2D elastic finite-difference code in velocity and stress formulation ! with Convolutional-PML (C-PML) absorbing conditions for an isotropic medium ! Dimitri Komatitsch, University of Pau, France, April 2007. ! Fourth-order implementation by Dimitri Komatitsch and Roland Martin, University of Pau, France, August 2007. ! The staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! ! but a fourth-order spatial operator is used instead of a second-order operator ! as in program seismic_CPML_2D_iso_second.f90 . You can type the following command ! to see the changes that have been made to switch from the second-order operator ! to the fourth-order operator: ! ! diff seismic_CPML_2D_isotropic_second_order.f90 seismic_CPML_2D_isotropic_fourth_order.f90 ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000) ! ! If you use this code for your own research, please cite some (or all) of these articles: ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdelaaziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! total number of grid points in each direction of the grid integer, parameter :: NX = 101 integer, parameter :: NY = 641 ! size of a grid cell double precision, parameter :: DELTAX = 10.d0 double precision, parameter :: DELTAY = DELTAX ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! P-velocity, S-velocity and density double precision, parameter :: cp = 3300.d0 double precision, parameter :: cs = cp / 1.732d0 double precision, parameter :: density = 2800.d0 ! total number of time steps ! the time step is twice smaller for this fourth-order simulation, ! therefore let us double the number of time steps to keep the same total duration integer, parameter :: NSTEP = 2000 * 2 ! time step in seconds ! fourth-order in space and second-order in time finite-difference schemes ! are less stable than second-order in space and second-order in time, ! therefore let us divide the time step by 2 double precision, parameter :: DELTAT = 2.d-3 / 2 ! parameters for the source double precision, parameter :: f0 = 7.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d7 ! source integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1 integer, parameter :: JSOURCE = 2 * NY / 3 + 1 double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY ! angle of source force clockwise with respect to vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 135.d0 ! receivers integer, parameter :: NREC = 2 double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters double precision, parameter :: xfin = xsource ! last receiver x in meters double precision, parameter :: yfin = 300.d0 ! last receiver y in meters ! display information on the screen from time to time ! the time step is twice smaller for this fourth-order simulation, ! therefore let us double the interval in time steps at which we display information integer, parameter :: IT_DISPLAY = 100 * 2 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays double precision, dimension(0:NX+1,0:NY+1) :: vx,vy,sigmaxx,sigmayy,sigmaxy,lambda,mu,rho ! to interpolate material parameters at the right location in the staggered grid cell double precision lambda_half_x,mu_half_x,lambda_plus_two_mu_half_x,mu_half_y,rho_half_x_half_y ! for evolution of total energy in the medium double precision epsilon_xx,epsilon_yy,epsilon_xy double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(0:NX+1,0:NY+1) :: & memory_dvx_dx, & memory_dvx_dy, & memory_dvy_dx, & memory_dvy_dy, & memory_dsigmaxx_dx, & memory_dsigmayy_dy, & memory_dsigmaxy_dx, & memory_dsigmaxy_dy double precision :: & value_dvx_dx, & value_dvx_dy, & value_dvy_dx, & value_dvy_dy, & value_dsigmaxx_dx, & value_dsigmayy_dy, & value_dsigmaxy_dx, & value_dsigmaxy_dy ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized ! for the source double precision :: a,t,force_x,force_y,source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy integer :: i,j,it,irec double precision :: Courant_number,velocnorm !--- !--- program starts here !--- print * print *,'2D elastic finite-difference code in velocity and stress formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_y) print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print * d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = NY*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! compute the Lame parameters and density do j = 1,NY do i = 1,NX rho(i,j) = density mu(i,j) = density*cs*cs lambda(i,j) = density*(cp*cp - 2.d0*cs*cs) enddo enddo ! print position of the source print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print *,'There are ',nrec,' receivers' print * xspacerec = (xfin-xdeb) / dble(NREC-1) yspacerec = (yfin-ydeb) / dble(NREC-1) do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number = cp * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2) print *,'Courant number is ',Courant_number print * if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable' ! suppress old files (can be commented out if "call system" is missing in your compiler) ! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif') ! initialize arrays vx(:,:) = ZERO vy(:,:) = ZERO sigmaxx(:,:) = ZERO sigmayy(:,:) = ZERO sigmaxy(:,:) = ZERO ! PML memory_dvx_dx(:,:) = ZERO memory_dvx_dy(:,:) = ZERO memory_dvy_dx(:,:) = ZERO memory_dvy_dy(:,:) = ZERO memory_dsigmaxx_dx(:,:) = ZERO memory_dsigmayy_dy(:,:) = ZERO memory_dsigmaxy_dx(:,:) = ZERO memory_dsigmaxy_dy(:,:) = ZERO ! initialize seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO ! initialize total energy total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO !--- !--- beginning of time loop !--- do it = 1,NSTEP !------------------------------------------------------------ ! compute stress sigma and update memory variables for C-PML !------------------------------------------------------------ do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda(i+1,j) + lambda(i,j)) mu_half_x = 0.5d0 * (mu(i+1,j) + mu(i,j)) lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x value_dvx_dx = (27.d0*vx(i+1,j)-27.d0*vx(i,j)-vx(i+2,j)+vx(i-1,j)) / (24.d0*DELTAX) value_dvy_dy = (27.d0*vy(i,j)-27.d0*vy(i,j-1)-vy(i,j+1)+vy(i,j-2)) / (24.d0*DELTAY) memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j) sigmaxx(i,j) = sigmaxx(i,j) + & (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) * DELTAT sigmayy(i,j) = sigmayy(i,j) + & (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) * DELTAT enddo enddo do j = 1,NY-1 do i = 2,NX ! interpolate material parameters at the right location in the staggered grid cell mu_half_y = 0.5d0 * (mu(i,j+1) + mu(i,j)) value_dvy_dx = (27.d0*vy(i,j)-27.d0*vy(i-1,j)-vy(i+1,j)+vy(i-2,j)) / (24.d0*DELTAX) value_dvx_dy = (27.d0*vx(i,j+1)-27.d0*vx(i,j)-vx(i,j+2)+vx(i,j-1)) / (24.d0*DELTAY) memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j) value_dvx_dy = value_dvx_dy / K_y(j) + memory_dvx_dy(i,j) sigmaxy(i,j) = sigmaxy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy) * DELTAT enddo enddo !-------------------------------------------------------- ! compute velocity and update memory variables for C-PML !-------------------------------------------------------- do j = 2,NY do i = 2,NX value_dsigmaxx_dx = (27.d0*sigmaxx(i,j)-27.d0*sigmaxx(i-1,j)-sigmaxx(i+1,j)+sigmaxx(i-2,j)) / (24.d0*DELTAX) value_dsigmaxy_dy = (27.d0*sigmaxy(i,j)-27.d0*sigmaxy(i,j-1)-sigmaxy(i,j+1)+sigmaxy(i,j-2)) / (24.d0*DELTAY) memory_dsigmaxx_dx(i,j) = b_x(i) * memory_dsigmaxx_dx(i,j) + a_x(i) * value_dsigmaxx_dx memory_dsigmaxy_dy(i,j) = b_y(j) * memory_dsigmaxy_dy(i,j) + a_y(j) * value_dsigmaxy_dy value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j) value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j) vx(i,j) = vx(i,j) + (value_dsigmaxx_dx + value_dsigmaxy_dy) * DELTAT / rho(i,j) enddo enddo do j = 1,NY-1 do i = 1,NX-1 ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) value_dsigmaxy_dx = (27.d0*sigmaxy(i+1,j)-27.d0*sigmaxy(i,j)-sigmaxy(i+2,j)+sigmaxy(i-1,j)) / (24.d0*DELTAX) value_dsigmayy_dy = (27.d0*sigmayy(i,j+1)-27.d0*sigmayy(i,j)-sigmayy(i,j+2)+sigmayy(i,j-1)) / (24.d0*DELTAY) memory_dsigmaxy_dx(i,j) = b_x_half(i) * memory_dsigmaxy_dx(i,j) + a_x_half(i) * value_dsigmaxy_dx memory_dsigmayy_dy(i,j) = b_y_half(j) * memory_dsigmayy_dy(i,j) + a_y_half(j) * value_dsigmayy_dy value_dsigmaxy_dx = value_dsigmaxy_dx / K_x_half(i) + memory_dsigmaxy_dx(i,j) value_dsigmayy_dy = value_dsigmayy_dy / K_y_half(j) + memory_dsigmayy_dy(i,j) vy(i,j) = vy(i,j) + (value_dsigmaxy_dx + value_dsigmayy_dy) * DELTAT / rho_half_x_half_y enddo enddo ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! first derivative of a Gaussian source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term ! define location of the source i = ISOURCE j = JSOURCE ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) vx(i,j) = vx(i,j) + force_x * DELTAT / rho(i,j) vy(i,j) = vy(i,j) + force_y * DELTAT / rho_half_x_half_y ! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers vx(1,:) = ZERO vx(NX,:) = ZERO vx(:,1) = ZERO vx(:,NY) = ZERO vy(1,:) = ZERO vy(NX,:) = ZERO vy(:,1) = ZERO vy(:,NY) = ZERO ! store seismograms do irec = 1,NREC sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec)) sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec)) enddo ! compute total energy in the medium (without the PML layers) ! compute kinetic energy first, defined as 1/2 rho ||v||^2 ! in principle we should use rho_half_x_half_y instead of rho for vy ! in order to interpolate density at the right location in the staggered grid cell ! but in a homogeneous medium we can safely ignore it total_energy_kinetic(it) = 0.5d0 * sum( & rho(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)*( & vx(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2 + & vy(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2)) ! add potential energy, defined as 1/2 epsilon_ij sigma_ij ! in principle we should interpolate the medium parameters at the right location ! in the staggered grid cell but in a homogeneous medium we can safely ignore it total_energy_potential(it) = ZERO do j = NPOINTS_PML, NY-NPOINTS_PML+1 do i = NPOINTS_PML, NX-NPOINTS_PML+1 epsilon_xx = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmaxx(i,j) - lambda(i,j) * & sigmayy(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j))) epsilon_yy = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmayy(i,j) - lambda(i,j) * & sigmaxx(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j))) epsilon_xy = sigmaxy(i,j) / (2.d0 * mu(i,j)) total_energy_potential(it) = total_energy_potential(it) + & 0.5d0 * (epsilon_xx * sigmaxx(i,j) + epsilon_yy * sigmayy(i,j) + 2.d0 * epsilon_xy * sigmaxy(i,j)) enddo enddo ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! print maximum of norm of velocity velocnorm = maxval(sqrt(vx**2 + vy**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',velocnorm print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) print * ! check stability of the code, exit if unstable if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' call create_color_image(vx,NX+2,NY+2,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1) call create_color_image(vy,NX+2,NY+2,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "cpml_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) open(unit=20,file='plot_comparison',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "compare_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:4 t ''Total energy CPML'' w l lc 1, & & "../collino/energy.dat" us 1:4 t ''Total energy Collino'' w l lc 2' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_CPML_2D_iso_fourth !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT) implicit none integer nt,nrec double precision DELTAT double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_CPML_2D_isotropic_second_order.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.1, November 2009. ! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! This software is a computer program whose purpose is to solve ! the two-dimensional isotropic elastic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_2D_iso_second ! 2D elastic finite-difference code in velocity and stress formulation ! with Convolutional-PML (C-PML) absorbing conditions for an isotropic medium ! Dimitri Komatitsch, University of Pau, France, April 2007. ! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these ! articles: ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! total number of grid points in each direction of the grid integer, parameter :: NX = 101 integer, parameter :: NY = 641 ! size of a grid cell double precision, parameter :: DELTAX = 10.d0 double precision, parameter :: DELTAY = DELTAX ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! P-velocity, S-velocity and density double precision, parameter :: cp = 3300.d0 double precision, parameter :: cs = cp / 1.732d0 double precision, parameter :: density = 2800.d0 ! total number of time steps integer, parameter :: NSTEP = 2000 ! time step in seconds double precision, parameter :: DELTAT = 2.d-3 ! parameters for the source double precision, parameter :: f0 = 7.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d7 ! source integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1 integer, parameter :: JSOURCE = 2 * NY / 3 + 1 double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY ! angle of source force in degrees and clockwise, with respect to the vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 135.d0 ! receivers integer, parameter :: NREC = 2 double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters double precision, parameter :: xfin = xsource ! last receiver x in meters double precision, parameter :: yfin = 300.d0 ! last receiver y in meters ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 100 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays double precision, dimension(NX,NY) :: vx,vy,sigma_xx,sigma_yy,sigma_xy,lambda,mu,rho ! to interpolate material parameters at the right location in the staggered grid cell double precision lambda_half_x,mu_half_x,lambda_plus_two_mu_half_x,mu_half_y,rho_half_x_half_y ! for evolution of total energy in the medium double precision :: epsilon_xx,epsilon_yy,epsilon_xy double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(NX,NY) :: & memory_dvx_dx, & memory_dvx_dy, & memory_dvy_dx, & memory_dvy_dy, & memory_dsigma_xx_dx, & memory_dsigma_yy_dy, & memory_dsigma_xy_dx, & memory_dsigma_xy_dy double precision :: & value_dvx_dx, & value_dvx_dy, & value_dvy_dx, & value_dvy_dy, & value_dsigma_xx_dx, & value_dsigma_yy_dy, & value_dsigma_xy_dx, & value_dsigma_xy_dy ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized ! for the source double precision :: a,t,force_x,force_y,source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy integer :: i,j,it,irec double precision :: Courant_number,velocnorm !--- !--- program starts here !--- print * print *,'2D elastic finite-difference code in velocity and stress formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_y) print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print * d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! compute the Lame parameters and density do j = 1,NY do i = 1,NX rho(i,j) = density mu(i,j) = density*cs*cs lambda(i,j) = density*(cp*cp - 2.d0*cs*cs) enddo enddo ! print position of the source print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print *,'There are ',nrec,' receivers' print * xspacerec = (xfin-xdeb) / dble(NREC-1) yspacerec = (yfin-ydeb) / dble(NREC-1) do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number = cp * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2) print *,'Courant number is ',Courant_number print * if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable' ! suppress old files (can be commented out if "call system" is missing in your compiler) ! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif') ! initialize arrays vx(:,:) = ZERO vy(:,:) = ZERO sigma_xx(:,:) = ZERO sigma_yy(:,:) = ZERO sigma_xy(:,:) = ZERO ! PML memory_dvx_dx(:,:) = ZERO memory_dvx_dy(:,:) = ZERO memory_dvy_dx(:,:) = ZERO memory_dvy_dy(:,:) = ZERO memory_dsigma_xx_dx(:,:) = ZERO memory_dsigma_yy_dy(:,:) = ZERO memory_dsigma_xy_dx(:,:) = ZERO memory_dsigma_xy_dy(:,:) = ZERO ! initialize seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO ! initialize total energy total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO !--- !--- beginning of time loop !--- do it = 1,NSTEP !------------------------------------------------------------ ! compute stress sigma and update memory variables for C-PML !------------------------------------------------------------ do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda(i+1,j) + lambda(i,j)) mu_half_x = 0.5d0 * (mu(i+1,j) + mu(i,j)) lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x value_dvx_dx = (vx(i+1,j) - vx(i,j)) / DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) / DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j) sigma_xx(i,j) = sigma_xx(i,j) + & (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) * DELTAT sigma_yy(i,j) = sigma_yy(i,j) + & (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) * DELTAT enddo enddo do j = 1,NY-1 do i = 2,NX ! interpolate material parameters at the right location in the staggered grid cell mu_half_y = 0.5d0 * (mu(i,j+1) + mu(i,j)) value_dvy_dx = (vy(i,j) - vy(i-1,j)) / DELTAX value_dvx_dy = (vx(i,j+1) - vx(i,j)) / DELTAY memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j) value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j) sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy) * DELTAT enddo enddo !-------------------------------------------------------- ! compute velocity and update memory variables for C-PML !-------------------------------------------------------- do j = 2,NY do i = 2,NX value_dsigma_xx_dx = (sigma_xx(i,j) - sigma_xx(i-1,j)) / DELTAX value_dsigma_xy_dy = (sigma_xy(i,j) - sigma_xy(i,j-1)) / DELTAY memory_dsigma_xx_dx(i,j) = b_x(i) * memory_dsigma_xx_dx(i,j) + a_x(i) * value_dsigma_xx_dx memory_dsigma_xy_dy(i,j) = b_y(j) * memory_dsigma_xy_dy(i,j) + a_y(j) * value_dsigma_xy_dy value_dsigma_xx_dx = value_dsigma_xx_dx / K_x(i) + memory_dsigma_xx_dx(i,j) value_dsigma_xy_dy = value_dsigma_xy_dy / K_y(j) + memory_dsigma_xy_dy(i,j) vx(i,j) = vx(i,j) + (value_dsigma_xx_dx + value_dsigma_xy_dy) * DELTAT / rho(i,j) enddo enddo do j = 1,NY-1 do i = 1,NX-1 ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) value_dsigma_xy_dx = (sigma_xy(i+1,j) - sigma_xy(i,j)) / DELTAX value_dsigma_yy_dy = (sigma_yy(i,j+1) - sigma_yy(i,j)) / DELTAY memory_dsigma_xy_dx(i,j) = b_x_half(i) * memory_dsigma_xy_dx(i,j) + a_x_half(i) * value_dsigma_xy_dx memory_dsigma_yy_dy(i,j) = b_y_half(j) * memory_dsigma_yy_dy(i,j) + a_y_half(j) * value_dsigma_yy_dy value_dsigma_xy_dx = value_dsigma_xy_dx / K_x_half(i) + memory_dsigma_xy_dx(i,j) value_dsigma_yy_dy = value_dsigma_yy_dy / K_y_half(j) + memory_dsigma_yy_dy(i,j) vy(i,j) = vy(i,j) + (value_dsigma_xy_dx + value_dsigma_yy_dy) * DELTAT / rho_half_x_half_y enddo enddo ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! first derivative of a Gaussian source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term ! define location of the source i = ISOURCE j = JSOURCE ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) vx(i,j) = vx(i,j) + force_x * DELTAT / rho(i,j) vy(i,j) = vy(i,j) + force_y * DELTAT / rho_half_x_half_y ! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers vx(1,:) = ZERO vx(NX,:) = ZERO vx(:,1) = ZERO vx(:,NY) = ZERO vy(1,:) = ZERO vy(NX,:) = ZERO vy(:,1) = ZERO vy(:,NY) = ZERO ! store seismograms do irec = 1,NREC sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec)) sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec)) enddo ! compute total energy in the medium (without the PML layers) ! compute kinetic energy first, defined as 1/2 rho ||v||^2 ! in principle we should use rho_half_x_half_y instead of rho for vy ! in order to interpolate density at the right location in the staggered grid cell ! but in a homogeneous medium we can safely ignore it total_energy_kinetic(it) = 0.5d0 * sum( & rho(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)*( & vx(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)**2 + & vy(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)**2)) ! add potential energy, defined as 1/2 epsilon_ij sigma_ij ! in principle we should interpolate the medium parameters at the right location ! in the staggered grid cell but in a homogeneous medium we can safely ignore it total_energy_potential(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML epsilon_xx = ((lambda(i,j) + 2.d0*mu(i,j)) * sigma_xx(i,j) - lambda(i,j) * & sigma_yy(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j))) epsilon_yy = ((lambda(i,j) + 2.d0*mu(i,j)) * sigma_yy(i,j) - lambda(i,j) * & sigma_xx(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j))) epsilon_xy = sigma_xy(i,j) / (2.d0 * mu(i,j)) total_energy_potential(it) = total_energy_potential(it) + & 0.5d0 * (epsilon_xx * sigma_xx(i,j) + epsilon_yy * sigma_yy(i,j) + 2.d0 * epsilon_xy * sigma_xy(i,j)) enddo enddo ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! print maximum of norm of velocity velocnorm = maxval(sqrt(vx**2 + vy**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',velocnorm print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) print * ! check stability of the code, exit if unstable if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1) call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "cpml_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) open(unit=20,file='plot_comparison',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "compare_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:4 t ''Total energy CPML'' w l lc 1, & & "../collino/energy.dat" us 1:4 t ''Total energy Collino'' w l lc 2' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_CPML_2D_iso_second !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT) implicit none integer nt,nrec double precision DELTAT double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_CPML_2D_poroelastic_fourth_order.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.1, November 2009. ! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributors: Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr ! and Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! This software is a computer program whose purpose is to solve ! the poroelastic elastic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions and Biot model with and without viscous dissipation. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_2D_poroelastic_fourth ! 2D poroelastic finite-difference code in velocity and stress formulation ! with Convolution-PML (C-PML) absorbing conditions ! with and without viscous dissipation ! Roland Martin, University of Pau, France, October 2009. ! based on the elastic code of Komatitsch and Martin, 2007. ! The fourth-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these ! articles: ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! To display the results as color images in the selected 2D cut plane, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif ! " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif ! " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! To display the 2D results as PostScript vector plots with small arrows, use: ! ! " gs vect*.ps " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! total number of grid points in each direction of the grid integer, parameter :: NX = 140 integer, parameter :: NY = 620 ! size of a grid cell double precision, parameter :: DELTAX = 0.5D0 double precision, parameter :: DELTAY = DELTAX ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_LEFT = .true. logical, parameter :: USE_PML_RIGHT = .true. logical, parameter :: USE_PML_BOTTOM = .true. logical, parameter :: USE_PML_TOP = .true. ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! heterogeneous model and height of the interface logical, parameter :: HETEROGENEOUS_MODEL = .true. double precision, parameter :: INTERFACE_HEIGHT =105.D0+NPOINTS_PML*DELTAY integer, parameter:: JINTERFACE=INT(INTERFACE_HEIGHT/DELTAY)+1 double precision :: co,c1,c2,vtemp ! model mud saturated with water, see article by Martin and Komatitsch double precision, parameter :: etaokappa_bottom=0.d0 double precision, parameter :: rmu_bottom = 5.25D09 double precision, parameter :: phi_bottom =0.25d0 double precision, parameter :: a_bottom = 2.49d0 double precision, parameter :: rhos_bottom = 2588.d0 double precision, parameter :: rhof_bottom = 952.4d0 double precision, parameter :: rho_bottom =2179.1d0 double precision, parameter :: rsm_bottom =9486.d0 double precision, parameter :: alpha_bottom=0.89d0 double precision, parameter :: rbM_bottom =7.71d09 double precision, parameter :: rlambdao_bottom = 6.2D08 double precision, parameter :: rlambdac_bottom =rlambdao_bottom+alpha_bottom**2*rbM_bottom double precision, parameter :: ro11_b=rho_bottom+phi_bottom*rhof_bottom*(a_bottom-2.d0) double precision, parameter :: ro12_b=phi_bottom*rhof_bottom*(1.d0-a_bottom) double precision, parameter :: ro22_b=a_bottom*phi_bottom*rhof_bottom double precision, parameter :: lambda_b=rlambdao_bottom+rbM_bottom*(alpha_bottom-phi_bottom)**2 double precision, parameter :: R_b=rbM_bottom*phi_bottom**2 double precision, parameter :: ga_b=rbM_bottom*phi_bottom*(alpha_bottom-phi_bottom) double precision, parameter :: S_b=lambda_b+2*rmu_bottom double precision, parameter :: c1_b=S_b*R_b-ga_b**2 double precision, parameter :: b1_b=-S_b*ro22_b-R_b*ro11_b+2*ga_b*ro12_b double precision, parameter :: a1_b=ro11_b*ro22_b-ro12_b**2 double precision, parameter :: delta_b=b1_b**2-4.d0*a1_b*c1_b double precision:: cp_bottom double precision:: cps_bottom double precision:: cs_bottom double precision, parameter :: etaokappa_top=3.33D06 double precision, parameter :: rmu_top = 2.4D09 double precision, parameter :: phi_top =0.1d0 double precision, parameter :: a_top = 2.42d0 double precision, parameter :: rhos_top = 2250.d0 double precision, parameter :: rhof_top = 1040.d0 double precision, parameter :: rho_top = 2129.d0 double precision, parameter :: rsm_top =25168.d0 double precision, parameter :: alpha_top=0.58d0 double precision, parameter :: rbM_top = 7.34d09 double precision, parameter :: rlambdao_top =6.D08 double precision, parameter :: rlambdac_top =rlambdao_top+alpha_top**2*rbM_top double precision, parameter :: ro11_t=rho_top+phi_top*rhof_top*(a_top-2.d0) double precision, parameter :: ro12_t=phi_top*rhof_top*(1.d0-a_top) double precision, parameter :: ro22_t=a_top*phi_top*rhof_top double precision, parameter :: lambda_t=rlambdao_top+rbM_top*(alpha_top-phi_top)**2 double precision, parameter :: R_t=rbM_top*phi_top**2 double precision, parameter :: ga_t=rbM_top*phi_top*(alpha_top-phi_top) double precision, parameter :: S_t=lambda_t+2*rmu_top double precision, parameter :: c1_t=S_t*R_t-ga_t**2 double precision, parameter :: b1_t=-S_t*ro22_t-R_t*ro11_t+2*ga_t*ro12_t double precision, parameter :: a1_t=ro11_t*ro22_t-ro12_t**2 double precision, parameter :: delta_t=b1_t**2-4.d0*a1_t*c1_t double precision:: cp_top double precision:: cps_top double precision:: cs_top ! total number of time steps integer, parameter :: NSTEP = 100000 ! time step in seconds double precision, parameter :: DELTAT = 1.d-04 ! parameters for the source double precision, parameter :: f0 = 80.d0 double precision, parameter :: t0 = 1.d0/f0 double precision, parameter :: factor =1.d02 ! source integer, parameter :: ISOURCE = NX/2+1 integer, parameter :: JSOURCE = NY/2 +1 integer, parameter :: IDEB = NX / 2 + 1 integer, parameter :: JDEB = NY / 2 + 1 double precision, parameter :: xsource = DELTAX * ISOURCE double precision, parameter :: ysource = DELTAY * JSOURCE ! angle of source force clockwise with respect to vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 0.d0 ! receivers integer, parameter :: NREC = 2 double precision, parameter :: ydeb = NPOINTS_PML*DELTAY+10.D0 ! first receiver x in meters double precision, parameter :: yfin = NY*DELTAY-NPOINTS_PML*DELTAY-10.d0 ! first receiver x in meters double precision, parameter :: xdeb =xsource ! first receiver y in meters double precision, parameter :: xfin =xdeb ! first receiver y in meters ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 200 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays double precision, dimension(0:NX+1,0:NY+1) :: vx,vy,sigmaxx,sigma2,alp_sigma2,sigmayy,sigmaxy,vnorm double precision, dimension(0:NX+1,0:NY+1) :: vxf,vyf double precision, dimension(0:NX+1,0:NY+1) :: rho,rhof,rsm,rmu,rlambdac,rbM,alpha,etaokappa,rlambdao ! to interpolate material parameters at the right location in the staggered grid cell double precision rho_half_x_half_y,rhof_half_x_half_y,rsm_half_x_half_y,etaokappa_half_x_half_y ! for evolution of total energy in the medium double precision epsilon_xx,epsilon_yy,epsilon_xy double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential double precision c33_half_y ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! 2D arrays for the memory variables double precision, dimension(0:NX+1,0:NY+1) :: gamma11,gamma22 double precision, dimension(0:NX+1,0:NY+1) :: gamma12_1 double precision, dimension(0:NX+1,0:NY+1) :: xi_1,xi_2 double precision, dimension(0:NX+1,0:NY+1) :: & memory_dx_vx1,memory_dx_vx2,memory_dy_vx,memory_dx_vy,memory_dy_vy1,memory_dy_vy2, & memory_dx_sigmaxx,memory_dx_sigmayy,memory_dx_sigmaxy, & memory_dx_sigma2vx,memory_dx_sigma2vxf,memory_dy_sigma2vy,memory_dy_sigma2vyf, & memory_dy_sigmaxx,memory_dy_sigmayy,memory_dy_sigmaxy ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half_x,K_x_half_x,alpha_x_half_x,a_x_half_x,b_x_half_x double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half_y,K_y_half_y,alpha_y_half_y,a_y_half_y,b_y_half_y double precision thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized double precision value_dx_vx1,value_dx_vx2,value_dx_vy,value_dx_sigmaxx,value_dx_sigmaxy double precision value_dy_vy1,value_dy_vy2,value_dy_vx,value_dy_sigmaxx,value_dy_sigmaxy double precision value_dx_sigma2vxf,value_dy_sigma2vyf ! for the source double precision a,t,source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sisp integer i,j,it,irec double precision Courant_number_bottom,Courant_number_top,velocnorm_all,max_amplitude double precision Dispersion_number_bottom,Dispersion_number_top !--- !--- program starts here !--- cp_bottom=(-b1_b+sqrt(delta_b))/(2.d0*a1_b); cps_bottom=(-b1_b-sqrt(delta_b))/(2.d0*a1_b); cp_bottom=sqrt(cp_bottom) cps_bottom=sqrt(cps_bottom) cs_bottom=sqrt(rmu_bottom/(ro11_b-ro12_b**2/ro22_b)) cp_top=(-b1_t+sqrt(delta_t))/(2.d0*a1_t); cps_top=(-b1_t-sqrt(delta_t))/(2.d0*a1_t); cp_top=sqrt(cp_top) cps_top=sqrt(cps_top) cs_top=sqrt(rmu_top/(ro11_t-ro12_t**2/ro22_t)) print *,'cp_bottom= ',cp_bottom print *,'cps_bottom=',cps_bottom print *,'cs_bottom= ',cs_bottom print *,'cp_top= ',cp_top print *,'cps_top=',cps_top print *,'cs_top= ',cs_top print *,'rho_bottom= ',rho_bottom print *,'rsm_bottom= ',rsm_bottom print *,'rho_top= ',rho_top print *,'rsm_top= ',rsm_top print *,'rmu_bottom= ',rmu_bottom print *,'rlambdac_bottom= ',rlambdac_bottom print *,'rlambdao_bottom= ',rlambdao_bottom print *,'alpha_bottom= ',alpha_bottom print *,'rbM_bottom= ',rbM_bottom print *,'etaokappa_bottom= ',etaokappa_bottom print *,'rmu_top= ',rmu_top print *,'rlambdac_top= ',rlambdac_top print *,'rlambdao_top= ',rlambdao_top print *,'alpha_top= ',alpha_top print *,'rbM_top= ',rbM_top print *,'etaokappa_top= ',etaokappa_top print *, 'DELTAT CPML=', DELTAT print *,'2D poroelastic finite-difference code in velocity and stress formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf if (HETEROGENEOUS_MODEL) then d0_x = - (NPOWER + 1) * max(cp_bottom,cp_top) * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * max(cp_bottom,cp_top) * log(Rcoef) / (2.d0 * thickness_PML_y) else d0_x = - (NPOWER + 1) * cp_bottom * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp_bottom * log(Rcoef) / (2.d0 * thickness_PML_y) endif print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y d_x(:) = ZERO d_x_half_x(:) = ZERO d_y(:) = ZERO d_y_half_y(:) = ZERO K_x(:) = 1.d0 K_x_half_x(:) = 1.d0 K_y(:) = 1.d0 K_y_half_y(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half_x(:) = ZERO alpha_y(:) = ZERO alpha_y_half_y(:) = ZERO a_x(:) = ZERO a_x_half_x(:) = ZERO a_y(:) = ZERO a_y_half_y(:) = ZERO ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !!!! ---------- left edge if (USE_PML_LEFT) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !!!! ---------- right edge if (USE_PML_RIGHT) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half_x(i) < ZERO) alpha_x_half_x(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half_x(i) = exp(- (d_x_half_x(i) / K_x_half_x(i) + alpha_x_half_x(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) /& (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half_x(i)) > 1.d-6) a_x_half_x(i) = d_x_half_x(i)& * (b_x_half_x(i) - 1.d0) / (K_x_half_x(i) * (d_x_half_x(i) + K_x_half_x(i) * alpha_x_half_x(i))) enddo !!!!!!!!!!!!! added Y damping profile ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = NY*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !!!! ---------- bottom edge if (USE_PML_BOTTOM) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !!!! ---------- top edge if (USE_PML_TOP) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end ! if (alpha_y(j) < ZERO) alpha_y(j) = ZERO ! if (alpha_y_half_y(j) < ZERO) alpha_y_half_y(j) = ZERO b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half_y(j) = exp(- (d_y_half_y(j) / K_y_half_y(j) + alpha_y_half_y(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) & / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half_y(j)) > 1.d-6) a_y_half_y(j) = d_y_half_y(j)& * (b_y_half_y(j) - 1.d0) / (K_y_half_y(j) * (d_y_half_y(j) + K_y_half_y(j) * alpha_y_half_y(j))) enddo ! compute the Lame parameters and density do j = 0,NY+1 do i = 0,NX+1 if (HETEROGENEOUS_MODEL .and. DELTAY*dble(j-1) > INTERFACE_HEIGHT) then rho(i,j)= rho_top rhof(i,j) = rhof_top rsm(i,j) = rsm_top rmu(i,j)= rmu_top rlambdac(i,j) = rlambdac_top rbM(i,j) = rbM_top alpha(i,j)=alpha_top etaokappa(i,j)=etaokappa_top rlambdao(i,j) = rlambdao_top else rho(i,j)= rho_bottom rhof(i,j) = rhof_bottom rsm(i,j) = rsm_bottom rmu(i,j)= rmu_bottom rlambdac(i,j) = rlambdac_bottom rbM(i,j) = rbM_bottom alpha(i,j)=alpha_bottom etaokappa(i,j)=etaokappa_bottom rlambdao(i,j) = rlambdao_bottom endif enddo enddo ! print position of the source print * print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print * print *,'There are ',nrec,' receivers' print * xspacerec = (xfin-xdeb) / dble(NREC-1) yspacerec = (yfin-ydeb) / dble(NREC-1) do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number_bottom = cp_bottom * DELTAT / min(DELTAX,DELTAY) Dispersion_number_bottom=min(cs_bottom,cps_bottom)/(2.5d0*f0*max(DELTAX,DELTAY)) print *,'Courant number at the bottom is ',Courant_number_bottom print *,'Dispersion number at the bottom is ',Dispersion_number_bottom print * if (Courant_number_bottom > 1.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable' if (HETEROGENEOUS_MODEL) then Courant_number_top = max(cp_top,cp_bottom) * DELTAT / min(DELTAX,DELTAY) Dispersion_number_top=min(cs_top,cs_bottom,cps_bottom,cps_top)/(2.5d0*f0*max(DELTAX,DELTAY)) print *,'Courant number at the top is ',Courant_number_top print * print *,'Dispersion number at the top is ',Dispersion_number_top if (Courant_number_top > 6.d0/7.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable' endif ! suppress old files ! call system('rm -f Vx_*.dat Vy_*.dat vect*.ps image*.pnm image*.gif') ! initialize arrays vx(:,:) = ZERO vy(:,:) = ZERO sigmaxx(:,:) = ZERO sigmayy(:,:) = ZERO sigmaxy(:,:) = ZERO sigma2(:,:) = ZERO alp_sigma2(:,:) = ZERO gamma11(:,:)=0.d0 gamma22(:,:)=0.d0 gamma12_1(:,:)=0.d0 gamma12_1(:,:)=0.d0 xi_1(:,:)=0.d0 xi_2(:,:)=0.d0 vxf(:,:) = ZERO vyf(:,:) = ZERO memory_dx_vx1(:,:)=0.d0 memory_dx_vx2(:,:)=0.d0 memory_dy_vx(:,:)=0.d0 memory_dx_vy(:,:)=0.d0 memory_dy_vy1(:,:)=0.d0 memory_dy_vy2(:,:)=0.d0 memory_dx_sigmaxx(:,:)=0.d0 memory_dx_sigmayy(:,:)=0.d0 memory_dx_sigmaxy(:,:)=0.d0 memory_dx_sigma2vx(:,:)=0.d0 memory_dx_sigma2vxf(:,:)=0.d0 memory_dy_sigmaxx(:,:)=0.d0 memory_dy_sigmayy(:,:)=0.d0 memory_dy_sigmaxy(:,:)=0.d0 memory_dy_sigma2vy(:,:)=0.d0 memory_dy_sigma2vyf(:,:)=0.d0 ! initialize seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO sisp(:,:) = ZERO ! initialize total energy total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO !--- !--- beginning of time loop !--- do it = 1,NSTEP !---------------------- ! compute stress sigma !---------------------- !----------------------------------- ! update memory variables for C-PML !----------------------------------- do j = 2,NY do i = 1,NX-1 ! memory of sigmaxx value_dx_sigmaxx =(27.d0*vx(i+1,j)-27.d0*vx(i,j)-vx(i+2,j)+vx(i-1,j))/DELTAX/24.D0 value_dy_sigmaxx =(27.d0*vy(i,j)-27.d0*vy(i,j-1)-vy(i,j+1)+vy(i,j-2))/DELTAY/24.D0 memory_dx_sigmaxx(i,j) = b_x_half_x(i) * memory_dx_sigmaxx(i,j) + a_x_half_x(i) * value_dx_sigmaxx memory_dy_sigmaxx(i,j) = b_y(j) * memory_dy_sigmaxx(i,j) + a_y(j) * value_dy_sigmaxx gamma11(i,j) = gamma11(i,j)+DELTAT*(value_dx_sigmaxx / K_x_half_x(i) + memory_dx_sigmaxx(i,j)) gamma22(i,j) = gamma22(i,j)+DELTAT*(value_dy_sigmaxx / K_y(j) + memory_dy_sigmaxx(i,j)) ! sigma2 value_dx_sigma2vxf=(27.d0*vxf(i+1,j)-27.d0* vxf(i,j)-vxf(i+2,j)+vxf(i-1,j)) / DELTAX/24.D0 value_dy_sigma2vyf=(27.d0*vyf(i,j)-27.d0*vyf(i,j-1)-vyf(i,j+1)+vyf(i,j-2)) / DELTAY/24.D0 memory_dx_sigma2vxf(i,j) = b_x_half_x(i) * memory_dx_sigma2vxf(i,j) + a_x_half_x(i) * value_dx_sigma2vxf memory_dy_sigma2vyf(i,j) = b_y(j) * memory_dy_sigma2vyf(i,j) + a_y(j) * value_dy_sigma2vyf xi_1(i,j) = xi_1(i,j) -(value_dx_sigma2vxf/ K_x_half_x(i) + memory_dx_sigma2vxf(i,j))*DELTAT xi_2(i,j) = xi_2(i,j) -(value_dy_sigma2vyf/K_y(j)+memory_dy_sigma2vyf(i,j))*DELTAT sigma2(i,j)=-alpha(i,j)*rbM(i,j)*(gamma11(i,j)+gamma22(i,j))+rbM(i,j)*(xi_1(i,j)+xi_2(i,j)) enddo enddo ! add the source (point source located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian source_term = factor * exp(-a*(t-t0)**2)/(-2.d0*a) ! first derivative of a Gaussian ! source_term = factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! source_term = factor *(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) ! define location of the source i = ISOURCE j = JSOURCE ! add the source term sigma2(i,j) = sigma2(i,j) + source_term*rbM(i,j) do j = 1,NY-1 do i = 2,NX ! interpolate material parameters at the right location in the staggered grid cell c33_half_y = 2.d0/(1.d0/rmu(i,j)+1.d0/rmu(i,j+1)) c33_half_y = rmu(i,j+1) value_dx_sigmaxy = (27.d0*vy(i,j) - 27.d0*vy(i-1,j)-vy(i+1,j)+vy(i-2,j)) / DELTAX/24.D0 value_dy_sigmaxy = (27.d0*vx(i,j+1) - 27.d0*vx(i,j)-vx(i,j+2)+vx(i,j-1)) / DELTAY/24.D0 memory_dx_sigmaxy(i,j) = b_x(i) * memory_dx_sigmaxy(i,j) + a_x(i) * value_dx_sigmaxy memory_dy_sigmaxy(i,j) = b_y_half_y(j) * memory_dy_sigmaxy(i,j) + a_y_half_y(j) * value_dy_sigmaxy sigmaxy(i,j) = sigmaxy(i,j) + & c33_half_y/1.d0 * (value_dx_sigmaxy / K_x(i) + memory_dx_sigmaxy(i,j) + & value_dy_sigmaxy / K_y(j) + memory_dy_sigmaxy(i,j)) * DELTAT enddo enddo do j = 2,NY do i = 1,NX-1 sigmaxx(i,j)=(rlambdao(i,j)+2.d0*rmu(i,j))*gamma11(i,j)+rlambdao(i,j)*gamma22(i,j) -alpha(i,j)*sigma2(i,j) sigmayy(i,j)=rlambdao(i,j)*gamma11(i,j)+(rlambdao(i,j)+2.d0*rmu(i,j))*gamma22(i,j) -alpha(i,j)*sigma2(i,j) enddo enddo !------------------ ! compute velocity !------------------ !----------------------------------- ! update memory variables for C-PML !----------------------------------- do j = 2,NY do i = 2,NX co=(rho(i,j)*rsm(i,j)-rhof(i,j)*rhof(i,j))/DELTAT c1=co+rho(i,j)*etaokappa(i,j)*0.5d0 c2=co-rho(i,j)*etaokappa(i,j)*0.5d0 vtemp=vxf(i,j) value_dx_vx1 = (27.d0*sigmaxx(i,j) - 27.d0*sigmaxx(i-1,j)& -sigmaxx(i+1,j)+sigmaxx(i-2,j)) / DELTAX/24.D0 value_dx_vx2 = (27.d0*sigma2(i,j) - 27.d0*sigma2(i-1,j)-sigma2(i+1,j)+sigma2(i-2,j)) / DELTAX/24.D0 value_dy_vx = (27.d0*sigmaxy(i,j) - 27.d0*sigmaxy(i,j-1)-sigmaxy(i,j+1)+sigmaxy(i,j-2)) / DELTAY/24.D0 memory_dx_vx1(i,j) = b_x(i) * memory_dx_vx1(i,j) + a_x(i) * value_dx_vx1 memory_dx_vx2(i,j) = b_x(i) * memory_dx_vx2(i,j) + a_x(i) * value_dx_vx2 memory_dy_vx(i,j) = b_y(j) * memory_dy_vx(i,j) + a_y(j) * value_dy_vx vxf(i,j) = (c2*vxf(i,j) + & (-rhof(i,j)*(value_dx_vx1/ K_x(i) + memory_dx_vx1(i,j) & + value_dy_vx / K_y(j) + memory_dy_vx(i,j)) & -rho(i,j)*(value_dx_vx2/ K_x(i) + memory_dx_vx2(i,j)) & )) /c1 vtemp=(vtemp+vxf(i,j))*0.5d0 vx(i,j) = vx(i,j) + & (rsm(i,j)*(value_dx_vx1/ K_x(i) + memory_dx_vx1(i,j)+ & value_dy_vx / K_y(j) + memory_dy_vx(i,j))+& rhof(i,j)*(value_dx_vx2/ K_x(i) + memory_dx_vx2(i,j)) + & rhof(i,j)*etaokappa(i,j)*vtemp)& /co enddo enddo do j = 1,NY-1 do i = 1,NX-1 rho_half_x_half_y = rho(i,j+1) rsm_half_x_half_y = rsm(i,j+1) rhof_half_x_half_y = rhof(i,j+1) etaokappa_half_x_half_y = etaokappa(i,j+1) co=(rho_half_x_half_y*rsm_half_x_half_y-rhof_half_x_half_y**2)/DELTAT c1=co+rho_half_x_half_y*etaokappa_half_x_half_y*0.5d0 c2=co-rho_half_x_half_y*etaokappa_half_x_half_y*0.5d0 vtemp=vyf(i,j) value_dx_vy = (27.d0*sigmaxy(i+1,j) - 27.d0*sigmaxy(i,j)-sigmaxy(i+2,j)+sigmaxy(i-1,j)) / DELTAX/24.D0 value_dy_vy1 = (27.d0*sigmayy(i,j+1)- 27.d0*sigmayy(i,j)& -sigmayy(i,j+2)+sigmayy(i,j-1)) / DELTAY/24.D0 value_dy_vy2 = (27.d0*sigma2(i,j+1) - 27.d0*sigma2(i,j)-sigma2(i,j+2)+sigma2(i,j-1)) / DELTAY/24.D0 memory_dx_vy(i,j) = b_x_half_x(i) * memory_dx_vy(i,j) + a_x_half_x(i) * value_dx_vy memory_dy_vy1(i,j) = b_y_half_y(j) * memory_dy_vy1(i,j) + a_y_half_y(j) * value_dy_vy1 memory_dy_vy2(i,j) = b_y_half_y(j) * memory_dy_vy2(i,j) + a_y_half_y(j) * value_dy_vy2 vyf(i,j) = (c2*vyf(i,j) + & (-rhof_half_x_half_y*(value_dx_vy / K_x_half_x(i) + memory_dx_vy(i,j) & +value_dy_vy1 / K_y_half_y(j) + memory_dy_vy1(i,j))& -rho_half_x_half_y*(value_dy_vy2 / K_y_half_y(j) + memory_dy_vy2(i,j)))& ) /c1 vtemp=(vtemp+vyf(i,j))*0.5d0 vy(i,j) = vy(i,j) + & (rsm_half_x_half_y*(value_dx_vy / K_x_half_x(i) + memory_dx_vy(i,j)& + value_dy_vy1 / K_y_half_y(j) + memory_dy_vy1(i,j))& + rhof_half_x_half_y*(value_dy_vy2 / K_y_half_y(j) + memory_dy_vy2(i,j))& + rhof_half_x_half_y*etaokappa_half_x_half_y*vtemp)& /co enddo enddo ! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers vx(1,:) = ZERO vx(NX,:) = ZERO vx(:,1) = ZERO vx(:,NY) = ZERO vy(1,:) = ZERO vy(NX,:) = ZERO vy(:,1) = ZERO vy(:,NY) = ZERO vxf(1,:) = ZERO vxf(NX,:) = ZERO vxf(:,1) = ZERO vxf(:,NY) = ZERO vyf(1,:) = ZERO vyf(NX,:) = ZERO vyf(:,1) = ZERO vyf(:,NY) = ZERO ! store seismograms do irec = 1,NREC ! x component sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec)) ! y component sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec)) ! fluid pressure sisp(it,irec) = sigma2(ix_rec(irec),iy_rec(irec)) enddo ! compute total energy ! compute kinetic energy first, defined as 1/2 rho ||v||^2 ! in principle we should use rho_half_x_half_y instead of rho for vy ! in order to interpolate density at the right location in the staggered grid cell ! but in a homogeneous medium we can safely ignore it total_energy_kinetic(it) = 0.5d0 * & sum(rho(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)& *(vx(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2& +vy(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2))& *DELTAX * DELTAY+& 0.5d0*sum(rsm(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)& *(vxf(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2& +vyf(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2))& *DELTAX*DELTAY ! add potential energy, defined as 1/2 epsilon_ij sigma_ij ! in principle we should interpolate the medium parameters at the right location ! in the staggered grid cell but in a homogeneous medium we can safely ignore it total_energy_potential(it) = ZERO do j = NPOINTS_PML,NY-NPOINTS_PML+1 do i = NPOINTS_PML,NX-NPOINTS_PML+1 epsilon_xx = ((rlambdao(i,j) + 2.d0*rmu(i,j)) * sigmaxx(i,j) - rlambdao(i,j) * sigmayy(i,j)) / & (4.d0 * rmu(i,j) * (rlambdao(i,j) + rmu(i,j))) epsilon_yy = ((rlambdao(i,j) + 2.d0*rmu(i,j)) * sigmayy(i,j) - rlambdao(i,j) * sigmaxx(i,j)) / & (4.d0 * rmu(i,j) * (rlambdao(i,j) + rmu(i,j))) epsilon_xy = sigmaxy(i,j) / (2.d0 * rmu(i,j)) total_energy_potential(it) = total_energy_potential(it) + & 0.5d0 * (epsilon_xx * sigmaxx(i,j) + epsilon_yy * sigmayy(i,j) + 2.d0 * epsilon_xy * sigmaxy(i,j)& +sigma2(i,j)**2/rbM(i,j)& +2.d0*rhof(i,j)*(vx(i,j)*vxf(i,j)+vy(i,j)*vyf(i,j)))*DELTAX * DELTAY enddo enddo ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! print maximum of norm of velocity velocnorm_all = maxval(sqrt(vx(:,:)**2 + vy(:,:)**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',velocnorm_all print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) print * ! check stability of the code, exit if unstable if (velocnorm_all > STABILITY_THRESHOLD) stop 'code became unstable and blew up' vnorm(:,:)=sqrt(vx(:,:)**2+vy(:,:)**2) call create_color_image(vx,NX+2,NY+2,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM, & USE_PML_TOP,1,max_amplitude,JINTERFACE) call create_color_image(vy,NX+2,NY+2,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM, & USE_PML_TOP,2,max_amplitude,JINTERFACE) ! save temporary partial seismograms to monitor the behavior of the simulation ! while it is running call write_seismograms(sisvx,sisvy,sisp,NSTEP,NREC,DELTAT,t0) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,sisp,NSTEP,NREC,DELTAT,t0) ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT), sngl(total_energy_kinetic(it) + total_energy_potential(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) '# set xrange [0:7]' write(20,*) '# set yrange [-4:4.5]' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) '# set output "cpml_total_energy.eps"' write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) '#set xrange [0:7]' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) '#set yrange [-4:4.5]' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) '#set yrange [-15:19]' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) '#set yrange [-12:16]' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) '#set yrange [-7:10]' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_CPML_2D_poroelastic_fourth !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,sisp,nt,nrec,DELTAT,t0) implicit none integer nt,nrec double precision DELTAT,t0 double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) double precision sisp(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Z component do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec)) enddo close(11) enddo ! fluid pressure do irec=1,nrec write(file_name,"('Pf_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisp(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM,USE_PML_TOP,field_number,max_amplitude,JINTERFACE) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.25d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM,USE_PML_TOP double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer ix,iy,irec,JINTERFACE double precision max_amplitude character(len=100) file_name,system_command double precision normalized_value integer :: R, G, B ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i5.5,'_Vx.pnm')") it write(system_command,"('convert image',i5.5,'_Vx.pnm image',i5.5,'_Vx.gif ; rm image',i5.5,'_Vx.pnm')") it,it,it endif if (field_number == 2) then write(file_name,"('image',i5.5,'_Vy.pnm')") it write(system_command,"('convert image',i5.5,'_Vy.pnm image',i5.5,'_Vy.gif ; rm image',i5.5,'_Vy.pnm')") it,it,it endif if (field_number == 3) then write(file_name,"('image',i5.5,'_Vnorm.pnm')") it write(system_command,"('convert image',i5.5,'_Vnorm.pnm image',i5.5,'_Vnorm.gif ; rm image',i5.5,'_Vnorm.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_LEFT .and. ix == NPOINTS_PML) .or. & (USE_PML_RIGHT .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_BOTTOM .and. iy == NPOINTS_PML) .or. & (USE_PML_TOP .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 else if (iy == JINTERFACE) then R = 0 G = 0 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to JPEG ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.3, July 2018. ! ! Copyright CNRS, France. ! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! This software is a computer program whose purpose is to solve ! the two-dimensional heterogeneous isotropic viscoacoustic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_2D_viscoacoust_fourth ! 2D finite-difference code in velocity and pressure formulation ! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic viscoacoustic medium ! Dimitri Komatitsch, CNRS, Marseille, July 2018. ! A fourth-order spatially-staggered grid formulation is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x pressure ! R_dot (viscoacoustic memory variable) ! ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these ! articles: ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! include viscoacoustic attenuation or not logical, parameter :: VISCOACOUSTIC_ATTENUATION = .true. ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! total number of grid points in each direction of the grid integer, parameter :: NX = 2001 integer, parameter :: NY = 2001 ! size of a grid cell double precision, parameter :: DELTAX = 1.5d0 double precision, parameter :: DELTAY = DELTAX ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! P-velocity and density ! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity) double precision, parameter :: cp_unrelaxed = 2000.d0 double precision, parameter :: density = 2000.d0 ! Time step in seconds. ! The CFL stability number for the O(2,2) algorithm is 1 / sqrt(2) = 0.707 ! i.e. one must choose cp * deltat / deltax < 0.707. ! For the O(2,4) algorithm used here it is a bit more restrictive, ! it is cp * deltat / deltax < 0.606 (see Levander 1988 eq (7)). ! However this only ensures that the scheme is stable. To have a scheme that is both stable and accurate, ! for O(2,4) some numerical tests show that one needs to take about half of that, ! i.e. choose deltat so that cp * deltat / deltax is equal to about 0.30 or so. (or any value below; but not above). ! Since the time scheme is only second order, this also depends on how many time steps are performed in total ! (i.e. what the value of NSTEP below is); for large values of NSTEP, of course numerical errors will start to accumulate. double precision, parameter :: DELTAT = 2.2d-4 ! total number of time steps integer, parameter :: NSTEP = 3600 ! parameters for the source double precision, parameter :: f0 = 35.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d0 ! source (in pressure, thus at a gridpoint rather than half a grid cell away) double precision, parameter :: xsource = 1500.d0 double precision, parameter :: ysource = 1500.d0 integer, parameter :: ISOURCE = xsource / DELTAX + 1 integer, parameter :: JSOURCE = ysource / DELTAY + 1 ! receivers integer, parameter :: NREC = 1 !! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters ! to compute energy curves for the whole medium (optional, but useful e.g. to produce ! energy variation figures for articles); but expensive option, thus off by default logical, parameter :: COMPUTE_ENERGY = .false. ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 200 ! compute some constants once and for all for the fourth-order spatial scheme ! These coefficients are given for instance by Levander, Geophysics, vol. 53(11), p. 1436, equation (A-2) double precision, parameter :: NINE_OVER_8_DELTAX = 9.d0 / (8.d0*DELTAX) double precision, parameter :: NINE_OVER_8_DELTAY = 9.d0 / (8.d0*DELTAY) double precision, parameter :: ONE_OVER_24_DELTAX = 1.d0 / (24.d0*DELTAX) double precision, parameter :: ONE_OVER_24_DELTAY = 1.d0 / (24.d0*DELTAY) ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays ! in order to be able to use a fourth-order spatial operator on the edges of the model ! here we define the arrays with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case double precision, dimension(0:NX+1,0:NY+1) :: vx,vy,pressure,kappa_unrelaxed,rho ! to interpolate material parameters or velocity at the right location in the staggered grid cell double precision kappa_half_x,rho_half_x_half_y,vy_interpolated ! for evolution of total energy in the medium double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(NX,NY) :: & memory_dvx_dx, & memory_dvx_dy, & memory_dvy_dx, & memory_dvy_dy, & memory_dpressure_dx, & memory_dpressure_dy double precision :: & value_dvx_dx, & value_dvy_dy, & value_dpressure_dx, & value_dpressure_dy ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half, & one_over_K_x,one_over_K_x_half double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half, & one_over_K_y,one_over_K_y_half double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized ! for the source double precision :: a,t,pressure_source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec integer :: myNREC ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sispressure integer :: i,j,it,irec double precision :: Courant_number,velocnorm,pressurenorm ! for attenuation (viscoacousticity) ! attenuation quality factor Qkappa to use double precision, parameter :: QKappa = 65.d0 ! number of Zener standard linear solids in parallel integer, parameter :: N_SLS = 3 ! attenuation constants double precision, dimension(N_SLS) :: tau_epsilon_kappa,tau_sigma_kappa,one_over_tau_sigma_kappa, & HALF_DELTAT_over_tau_sigma_kappa,multiplication_factor_tau_sigma_kappa,DELTAT_delta_relaxed_over_tau_sigma_without_Kappa ! memory variable for attenuation double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_dot,memory_variable_R_dot_old integer :: i_sls double precision :: sum_of_memory_variables_kappa ! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band double precision :: f_min_attenuation,f_max_attenuation !--- !--- program starts here !--- print * print *,'2D viscoacoustic finite-difference code in velocity and pressure formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * ! for attenuation (viscoacousticity) if (VISCOACOUSTIC_ATTENUATION) then print *,'QKappa quality factor used for attenuation = ',QKappa print *,'Number of Zener standard linear solids used to mimic the viscoacoustic behavior (N_SLS) = ',N_SLS print * ! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band ! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0) f_min_attenuation = exp(log(f0)-log(12.d0)/2.d0) f_max_attenuation = 12.d0 * f_min_attenuation ! call the SolvOpt() nonlinear optimization routine to compute the tau_epsilon and tau_sigma values from a given Q factor call compute_attenuation_coeffs(N_SLS,QKappa,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_kappa,tau_sigma_kappa) else ! dummy values in the non-dissipative case tau_epsilon_kappa(:) = 1.d0 tau_sigma_kappa(:) = 1.d0 endif ! precompute the inverse once and for all, to save computation time in the time loop below ! (on computers, a multiplication is very significantly cheaper than a division) one_over_tau_sigma_kappa(:) = 1.d0 / tau_sigma_kappa(:) HALF_DELTAT_over_tau_sigma_kappa(:) = 0.5d0 * DELTAT / tau_sigma_kappa(:) multiplication_factor_tau_sigma_kappa(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_kappa(:)) ! compute DELTAT_delta_relaxed_over_tau_sigma_without_Kappa, which is a term ! needed to compute the evolution of the viscoacoustic memory variables if (VISCOACOUSTIC_ATTENUATION) then DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = (DELTAT / sum(tau_epsilon_kappa(:) / tau_sigma_kappa(:))) * & (tau_epsilon_kappa(:)/tau_sigma_kappa(:) - 1.d0) / tau_sigma_kappa(:) else DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = ZERO endif !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y) print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print * d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! precompute the inverse once and for all, to save computation time in the time loop below ! (on computers, a multiplication is very significantly cheaper than a division) one_over_K_x(:) = 1.d0 / K_x(:) one_over_K_x_half(:) = 1.d0 / K_x_half(:) one_over_K_y(:) = 1.d0 / K_y(:) one_over_K_y_half(:) = 1.d0 / K_y_half(:) ! compute the Lame parameter and density do j = 1,NY do i = 1,NX rho(i,j) = density kappa_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed enddo enddo ! print position of the source print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print *,'There are ',nrec,' receivers' print * if (NREC > 1) then ! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1 myNREC = NREC xspacerec = (xfin-xdeb) / dble(myNREC-1) yspacerec = (yfin-ydeb) / dble(myNREC-1) else xspacerec = 0.d0 yspacerec = 0.d0 endif do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant, K. O. Friedrichs and H. Lewy (1928) ! For this O(2,4) scheme, when DELTAX == DELTAY the Courant number is given by Levander, Geophysics, vol. 53(11), p. 1427, ! equation (7) and is equal to 0.606 (it is thus smaller than that of the O(2,2) scheme, which is 1/sqrt(2) = 0.707, ! i.e. when switching to a fourth-order spatial scheme one needs a time step that is about 0.707 / 0.606 = 1.167 times smaller. if (DELTAX == DELTAY) then Courant_number = cp_unrelaxed * DELTAT / DELTAX print *,'Courant number is ',Courant_number print *,' (the maximum possible value is 0.606; in practice for accuracy reasons a value not larger than 0.30 is recommended)' print * if (Courant_number > 0.606) stop 'time step is too large, simulation will be unstable' endif ! suppress old files (can be commented out if "call system" is missing in your compiler) call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif') ! initialize arrays vx(:,:) = ZERO vy(:,:) = ZERO pressure(:,:) = ZERO memory_variable_R_dot(:,:,:) = ZERO memory_variable_R_dot_old(:,:,:) = ZERO ! PML memory_dvx_dx(:,:) = ZERO memory_dvx_dy(:,:) = ZERO memory_dvy_dx(:,:) = ZERO memory_dvy_dy(:,:) = ZERO memory_dpressure_dx(:,:) = ZERO memory_dpressure_dy(:,:) = ZERO ! initialize seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO sispressure(:,:) = ZERO ! initialize total energy total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO if (VISCOACOUSTIC_ATTENUATION) then print *,'adding VISCOACOUSTIC_ATTENUATION (i.e., running a viscoacoustic simulation)' else print *,'not adding VISCOACOUSTIC_ATTENUATION (i.e., running a purely acoustic simulation)' endif print * !--- !--- beginning of time loop !--- do it = 1,NSTEP !----------------------------------------------------------------------- ! compute pressure and update memory variables for C-PML ! also update memory variables for viscoacoustic attenuation if needed !----------------------------------------------------------------------- ! we purposely leave this "if" test outside of the loops to make sure the compiler can optimize these loops; ! with an "if" test inside most compilers cannot if (.not. VISCOACOUSTIC_ATTENUATION) then do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j)) value_dvx_dx = (vx(i+1,j) - vx(i,j)) * NINE_OVER_8_DELTAX + (vx(i-1,j) - vx(i+2,j)) * ONE_OVER_24_DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) * NINE_OVER_8_DELTAY + (vy(i,j-2) - vy(i,j+1)) * ONE_OVER_24_DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j) pressure(i,j) = pressure(i,j) - kappa_half_x * (value_dvx_dx + value_dvy_dy) * DELTAT enddo enddo else ! the present becomes the past for the memory variables. ! in C or C++ we could replace this with an exchange of pointers on the arrays ! in order to avoid a memory copy of the whole array. memory_variable_R_dot_old(:,:,:) = memory_variable_R_dot(:,:,:) do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j)) value_dvx_dx = (vx(i+1,j) - vx(i,j)) * NINE_OVER_8_DELTAX + (vx(i-1,j) - vx(i+2,j)) * ONE_OVER_24_DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) * NINE_OVER_8_DELTAY + (vy(i,j-2) - vy(i,j+1)) * ONE_OVER_24_DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j) ! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following ! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here sum_of_memory_variables_kappa = 0.d0 do i_sls = 1,N_SLS ! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) memory_variable_R_dot(i,j,i_sls) = (memory_variable_R_dot_old(i,j,i_sls) + & (value_dvx_dx + value_dvy_dy) * kappa_unrelaxed(i,j) * DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(i_sls) - & memory_variable_R_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_kappa(i_sls)) & * multiplication_factor_tau_sigma_kappa(i_sls) sum_of_memory_variables_kappa = sum_of_memory_variables_kappa + & memory_variable_R_dot(i,j,i_sls) + memory_variable_R_dot_old(i,j,i_sls) enddo pressure(i,j) = pressure(i,j) + (- kappa_half_x * (value_dvx_dx + value_dvy_dy) + & ! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) 0.5d0 * sum_of_memory_variables_kappa) * DELTAT enddo enddo endif ! add the source (pressure located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! pressure_source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a) ! first derivative of a Gaussian pressure_source_term = factor * (t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! pressure_source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) ! to get the right amplitude of the force, we need to divide by the area of a grid cell ! (we checked that against the analytical solution in a homogeneous medium for a pressure source) pressure_source_term = pressure_source_term / (DELTAX * DELTAY) ! define location of the source i = ISOURCE j = JSOURCE ! the pressure source is added to d(pressure)/dt in this split pressure / velocity scheme ! and that is why we need to select the first derivative of a Gaussian as a source time wavelet ! above instead of a Ricker (i.e. a second derivative) added to d2(pressure)/dt2 ! as in the unsplit equation written in pressure only. ! Since the formula is d(pressure)/dt = (pressure_new - pressure_old) / DELTAT = pressure_source_term ! we also need to multiply by DELTAT here to avoid having an amplitude of the seismogram ! that varies when one changes the time step, i.e. we write: ! pressure_new = pressure_old + pressure_source_term * DELTAT at the source grid point pressure(i,j) = pressure(i,j) + pressure_source_term * DELTAT !-------------------------------------------------------- ! compute velocity and update memory variables for C-PML !-------------------------------------------------------- do j = 2,NY do i = 2,NX value_dpressure_dx = (pressure(i,j) - pressure(i-1,j)) * NINE_OVER_8_DELTAX + & (pressure(i-2,j) - pressure(i+1,j)) * ONE_OVER_24_DELTAX memory_dpressure_dx(i,j) = b_x(i) * memory_dpressure_dx(i,j) + a_x(i) * value_dpressure_dx value_dpressure_dx = value_dpressure_dx * one_over_K_x(i) + memory_dpressure_dx(i,j) vx(i,j) = vx(i,j) - value_dpressure_dx * DELTAT / rho(i,j) enddo enddo do j = 1,NY-1 do i = 1,NX-1 ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) value_dpressure_dy = (pressure(i,j+1) - pressure(i,j)) * NINE_OVER_8_DELTAY + & (pressure(i,j-1) - pressure(i,j+2)) * ONE_OVER_24_DELTAY memory_dpressure_dy(i,j) = b_y_half(j) * memory_dpressure_dy(i,j) + a_y_half(j) * value_dpressure_dy value_dpressure_dy = value_dpressure_dy * one_over_K_y_half(j) + memory_dpressure_dy(i,j) vy(i,j) = vy(i,j) - value_dpressure_dy * DELTAT / rho_half_x_half_y enddo enddo ! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers vx(1,:) = ZERO vx(NX,:) = ZERO vx(:,1) = ZERO vx(:,NY) = ZERO vy(1,:) = ZERO vy(NX,:) = ZERO vy(:,1) = ZERO vy(:,NY) = ZERO ! store seismograms do irec = 1,NREC ! beware here that the two components of the velocity vector are not defined at the same point ! in a staggered grid, and thus the two components of the velocity vector are recorded at slightly different locations, ! vy is staggered by half a grid cell along X and along Y with respect to vx sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec)) sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec)) sispressure(it,irec) = pressure(ix_rec(irec),iy_rec(irec)) enddo ! compute total energy in the medium (without the PML layers) if (COMPUTE_ENERGY) then ! compute kinetic energy first, defined as 1/2 rho ||v||^2 total_energy_kinetic(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! interpolate vy back at the location of vx, to be able to use both at the same location vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1)) total_energy_kinetic(it) = total_energy_kinetic(it) + 0.5d0 * rho(i,j) * (vx(i,j)**2 + vy_interpolated**2) enddo enddo ! add potential energy, defined as 1/2 pressure^2 / Kappa total_energy_potential(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! interpolate material parameters at the right location in the staggered grid cell kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j)) total_energy_potential(it) = total_energy_potential(it) + 0.5d0 * pressure(i,j)**2 / kappa_half_x enddo enddo endif ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! print maximum of pressure and of norm of velocity pressurenorm = maxval(abs(pressure)) velocnorm = maxval(sqrt(vx**2 + vy**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max absolute value of pressure = ',pressurenorm print *,'Max norm velocity vector V (m/s) = ',velocnorm if (COMPUTE_ENERGY) print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) print * ! check stability of the code, exit if unstable if (pressurenorm > STABILITY_THRESHOLD .or. velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' ! call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & ! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1) ! call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & ! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2) call create_color_image(pressure,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,3) ! save the part of the seismograms that has been computed so far, so that users can monitor the progress of the simulation call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0) if (COMPUTE_ENERGY) then ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "cpml_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) endif ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_CPML_2D_viscoacoust_fourth !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,sispressure,nt,nrec,DELTAT,t0) implicit none integer nt,nrec double precision DELTAT,t0 double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) double precision sispressure(nt,nrec) integer irec,it character(len=100) file_name ! pressure do irec=1,nrec write(file_name,"('pressure_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt ! in the scheme of eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) ! pressure is defined at time t + DELTAT/2, i.e. staggered in time with respect to velocity. ! Here we must thus take this shift of DELTAT/2 into account to save the seismograms at the right time write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec)) enddo close(11) enddo ! X component of velocity do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component of velocity do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX ! in order to be able to use a fourth-order spatial operator on the edges of the model ! here we define the array with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case double precision, dimension(0:NX+1,0:NY+1) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it else if (field_number == 3) then write(file_name,"('image',i6.6,'_pressure.pnm')") it write(system_command,"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')") & it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ! !---- include the SolvOpt() routine that is used to compute the tau_epsilon and tau_sigma values from a given Q attenuation factor ! include "attenuation_model_with_SolvOpt.f90" ================================================ FILE: seismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.3, July 2018. ! ! Copyright CNRS, France. ! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! This software is a computer program whose purpose is to solve ! the two-dimensional heterogeneous isotropic viscoacoustic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_2D_viscoacoust_second ! 2D finite-difference code in velocity and pressure formulation ! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic viscoacoustic medium ! Dimitri Komatitsch, CNRS, Marseille, July 2018. ! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x pressure ! R_dot (viscoacoustic memory variable) ! ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these ! articles: ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! include viscoacoustic attenuation or not logical, parameter :: VISCOACOUSTIC_ATTENUATION = .true. ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! total number of grid points in each direction of the grid integer, parameter :: NX = 2001 integer, parameter :: NY = 2001 ! size of a grid cell double precision, parameter :: DELTAX = 1.5d0 double precision, parameter :: DELTAY = DELTAX ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! P-velocity and density ! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity) double precision, parameter :: cp_unrelaxed = 2000.d0 double precision, parameter :: density = 2000.d0 ! Time step in seconds. ! The CFL stability number for the O(2,2) algorithm is 1 / sqrt(2) = 0.707 ! i.e. one must choose cp * deltat / deltax < 0.707. ! However this only ensures that the scheme is stable. To have a scheme that is both stable and accurate, ! some numerical tests show that one needs to take about half of that, ! i.e. choose deltat so that cp * deltat / deltax is equal to about 0.30 or so. (or any value below; but not above). ! Since the time scheme is only second order, this also depends on how many time steps are performed in total ! (i.e. what the value of NSTEP below is); for large values of NSTEP, of course numerical errors will start to accumulate. double precision, parameter :: DELTAT = 2.2d-4 ! total number of time steps integer, parameter :: NSTEP = 3600 ! parameters for the source double precision, parameter :: f0 = 35.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d0 ! source (in pressure, thus at a gridpoint rather than half a grid cell away) double precision, parameter :: xsource = 1500.d0 double precision, parameter :: ysource = 1500.d0 integer, parameter :: ISOURCE = xsource / DELTAX + 1 integer, parameter :: JSOURCE = ysource / DELTAY + 1 ! receivers integer, parameter :: NREC = 1 !! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters ! to compute energy curves for the whole medium (optional, but useful e.g. to produce ! energy variation figures for articles); but expensive option, thus off by default logical, parameter :: COMPUTE_ENERGY = .false. ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 200 ! compute some constants once and for all for the second-order spatial scheme double precision, parameter :: ONE_OVER_DELTAX = 1.d0 / DELTAX double precision, parameter :: ONE_OVER_DELTAY = 1.d0 / DELTAY ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays double precision, dimension(NX,NY) :: vx,vy,pressure,kappa_unrelaxed,rho ! to interpolate material parameters or velocity at the right location in the staggered grid cell double precision kappa_half_x,rho_half_x_half_y,vy_interpolated ! for evolution of total energy in the medium double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(NX,NY) :: & memory_dvx_dx, & memory_dvx_dy, & memory_dvy_dx, & memory_dvy_dy, & memory_dpressure_dx, & memory_dpressure_dy double precision :: & value_dvx_dx, & value_dvy_dy, & value_dpressure_dx, & value_dpressure_dy ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half, & one_over_K_x,one_over_K_x_half double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half, & one_over_K_y,one_over_K_y_half double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized ! for the source double precision :: a,t,pressure_source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec integer :: myNREC ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sispressure integer :: i,j,it,irec double precision :: Courant_number,velocnorm,pressurenorm ! for attenuation (viscoacousticity) ! attenuation quality factor Qkappa to use double precision, parameter :: QKappa = 65.d0 ! number of Zener standard linear solids in parallel integer, parameter :: N_SLS = 3 ! attenuation constants double precision, dimension(N_SLS) :: tau_epsilon_kappa,tau_sigma_kappa,one_over_tau_sigma_kappa, & HALF_DELTAT_over_tau_sigma_kappa,multiplication_factor_tau_sigma_kappa,DELTAT_delta_relaxed_over_tau_sigma_without_Kappa ! memory variable for attenuation double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_dot,memory_variable_R_dot_old integer :: i_sls double precision :: sum_of_memory_variables_kappa ! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band double precision :: f_min_attenuation,f_max_attenuation !--- !--- program starts here !--- print * print *,'2D viscoacoustic finite-difference code in velocity and pressure formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * ! for attenuation (viscoacousticity) if (VISCOACOUSTIC_ATTENUATION) then print *,'QKappa quality factor used for attenuation = ',QKappa print *,'Number of Zener standard linear solids used to mimic the viscoacoustic behavior (N_SLS) = ',N_SLS print * ! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band ! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0) f_min_attenuation = exp(log(f0)-log(12.d0)/2.d0) f_max_attenuation = 12.d0 * f_min_attenuation ! call the SolvOpt() nonlinear optimization routine to compute the tau_epsilon and tau_sigma values from a given Q factor call compute_attenuation_coeffs(N_SLS,QKappa,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_kappa,tau_sigma_kappa) else ! dummy values in the non-dissipative case tau_epsilon_kappa(:) = 1.d0 tau_sigma_kappa(:) = 1.d0 endif ! precompute the inverse once and for all, to save computation time in the time loop below ! (on computers, a multiplication is very significantly cheaper than a division) one_over_tau_sigma_kappa(:) = 1.d0 / tau_sigma_kappa(:) HALF_DELTAT_over_tau_sigma_kappa(:) = 0.5d0 * DELTAT / tau_sigma_kappa(:) multiplication_factor_tau_sigma_kappa(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_kappa(:)) ! compute DELTAT_delta_relaxed_over_tau_sigma_without_Kappa, which is a term ! needed to compute the evolution of the viscoacoustic memory variables if (VISCOACOUSTIC_ATTENUATION) then DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = (DELTAT / sum(tau_epsilon_kappa(:) / tau_sigma_kappa(:))) * & (tau_epsilon_kappa(:)/tau_sigma_kappa(:) - 1.d0) / tau_sigma_kappa(:) else DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = ZERO endif !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y) print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print * d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! precompute the inverse once and for all, to save computation time in the time loop below ! (on computers, a multiplication is very significantly cheaper than a division) one_over_K_x(:) = 1.d0 / K_x(:) one_over_K_x_half(:) = 1.d0 / K_x_half(:) one_over_K_y(:) = 1.d0 / K_y(:) one_over_K_y_half(:) = 1.d0 / K_y_half(:) ! compute the Lame parameter and density do j = 1,NY do i = 1,NX rho(i,j) = density kappa_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed enddo enddo ! print position of the source print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print *,'There are ',nrec,' receivers' print * if (NREC > 1) then ! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1 myNREC = NREC xspacerec = (xfin-xdeb) / dble(myNREC-1) yspacerec = (yfin-ydeb) / dble(myNREC-1) else xspacerec = 0.d0 yspacerec = 0.d0 endif do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant, K. O. Friedrichs and H. Lewy (1928) ! For this O(2,2) scheme, when DELTAX == DELTAY the Courant number is 1/sqrt(2) = 0.707 if (DELTAX == DELTAY) then Courant_number = cp_unrelaxed * DELTAT / DELTAX print *,'Courant number is ',Courant_number print *,' (the maximum possible value is 1/sqrt(2) = 0.707; & &in practice for accuracy reasons a value not larger than 0.30 is recommended)' print * if (Courant_number > 1.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable' endif ! suppress old files (can be commented out if "call system" is missing in your compiler) call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif') ! initialize arrays vx(:,:) = ZERO vy(:,:) = ZERO pressure(:,:) = ZERO memory_variable_R_dot(:,:,:) = ZERO memory_variable_R_dot_old(:,:,:) = ZERO ! PML memory_dvx_dx(:,:) = ZERO memory_dvx_dy(:,:) = ZERO memory_dvy_dx(:,:) = ZERO memory_dvy_dy(:,:) = ZERO memory_dpressure_dx(:,:) = ZERO memory_dpressure_dy(:,:) = ZERO ! initialize seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO sispressure(:,:) = ZERO ! initialize total energy total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO if (VISCOACOUSTIC_ATTENUATION) then print *,'adding VISCOACOUSTIC_ATTENUATION (i.e., running a viscoacoustic simulation)' else print *,'not adding VISCOACOUSTIC_ATTENUATION (i.e., running a purely acoustic simulation)' endif print * !--- !--- beginning of time loop !--- do it = 1,NSTEP !----------------------------------------------------------------------- ! compute pressure and update memory variables for C-PML ! also update memory variables for viscoacoustic attenuation if needed !----------------------------------------------------------------------- ! we purposely leave this "if" test outside of the loops to make sure the compiler can optimize these loops; ! with an "if" test inside most compilers cannot if (.not. VISCOACOUSTIC_ATTENUATION) then do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j)) value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j) pressure(i,j) = pressure(i,j) - kappa_half_x * (value_dvx_dx + value_dvy_dy) * DELTAT enddo enddo else ! the present becomes the past for the memory variables. ! in C or C++ we could replace this with an exchange of pointers on the arrays ! in order to avoid a memory copy of the whole array. memory_variable_R_dot_old(:,:,:) = memory_variable_R_dot(:,:,:) do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j)) value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j) ! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following ! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here sum_of_memory_variables_kappa = 0.d0 do i_sls = 1,N_SLS ! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) memory_variable_R_dot(i,j,i_sls) = (memory_variable_R_dot_old(i,j,i_sls) + & (value_dvx_dx + value_dvy_dy) * kappa_unrelaxed(i,j) * DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(i_sls) - & memory_variable_R_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_kappa(i_sls)) & * multiplication_factor_tau_sigma_kappa(i_sls) sum_of_memory_variables_kappa = sum_of_memory_variables_kappa + & memory_variable_R_dot(i,j,i_sls) + memory_variable_R_dot_old(i,j,i_sls) enddo pressure(i,j) = pressure(i,j) + (- kappa_half_x * (value_dvx_dx + value_dvy_dy) + & ! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) 0.5d0 * sum_of_memory_variables_kappa) * DELTAT enddo enddo endif ! add the source (pressure located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! pressure_source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a) ! first derivative of a Gaussian pressure_source_term = factor * (t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! pressure_source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) ! to get the right amplitude of the force, we need to divide by the area of a grid cell ! (we checked that against the analytical solution in a homogeneous medium for a pressure source) pressure_source_term = pressure_source_term / (DELTAX * DELTAY) ! define location of the source i = ISOURCE j = JSOURCE ! the pressure source is added to d(pressure)/dt in this split pressure / velocity scheme ! and that is why we need to select the first derivative of a Gaussian as a source time wavelet ! above instead of a Ricker (i.e. a second derivative) added to d2(pressure)/dt2 ! as in the unsplit equation written in pressure only. ! Since the formula is d(pressure)/dt = (pressure_new - pressure_old) / DELTAT = pressure_source_term ! we also need to multiply by DELTAT here to avoid having an amplitude of the seismogram ! that varies when one changes the time step, i.e. we write: ! pressure_new = pressure_old + pressure_source_term * DELTAT at the source grid point pressure(i,j) = pressure(i,j) + pressure_source_term * DELTAT !-------------------------------------------------------- ! compute velocity and update memory variables for C-PML !-------------------------------------------------------- do j = 2,NY do i = 2,NX value_dpressure_dx = (pressure(i,j) - pressure(i-1,j)) * ONE_OVER_DELTAX memory_dpressure_dx(i,j) = b_x(i) * memory_dpressure_dx(i,j) + a_x(i) * value_dpressure_dx value_dpressure_dx = value_dpressure_dx * one_over_K_x(i) + memory_dpressure_dx(i,j) vx(i,j) = vx(i,j) - value_dpressure_dx * DELTAT / rho(i,j) enddo enddo do j = 1,NY-1 do i = 1,NX-1 ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) value_dpressure_dy = (pressure(i,j+1) - pressure(i,j)) * ONE_OVER_DELTAY memory_dpressure_dy(i,j) = b_y_half(j) * memory_dpressure_dy(i,j) + a_y_half(j) * value_dpressure_dy value_dpressure_dy = value_dpressure_dy * one_over_K_y_half(j) + memory_dpressure_dy(i,j) vy(i,j) = vy(i,j) - value_dpressure_dy * DELTAT / rho_half_x_half_y enddo enddo ! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers vx(1,:) = ZERO vx(NX,:) = ZERO vx(:,1) = ZERO vx(:,NY) = ZERO vy(1,:) = ZERO vy(NX,:) = ZERO vy(:,1) = ZERO vy(:,NY) = ZERO ! store seismograms do irec = 1,NREC ! beware here that the two components of the velocity vector are not defined at the same point ! in a staggered grid, and thus the two components of the velocity vector are recorded at slightly different locations, ! vy is staggered by half a grid cell along X and along Y with respect to vx sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec)) sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec)) sispressure(it,irec) = pressure(ix_rec(irec),iy_rec(irec)) enddo ! compute total energy in the medium (without the PML layers) if (COMPUTE_ENERGY) then ! compute kinetic energy first, defined as 1/2 rho ||v||^2 total_energy_kinetic(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! interpolate vy back at the location of vx, to be able to use both at the same location vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1)) total_energy_kinetic(it) = total_energy_kinetic(it) + 0.5d0 * rho(i,j) * (vx(i,j)**2 + vy_interpolated**2) enddo enddo ! add potential energy, defined as 1/2 pressure^2 / Kappa total_energy_potential(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! interpolate material parameters at the right location in the staggered grid cell kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j)) total_energy_potential(it) = total_energy_potential(it) + 0.5d0 * pressure(i,j)**2 / kappa_half_x enddo enddo endif ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! print maximum of pressure and of norm of velocity pressurenorm = maxval(abs(pressure)) velocnorm = maxval(sqrt(vx**2 + vy**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max absolute value of pressure = ',pressurenorm print *,'Max norm velocity vector V (m/s) = ',velocnorm if (COMPUTE_ENERGY) print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) print * ! check stability of the code, exit if unstable if (pressurenorm > STABILITY_THRESHOLD .or. velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' ! call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & ! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1) ! call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & ! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2) call create_color_image(pressure,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,3) ! save the part of the seismograms that has been computed so far, so that users can monitor the progress of the simulation call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0) if (COMPUTE_ENERGY) then ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "cpml_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) endif ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_CPML_2D_viscoacoust_second !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,sispressure,nt,nrec,DELTAT,t0) implicit none integer nt,nrec double precision DELTAT,t0 double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) double precision sispressure(nt,nrec) integer irec,it character(len=100) file_name ! pressure do irec=1,nrec write(file_name,"('pressure_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt ! in the scheme of eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) ! pressure is defined at time t + DELTAT/2, i.e. staggered in time with respect to velocity. ! Here we must thus take this shift of DELTAT/2 into account to save the seismograms at the right time write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec)) enddo close(11) enddo ! X component of velocity do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component of velocity do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it else if (field_number == 3) then write(file_name,"('image',i6.6,'_pressure.pnm')") it write(system_command,"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')") & it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ! !---- include the SolvOpt() routine that is used to compute the tau_epsilon and tau_sigma values from a given Q attenuation factor ! include "attenuation_model_with_SolvOpt.f90" ================================================ FILE: seismic_CPML_2D_pressure_second_order.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.3, July 2018. ! ! Copyright CNRS, France. ! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! This software is a computer program whose purpose is to solve ! the two-dimensional heterogeneous isotropic acoustic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_2D_pressure ! 2D acoustic finite-difference code in pressure formulation ! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic acoustic medium ! Dimitri Komatitsch, CNRS, Marseille, July 2018. ! The pressure wave equation in an inviscid heterogeneous fluid is: ! ! 1/Kappa d2p / dt2 = div(grad(p) / rho) = d(1/rho dp/dx)/dx + d(1/rho dp/dy)/dy ! ! (see for instance Komatitsch and Tromp, Geophysical Journal International, vol. 149, p. 390-412 (2002), equations (19) and (21)) ! ! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | | ! dp/dy +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! p dp/dx ! ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these ! articles: ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! total number of grid points in each direction of the grid integer, parameter :: NX = 2001 integer, parameter :: NY = 2001 ! size of a grid cell double precision, parameter :: DELTAX = 1.5d0 double precision, parameter :: DELTAY = DELTAX ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! P-velocity and density ! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity) double precision, parameter :: cp_unrelaxed = 2000.d0 double precision, parameter :: density = 2000.d0 ! total number of time steps integer, parameter :: NSTEP = 1500 ! time step in seconds double precision, parameter :: DELTAT = 5.2d-4 ! parameters for the source double precision, parameter :: f0 = 35.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d0 ! source (in pressure) double precision, parameter :: xsource = 1500.d0 double precision, parameter :: ysource = 1500.d0 integer, parameter :: ISOURCE = xsource / DELTAX + 1 integer, parameter :: JSOURCE = ysource / DELTAY + 1 ! receivers integer, parameter :: NREC = 1 !! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 100 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays double precision, dimension(NX,NY) :: pressure_past,pressure_present,pressure_future, & pressure_xx,pressure_yy,dpressurexx_dx,dpressureyy_dy,kappa_unrelaxed,rho,Kronecker_source ! to interpolate material parameters or velocity at the right location in the staggered grid cell double precision :: rho_half_x,rho_half_y ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(NX,NY) :: & memory_dpressure_dx, & memory_dpressure_dy, & memory_dpressurexx_dx, & memory_dpressureyy_dy double precision :: & value_dpressure_dx, & value_dpressure_dy, & value_dpressurexx_dx, & value_dpressureyy_dy ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized ! for the source double precision :: a,t,source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec integer :: myNREC ! for seismograms double precision, dimension(NSTEP,NREC) :: sispressure integer :: i,j,it,irec double precision :: Courant_number,pressurenorm !--- !--- program starts here !--- print * print *,'2D acoustic finite-difference code in pressure formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y) print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print * d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! compute the Lame parameter and density do j = 1,NY do i = 1,NX rho(i,j) = density kappa_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed enddo enddo ! print position of the source print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of the source Kronecker_source(:,:) = 0.d0 Kronecker_source(ISOURCE,JSOURCE) = 1.d0 ! define location of receivers print *,'There are ',nrec,' receivers' print * if (NREC > 1) then ! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1 myNREC = NREC xspacerec = (xfin-xdeb) / dble(myNREC-1) yspacerec = (yfin-ydeb) / dble(myNREC-1) else xspacerec = 0.d0 yspacerec = 0.d0 endif do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number = cp_unrelaxed * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2) print *,'Courant number is ',Courant_number print * if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable' ! suppress old files (can be commented out if "call system" is missing in your compiler) call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif') ! initialize arrays pressure_present(:,:) = ZERO pressure_past(:,:) = ZERO ! PML memory_dpressure_dx(:,:) = ZERO memory_dpressure_dy(:,:) = ZERO memory_dpressurexx_dx(:,:) = ZERO memory_dpressureyy_dy(:,:) = ZERO ! initialize seismograms sispressure(:,:) = ZERO !--- !--- beginning of time loop !--- do it = 1,NSTEP ! compute the first spatial derivatives divided by density do j = 1,NY do i = 1,NX-1 value_dpressure_dx = (pressure_present(i+1,j) - pressure_present(i,j)) / DELTAX memory_dpressure_dx(i,j) = b_x_half(i) * memory_dpressure_dx(i,j) + a_x_half(i) * value_dpressure_dx value_dpressure_dx = value_dpressure_dx / K_x_half(i) + memory_dpressure_dx(i,j) rho_half_x = 0.5d0 * (rho(i+1,j) + rho(i,j)) pressure_xx(i,j) = value_dpressure_dx / rho_half_x enddo enddo do j = 1,NY-1 do i = 1,NX value_dpressure_dy = (pressure_present(i,j+1) - pressure_present(i,j)) / DELTAY memory_dpressure_dy(i,j) = b_y_half(j) * memory_dpressure_dy(i,j) + a_y_half(j) * value_dpressure_dy value_dpressure_dy = value_dpressure_dy / K_y_half(j) + memory_dpressure_dy(i,j) rho_half_y = 0.5d0 * (rho(i,j+1) + rho(i,j)) pressure_yy(i,j) = value_dpressure_dy / rho_half_y enddo enddo ! compute the second spatial derivatives do j = 1,NY do i = 2,NX value_dpressurexx_dx = (pressure_xx(i,j) - pressure_xx(i-1,j)) / DELTAX memory_dpressurexx_dx(i,j) = b_x(i) * memory_dpressurexx_dx(i,j) + a_x(i) * value_dpressurexx_dx value_dpressurexx_dx = value_dpressurexx_dx / K_x(i) + memory_dpressurexx_dx(i,j) dpressurexx_dx(i,j) = value_dpressurexx_dx enddo enddo do j = 2,NY do i = 1,NX value_dpressureyy_dy = (pressure_yy(i,j) - pressure_yy(i,j-1)) / DELTAY memory_dpressureyy_dy(i,j) = b_y(j) * memory_dpressureyy_dy(i,j) + a_y(j) * value_dpressureyy_dy value_dpressureyy_dy = value_dpressureyy_dy / K_y(j) + memory_dpressureyy_dy(i,j) dpressureyy_dy(i,j) = value_dpressureyy_dy enddo enddo ! add the source (pressure located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a) ! first derivative of a Gaussian ! source_term = factor * (t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) ! apply the time evolution scheme ! we apply it everywhere, including at some points on the edges of the domain that have not be calculated above, ! which is of course wrong (or more precisely undefined), but this does not matter because these values ! will be erased by the Dirichlet conditions set on these edges below pressure_future(:,:) = - pressure_past(:,:) + 2.d0 * pressure_present(:,:) + & DELTAT*DELTAT * ((dpressurexx_dx(:,:) + dpressureyy_dy(:,:)) * kappa_unrelaxed(:,:) + & 4.d0 * PI * cp_unrelaxed**2 * source_term * Kronecker_source(:,:)) ! apply Dirichlet conditions at the bottom of the C-PML layers, ! which is the right condition to implement in order for C-PML to remain stable at long times ! Dirichlet condition for pressure on the left boundary pressure_future(1,:) = ZERO ! Dirichlet condition for pressure on the right boundary pressure_future(NX,:) = ZERO ! Dirichlet condition for pressure on the bottom boundary pressure_future(:,1) = ZERO ! Dirichlet condition for pressure on the top boundary pressure_future(:,NY) = ZERO ! store seismograms do irec = 1,NREC sispressure(it,irec) = pressure_future(ix_rec(irec),iy_rec(irec)) enddo ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! print maximum of pressure and of norm of velocity pressurenorm = maxval(abs(pressure_future)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max absolute value of pressure = ',pressurenorm print * ! check stability of the code, exit if unstable if (pressurenorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' call create_color_image(pressure_future,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,3) endif ! move new values to old values (the present becomes the past, the future becomes the present) pressure_past(:,:) = pressure_present(:,:) pressure_present(:,:) = pressure_future(:,:) enddo ! end of the time loop ! save seismograms call write_seismograms(sispressure,NSTEP,NREC,DELTAT,t0) print * print *,'End of the simulation' print * end program seismic_CPML_2D_pressure !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sispressure,nt,nrec,DELTAT,t0) implicit none integer nt,nrec double precision DELTAT,t0 double precision sispressure(nt,nrec) integer irec,it character(len=100) file_name ! pressure do irec=1,nrec write(file_name,"('pressure_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt ! write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sispressure(it,irec)) write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec)) ! write(11,*) sngl(dble(it-1)*DELTAT - DELTAT - t0),' ',sngl(sispressure(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it else if (field_number == 3) then write(file_name,"('image',i6.6,'_pressure.pnm')") it write(system_command,"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')") & it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.3, July 2018. ! ! Copyright CNRS, France. ! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! This software is a computer program whose purpose is to solve ! the two-dimensional heterogeneous isotropic viscoelastic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_2D_viscoelast_fourth ! 2D finite-difference code in velocity and stress formulation ! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic viscoelastic medium ! Dimitri Komatitsch, CNRS, Marseille, July 2018. ! A fourth-order spatially-staggered grid formulation is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! e13 | | | ! (memory | | | ! variable) | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! e1 (viscoelastic memory variable) ! e11 (viscoelastic memory variable) ! ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these ! articles: ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! include viscoelastic attenuation or not logical, parameter :: VISCOELASTIC_ATTENUATION = .true. ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! total number of grid points in each direction of the grid integer, parameter :: NX = 2001 integer, parameter :: NY = 2001 ! size of a grid cell double precision, parameter :: DELTAX = 1.5d0 double precision, parameter :: DELTAY = DELTAX ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! P-velocity and density ! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity) double precision, parameter :: cp_unrelaxed = 2000.d0 double precision, parameter :: cs_unrelaxed = cp_unrelaxed / 1.732d0 double precision, parameter :: density = 2000.d0 ! Time step in seconds. ! The CFL stability number for the O(2,2) algorithm is 1 / sqrt(2) = 0.707 ! i.e. one must choose cp * deltat / deltax < 0.707. ! For the O(2,4) algorithm used here it is a bit more restrictive, ! it is cp * deltat / deltax < 0.606 (see Levander 1988 eq (7)). ! However this only ensures that the scheme is stable. To have a scheme that is both stable and accurate, ! for O(2,4) some numerical tests show that one needs to take about half of that, ! i.e. choose deltat so that cp * deltat / deltax is equal to about 0.30 or so. (or any value below; but not above). ! Since the time scheme is only second order, this also depends on how many time steps are performed in total ! (i.e. what the value of NSTEP below is); for large values of NSTEP, of course numerical errors will start to accumulate. double precision, parameter :: DELTAT = 2.2d-4 ! total number of time steps integer, parameter :: NSTEP = 5200 ! parameters for the source double precision, parameter :: f0 = 35.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d0 ! source (force) double precision, parameter :: xsource = 1500.d0 double precision, parameter :: ysource = 1500.d0 integer, parameter :: ISOURCE = xsource / DELTAX + 1 integer, parameter :: JSOURCE = ysource / DELTAY + 1 ! angle of source force in degrees and clockwise, with respect to the vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 0.d0 ! receivers integer, parameter :: NREC = 1 !! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters ! to compute energy curves for the whole medium (optional, but useful e.g. to produce ! energy variation figures for articles); but expensive option, thus off by default logical, parameter :: COMPUTE_ENERGY = .false. ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 200 ! compute some constants once and for all for the fourth-order spatial scheme ! These coefficients are given for instance by Levander, Geophysics, vol. 53(11), p. 1436, equation (A-2) double precision, parameter :: NINE_OVER_8_DELTAX = 9.d0 / (8.d0*DELTAX) double precision, parameter :: NINE_OVER_8_DELTAY = 9.d0 / (8.d0*DELTAY) double precision, parameter :: ONE_OVER_24_DELTAX = 1.d0 / (24.d0*DELTAX) double precision, parameter :: ONE_OVER_24_DELTAY = 1.d0 / (24.d0*DELTAY) ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 double precision, parameter :: TWO_THIRDS = 2.d0 / 3.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays ! in order to be able to use a fourth-order spatial operator on the edges of the model ! here we define the arrays with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case double precision, dimension(0:NX+1,0:NY+1) :: vx,vy,sigma_xx,sigma_yy,sigma_xy,lambda_unrelaxed,mu_unrelaxed,rho ! to interpolate material parameters or velocity at the right location in the staggered grid cell double precision :: lambda_half_x,mu_half_x,lambda_plus_mu_half_x,lambda_plus_two_mu_half_x,mu_half_y double precision :: rho_half_x_half_y,vy_interpolated ! for evolution of total energy in the medium double precision :: epsilon_xx,epsilon_yy,epsilon_xy double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(NX,NY) :: & memory_dvx_dx, & memory_dvx_dy, & memory_dvy_dx, & memory_dvy_dy, & memory_dsigma_xx_dx, & memory_dsigma_yy_dy, & memory_dsigma_xy_dx, & memory_dsigma_xy_dy double precision :: & value_dvx_dx, & value_dvx_dy, & value_dvy_dx, & value_dvy_dy, & value_dsigma_xx_dx, & value_dsigma_yy_dy, & value_dsigma_xy_dx, & value_dsigma_xy_dy ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half, & one_over_K_x,one_over_K_x_half double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half, & one_over_K_y,one_over_K_y_half double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized ! for the source double precision :: a,t,force_x,force_y,force_source_term ! for receivers ! Please note something important: the two components of the velocity vector are not defined at the same location, ! Vy is half a grid cell away from Vx (see ASCII figure at the beginning of this program). ! Thus this means there are "two receivers" rather than one, one recording Vx and another one, half a grid cell away, recording Vy. ! If you need to use both components in real applications (and of course we will), ! you will need to interpolate Vy to the location of Vx using: ! ! interpolate vy back at the location of vx, to be able to use both at the same location ! vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1)) ! double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec integer :: myNREC ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sispressure integer :: i,j,it,irec double precision :: Courant_number,velocnorm ! for attenuation (viscoelasticity) ! attenuation quality factors Qp and Qs to use ! BEWARE: we use Qp and Qs here, not QKappa and Qmu. ! BEWARE: While Qmu is always equal to Qs, QKappa is not equal to Qp, ! BEWARE: to convert from one to the other if your input data have Qkappa and Qmu you can use ! BEWARE: the program conversion_between_Qp_Qs_and_Qkappa_Qmu_from_Dahlen_Tromp_959_960_in_3D_and_in_2D_plane_strain.f90 ! BEWARE: that is included in this software package. double precision, parameter :: Qp = 65.d0 double precision, parameter :: Qs = 55.d0 ! number of Zener standard linear solids in parallel integer, parameter :: N_SLS = 3 ! attenuation constants double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,one_over_tau_sigma_nu1, & HALF_DELTAT_over_tau_sigma_nu1,multiplication_factor_tau_sigma_nu1,DELTAT_phi_nu1 double precision, dimension(N_SLS) :: tau_epsilon_nu2,tau_sigma_nu2,one_over_tau_sigma_nu2, & HALF_DELTAT_over_tau_sigma_nu2,multiplication_factor_tau_sigma_nu2,DELTAT_phi_nu2 ! memory variable and other arrays for attenuation double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e1_dot,memory_variable_R_e1_dot_old double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e11_dot,memory_variable_R_e11_dot_old double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e13_dot,memory_variable_R_e13_dot_old integer :: i_sls double precision :: sum_of_memory_variables_e1,sum_of_memory_variables_e11,sum_of_memory_variables_e13 ! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band double precision :: f_min_attenuation,f_max_attenuation !--- !--- program starts here !--- print * print *,'2D viscoelastic finite-difference code in velocity and stress formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * ! for attenuation (viscoelasticity) if (VISCOELASTIC_ATTENUATION) then print *,'Qp quality factor used for attenuation = ',Qp print *,'Qs quality factor used for attenuation = ',Qs print *,'Number of Zener standard linear solids used to mimic the viscoelastic behavior (N_SLS) = ',N_SLS print * ! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band ! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0) f_min_attenuation = exp(log(f0)-log(12.d0)/2.d0) f_max_attenuation = 12.d0 * f_min_attenuation ! call the SolvOpt() nonlinear optimization routine to compute the tau_epsilon and tau_sigma values from a given Q factor print *,'Values for Qp:' print * call compute_attenuation_coeffs(N_SLS,Qp,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu1,tau_sigma_nu1) print *,'Values for Qs:' print * call compute_attenuation_coeffs(N_SLS,Qs,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu2,tau_sigma_nu2) else ! dummy values in the non-dissipative case tau_epsilon_nu1(:) = 1.d0 tau_sigma_nu1(:) = 1.d0 tau_epsilon_nu2(:) = 1.d0 tau_sigma_nu2(:) = 1.d0 endif ! precompute the inverse once and for all, to save computation time in the time loop below ! (on computers, a multiplication is very significantly cheaper than a division) one_over_tau_sigma_nu1(:) = 1.d0 / tau_sigma_nu1(:) one_over_tau_sigma_nu2(:) = 1.d0 / tau_sigma_nu2(:) HALF_DELTAT_over_tau_sigma_nu1(:) = 0.5d0 * DELTAT / tau_sigma_nu1(:) HALF_DELTAT_over_tau_sigma_nu2(:) = 0.5d0 * DELTAT / tau_sigma_nu2(:) multiplication_factor_tau_sigma_nu1(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu1(:)) multiplication_factor_tau_sigma_nu2(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu2(:)) ! use the right formula with 1/N included DELTAT_phi_nu1(:) = DELTAT * (1.d0 - tau_epsilon_nu1(:)/tau_sigma_nu1(:)) / tau_sigma_nu1(:) / sum(tau_epsilon_nu1/tau_sigma_nu1) DELTAT_phi_nu2(:) = DELTAT * (1.d0 - tau_epsilon_nu2(:)/tau_sigma_nu2(:)) / tau_sigma_nu2(:) / sum(tau_epsilon_nu2/tau_sigma_nu2) !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y) print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print * d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! precompute the inverse once and for all, to save computation time in the time loop below ! (on computers, a multiplication is very significantly cheaper than a division) one_over_K_x(:) = 1.d0 / K_x(:) one_over_K_x_half(:) = 1.d0 / K_x_half(:) one_over_K_y(:) = 1.d0 / K_y(:) one_over_K_y_half(:) = 1.d0 / K_y_half(:) ! compute the Lame parameter and density do j = 1,NY do i = 1,NX rho(i,j) = density mu_unrelaxed(i,j) = density*cs_unrelaxed*cs_unrelaxed lambda_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed - 2.d0*mu_unrelaxed(i,j) enddo enddo ! print position of the source print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print *,'There are ',nrec,' receivers' print * if (NREC > 1) then ! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1 myNREC = NREC xspacerec = (xfin-xdeb) / dble(myNREC-1) yspacerec = (yfin-ydeb) / dble(myNREC-1) else xspacerec = 0.d0 yspacerec = 0.d0 endif do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant, K. O. Friedrichs and H. Lewy (1928) ! For this O(2,4) scheme, when DELTAX == DELTAY the Courant number is given by Levander, Geophysics, vol. 53(11), p. 1427, ! equation (7) and is equal to 0.606 (it is thus smaller than that of the O(2,2) scheme, which is 1/sqrt(2) = 0.707, ! i.e. when switching to a fourth-order spatial scheme one needs a time step that is about 0.707 / 0.606 = 1.167 times smaller. if (DELTAX == DELTAY) then Courant_number = cp_unrelaxed * DELTAT / DELTAX print *,'Courant number is ',Courant_number print *,' (the maximum possible value is 0.606; in practice for accuracy reasons a value not larger than 0.30 is recommended)' print * if (Courant_number > 0.606) stop 'time step is too large, simulation will be unstable' endif ! suppress old files (can be commented out if "call system" is missing in your compiler) call system('rm -f Vx_file*.dat Vy_file*.dat image*.pnm image*.gif') ! initialize arrays vx(:,:) = ZERO vy(:,:) = ZERO sigma_xx(:,:) = ZERO sigma_yy(:,:) = ZERO sigma_xy(:,:) = ZERO memory_variable_R_e1_dot(:,:,:) = ZERO memory_variable_R_e1_dot_old(:,:,:) = ZERO memory_variable_R_e11_dot(:,:,:) = ZERO memory_variable_R_e11_dot_old(:,:,:) = ZERO memory_variable_R_e13_dot(:,:,:) = ZERO memory_variable_R_e13_dot_old(:,:,:) = ZERO ! PML memory_dvx_dx(:,:) = ZERO memory_dvx_dy(:,:) = ZERO memory_dvy_dx(:,:) = ZERO memory_dvy_dy(:,:) = ZERO memory_dsigma_xx_dx(:,:) = ZERO memory_dsigma_yy_dy(:,:) = ZERO memory_dsigma_xy_dx(:,:) = ZERO memory_dsigma_xy_dy(:,:) = ZERO ! initialize seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO sispressure(:,:) = ZERO ! initialize total energy total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO if (VISCOELASTIC_ATTENUATION) then print *,'adding VISCOELASTIC_ATTENUATION (i.e., running a viscoelastic simulation)' else print *,'not adding VISCOELASTIC_ATTENUATION (i.e., running a purely elastic simulation)' endif print * !--- !--- beginning of time loop !--- do it = 1,NSTEP !----------------------------------------------------------------------- ! compute the stress tensor and update memory variables for C-PML ! also update memory variables for viscoelastic attenuation if needed !----------------------------------------------------------------------- ! we purposely leave this "if" test outside of the loops to make sure the compiler can optimize these loops; ! with an "if" test inside most compilers cannot if (.not. VISCOELASTIC_ATTENUATION) then do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j)) mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j)) lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x value_dvx_dx = (vx(i+1,j) - vx(i,j)) * NINE_OVER_8_DELTAX + (vx(i-1,j) - vx(i+2,j)) * ONE_OVER_24_DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) * NINE_OVER_8_DELTAY + (vy(i,j-2) - vy(i,j+1)) * ONE_OVER_24_DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j) sigma_xx(i,j) = sigma_xx(i,j) + (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) * DELTAT sigma_yy(i,j) = sigma_yy(i,j) + (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) * DELTAT enddo enddo do j = 1,NY-1 do i = 2,NX ! interpolate material parameters at the right location in the staggered grid cell mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j)) value_dvy_dx = (vy(i,j) - vy(i-1,j)) * NINE_OVER_8_DELTAX + (vy(i-2,j) - vy(i+1,j)) * ONE_OVER_24_DELTAX value_dvx_dy = (vx(i,j+1) - vx(i,j)) * NINE_OVER_8_DELTAY + (vx(i,j-1) - vx(i,j+2)) * ONE_OVER_24_DELTAY memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j) value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j) sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy) * DELTAT enddo enddo else ! the present becomes the past for the memory variables. ! in C or C++ we could replace this with an exchange of pointers on the arrays ! in order to avoid a memory copy of the whole array. memory_variable_R_e1_dot_old(:,:,:) = memory_variable_R_e1_dot(:,:,:) memory_variable_R_e11_dot_old(:,:,:) = memory_variable_R_e11_dot(:,:,:) memory_variable_R_e13_dot_old(:,:,:) = memory_variable_R_e13_dot(:,:,:) do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j)) mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j)) lambda_plus_mu_half_x = lambda_half_x + mu_half_x lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x value_dvx_dx = (vx(i+1,j) - vx(i,j)) * NINE_OVER_8_DELTAX + (vx(i-1,j) - vx(i+2,j)) * ONE_OVER_24_DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) * NINE_OVER_8_DELTAY + (vy(i,j-2) - vy(i,j+1)) * ONE_OVER_24_DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j) ! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following ! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here sum_of_memory_variables_e1 = 0.d0 sum_of_memory_variables_e11 = 0.d0 do i_sls = 1,N_SLS ! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) memory_variable_R_e1_dot(i,j,i_sls) = (memory_variable_R_e1_dot_old(i,j,i_sls) + & (value_dvx_dx + value_dvy_dy) * DELTAT_phi_nu1(i_sls) - & memory_variable_R_e1_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu1(i_sls)) & * multiplication_factor_tau_sigma_nu1(i_sls) memory_variable_R_e11_dot(i,j,i_sls) = (memory_variable_R_e11_dot_old(i,j,i_sls) + & 0.5d0 * (value_dvx_dx - value_dvy_dy) * DELTAT_phi_nu2(i_sls) - & memory_variable_R_e11_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) & * multiplication_factor_tau_sigma_nu2(i_sls) sum_of_memory_variables_e1 = sum_of_memory_variables_e1 + & memory_variable_R_e1_dot(i,j,i_sls) + memory_variable_R_e1_dot_old(i,j,i_sls) sum_of_memory_variables_e11 = sum_of_memory_variables_e11 + & memory_variable_R_e11_dot(i,j,i_sls) + memory_variable_R_e11_dot_old(i,j,i_sls) enddo sigma_xx(i,j) = sigma_xx(i,j) + & (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy & ! use the right formula with 1/N included ! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189)) ! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) + (0.5d0 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 + mu_half_x * sum_of_memory_variables_e11)) * DELTAT sigma_yy(i,j) = sigma_yy(i,j) + & (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy & ! use the right formula with 1/N included ! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189)) ! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) + (0.5d0 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 - mu_half_x * sum_of_memory_variables_e11)) * DELTAT enddo enddo do j = 1,NY-1 do i = 2,NX ! interpolate material parameters at the right location in the staggered grid cell mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j)) value_dvy_dx = (vy(i,j) - vy(i-1,j)) * NINE_OVER_8_DELTAX + (vy(i-2,j) - vy(i+1,j)) * ONE_OVER_24_DELTAX value_dvx_dy = (vx(i,j+1) - vx(i,j)) * NINE_OVER_8_DELTAY + (vx(i,j-1) - vx(i,j+2)) * ONE_OVER_24_DELTAY memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j) value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j) ! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following ! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here sum_of_memory_variables_e13 = 0.d0 do i_sls = 1,N_SLS ! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) memory_variable_R_e13_dot(i,j,i_sls) = (memory_variable_R_e13_dot_old(i,j,i_sls) + & (value_dvy_dx + value_dvx_dy) * DELTAT_phi_nu2(i_sls) - & memory_variable_R_e13_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) & * multiplication_factor_tau_sigma_nu2(i_sls) sum_of_memory_variables_e13 = sum_of_memory_variables_e13 + & memory_variable_R_e13_dot(i,j,i_sls) + memory_variable_R_e13_dot_old(i,j,i_sls) enddo sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy & ! use the right formula with 1/N included ! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189)) ! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) + 0.5d0 * sum_of_memory_variables_e13) * DELTAT enddo enddo endif !-------------------------------------------------------- ! compute velocity and update memory variables for C-PML !-------------------------------------------------------- do j = 2,NY do i = 2,NX value_dsigma_xx_dx = (sigma_xx(i,j) - sigma_xx(i-1,j)) * NINE_OVER_8_DELTAX + & (sigma_xx(i-2,j) - sigma_xx(i+1,j)) * ONE_OVER_24_DELTAX value_dsigma_xy_dy = (sigma_xy(i,j) - sigma_xy(i,j-1)) * NINE_OVER_8_DELTAY + & (sigma_xy(i,j-2) - sigma_xy(i,j+1)) * ONE_OVER_24_DELTAY memory_dsigma_xx_dx(i,j) = b_x(i) * memory_dsigma_xx_dx(i,j) + a_x(i) * value_dsigma_xx_dx memory_dsigma_xy_dy(i,j) = b_y(j) * memory_dsigma_xy_dy(i,j) + a_y(j) * value_dsigma_xy_dy value_dsigma_xx_dx = value_dsigma_xx_dx / K_x(i) + memory_dsigma_xx_dx(i,j) value_dsigma_xy_dy = value_dsigma_xy_dy / K_y(j) + memory_dsigma_xy_dy(i,j) vx(i,j) = vx(i,j) + (value_dsigma_xx_dx + value_dsigma_xy_dy) * DELTAT / rho(i,j) enddo enddo do j = 1,NY-1 do i = 1,NX-1 ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) value_dsigma_xy_dx = (sigma_xy(i+1,j) - sigma_xy(i,j)) * NINE_OVER_8_DELTAX + & (sigma_xy(i-1,j) - sigma_xy(i+2,j)) * ONE_OVER_24_DELTAX value_dsigma_yy_dy = (sigma_yy(i,j+1) - sigma_yy(i,j)) * NINE_OVER_8_DELTAY + & (sigma_yy(i,j-1) - sigma_yy(i,j+2)) * ONE_OVER_24_DELTAY memory_dsigma_xy_dx(i,j) = b_x_half(i) * memory_dsigma_xy_dx(i,j) + a_x_half(i) * value_dsigma_xy_dx memory_dsigma_yy_dy(i,j) = b_y_half(j) * memory_dsigma_yy_dy(i,j) + a_y_half(j) * value_dsigma_yy_dy value_dsigma_xy_dx = value_dsigma_xy_dx / K_x_half(i) + memory_dsigma_xy_dx(i,j) value_dsigma_yy_dy = value_dsigma_yy_dy / K_y_half(j) + memory_dsigma_yy_dy(i,j) vy(i,j) = vy(i,j) + (value_dsigma_xy_dx + value_dsigma_yy_dy) * DELTAT / rho_half_x_half_y enddo enddo ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! force_source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a) ! first derivative of a Gaussian ! force_source_term = factor * (t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) force_source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) ! to get the right amplitude of the force, we need to divide by the area of a grid cell ! (we checked that against the analytical solution in a homogeneous medium for a force source) force_source_term = force_source_term / (DELTAX * DELTAY) ! define location of the source i = ISOURCE j = JSOURCE force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) ! we want seismograms to be representing velocity, for the case of the seismic wave equation ! representing displacement for a Ricker (i.e., second derivative of a Gaussian) source in displacement. ! Since the force source is added to d(velocity)/dt in this split velocity and stress scheme ! we need to select the second derivative of a Gaussian as a source time wavelet ! by analogy with a Ricker (i.e. a second derivative) added to d2(displacement)/dt2 ! as in the unsplit equation written in displacement only. ! Since the formula is d(velocity)/dt = (velocity_new - velocity_old) / DELTAT = force_source_term ! we also need to multiply by DELTAT here to avoid having an amplitude of the seismogram ! that varies when one changes the time step, i.e. we write: ! velocity_new = velocity_old + force_source_term * DELTAT at the source grid point vx(i,j) = vx(i,j) + force_x * DELTAT / rho(i,j) vy(i,j) = vy(i,j) + force_y * DELTAT / rho_half_x_half_y ! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers vx(1,:) = ZERO vx(NX,:) = ZERO vx(:,1) = ZERO vx(:,NY) = ZERO vy(1,:) = ZERO vy(NX,:) = ZERO vy(:,1) = ZERO vy(:,NY) = ZERO ! store seismograms do irec = 1,NREC ! beware here that the two components of the velocity vector are not defined at the same point ! in a staggered grid, and thus the two components of the velocity vector are recorded at slightly different locations, ! vy is staggered by half a grid cell along X and along Y with respect to vx sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec)) sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec)) ! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction, ! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5): ! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as ! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor. ! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3 ! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij ! = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij ! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx ! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy ! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz ! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon) ! ! to compute pressure in 2D in an elastic solid in the plane strain convention i.e. in the P-SV case, ! one still uses pressure = - trace(sigma) / 3 but taking into account the fact ! that the off-plane strain epsilon_zz is zero by definition of the plane strain convention ! but thus the off-plane stress sigma_zz is not equal to zero, ! one has instead: sigma_zz = lambda * (epsilon_xx + epsilon_yy), thus ! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij ! = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij ! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx ! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy ! sigma_zz = lambda * (epsilon_xx + epsilon_yy) ! pressure = - trace(sigma) / 3 = - (lambda + 2*mu/3) (epsilon_xx + epsilon_yy) i = ix_rec(irec) j = iy_rec(irec) ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j)) mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j)) epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * & sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x)) epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * & sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x)) sispressure(it,irec) = - (lambda_half_x + TWO_THIRDS*mu_half_x) * (epsilon_xx + epsilon_yy) enddo ! compute total energy in the medium (without the PML layers) if (COMPUTE_ENERGY) then ! compute kinetic energy first, defined as 1/2 rho ||v||^2 total_energy_kinetic(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! interpolate vy back at the location of vx, to be able to use both at the same location vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1)) total_energy_kinetic(it) = total_energy_kinetic(it) + 0.5d0 * rho(i,j) * (vx(i,j)**2 + vy_interpolated**2) enddo enddo ! add potential energy, defined as 1/2 epsilon_ij sigma_ij total_energy_potential(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j)) mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j)) mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j)) epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * & sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x)) epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * & sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x)) epsilon_xy = sigma_xy(i,j) / (2.d0 * mu_half_y) total_energy_potential(it) = total_energy_potential(it) + & 0.5d0 * (epsilon_xx * sigma_xx(i,j) + epsilon_yy * sigma_yy(i,j) + 2.d0 * epsilon_xy * sigma_xy(i,j)) enddo enddo endif ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! print maximum of norm of velocity velocnorm = maxval(sqrt(vx**2 + vy**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',velocnorm if (COMPUTE_ENERGY) print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) print * ! check stability of the code, exit if unstable if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1) call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2) ! save the part of the seismograms that has been computed so far, so that users can monitor the progress of the simulation call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0) if (COMPUTE_ENERGY) then ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "cpml_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) endif ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_CPML_2D_viscoelast_fourth !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,sispressure,nt,nrec,DELTAT,t0) implicit none integer nt,nrec double precision DELTAT,t0 double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) double precision sispressure(nt,nrec) integer irec,it character(len=100) file_name ! pressure do irec=1,nrec write(file_name,"('pressure_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt ! in the scheme of eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) ! pressure is defined at time t + DELTAT/2, i.e. staggered in time with respect to velocity. ! Here we must thus take this shift of DELTAT/2 into account to save the seismograms at the right time write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec)) enddo close(11) enddo ! X component of velocity do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component of velocity do irec=1,nrec write(file_name,"('Vy_file_half_a_grid_cell_away_from_Vx_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX ! in order to be able to use a fourth-order spatial operator on the edges of the model ! here we define the array with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case double precision, dimension(0:NX+1,0:NY+1) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it else if (field_number == 3) then write(file_name,"('image',i6.6,'_pressure.pnm')") it write(system_command,"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')") & it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ! !---- include the SolvOpt() routine that is used to compute the tau_epsilon and tau_sigma values from a given Q attenuation factor ! include "attenuation_model_with_SolvOpt.f90" ================================================ FILE: seismic_CPML_2D_velocity_and_stress_second_order_viscoelastic.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.3, July 2018. ! ! Copyright CNRS, France. ! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! This software is a computer program whose purpose is to solve ! the two-dimensional heterogeneous isotropic viscoelastic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_2D_viscoelast_second ! 2D finite-difference code in velocity and stress formulation ! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic viscoelastic medium ! Dimitri Komatitsch, CNRS, Marseille, July 2018. ! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! e13 | | | ! (memory | | | ! variable) | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! e1 (viscoelastic memory variable) ! e11 (viscoelastic memory variable) ! ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these ! articles: ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the 2D results as color images, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! include viscoelastic attenuation or not logical, parameter :: VISCOELASTIC_ATTENUATION = .true. ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! total number of grid points in each direction of the grid integer, parameter :: NX = 2001 integer, parameter :: NY = 2001 ! size of a grid cell double precision, parameter :: DELTAX = 1.5d0 double precision, parameter :: DELTAY = DELTAX ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! P-velocity and density ! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity) double precision, parameter :: cp_unrelaxed = 2000.d0 double precision, parameter :: cs_unrelaxed = cp_unrelaxed / 1.732d0 double precision, parameter :: density = 2000.d0 ! Time step in seconds. ! The CFL stability number for the O(2,2) algorithm is 1 / sqrt(2) = 0.707 ! i.e. one must choose cp * deltat / deltax < 0.707. ! For the O(2,4) algorithm used here it is a bit more restrictive, ! it is cp * deltat / deltax < 0.606 (see Levander 1988 eq (7)). ! However this only ensures that the scheme is stable. To have a scheme that is both stable and accurate, ! for O(2,4) some numerical tests show that one needs to take about half of that, ! i.e. choose deltat so that cp * deltat / deltax is equal to about 0.30 or so. (or any value below; but not above). ! Since the time scheme is only second order, this also depends on how many time steps are performed in total ! (i.e. what the value of NSTEP below is); for large values of NSTEP, of course numerical errors will start to accumulate. double precision, parameter :: DELTAT = 2.2d-4 ! total number of time steps integer, parameter :: NSTEP = 5200 ! parameters for the source double precision, parameter :: f0 = 35.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d0 ! source (force) double precision, parameter :: xsource = 1500.d0 double precision, parameter :: ysource = 1500.d0 integer, parameter :: ISOURCE = xsource / DELTAX + 1 integer, parameter :: JSOURCE = ysource / DELTAY + 1 ! angle of source force in degrees and clockwise, with respect to the vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 0.d0 ! receivers integer, parameter :: NREC = 1 !! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters ! to compute energy curves for the whole medium (optional, but useful e.g. to produce ! energy variation figures for articles); but expensive option, thus off by default logical, parameter :: COMPUTE_ENERGY = .false. ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 200 ! compute some constants once and for all for the second-order spatial scheme double precision, parameter :: ONE_OVER_DELTAX = 1.d0 / DELTAX double precision, parameter :: ONE_OVER_DELTAY = 1.d0 / DELTAY ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 double precision, parameter :: TWO_THIRDS = 2.d0 / 3.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays double precision, dimension(NX,NY) :: vx,vy,sigma_xx,sigma_yy,sigma_xy,lambda_unrelaxed,mu_unrelaxed,rho ! to interpolate material parameters or velocity at the right location in the staggered grid cell double precision :: lambda_half_x,mu_half_x,lambda_plus_mu_half_x,lambda_plus_two_mu_half_x,mu_half_y double precision :: rho_half_x_half_y,vy_interpolated ! for evolution of total energy in the medium double precision :: epsilon_xx,epsilon_yy,epsilon_xy double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(NX,NY) :: & memory_dvx_dx, & memory_dvx_dy, & memory_dvy_dx, & memory_dvy_dy, & memory_dsigma_xx_dx, & memory_dsigma_yy_dy, & memory_dsigma_xy_dx, & memory_dsigma_xy_dy double precision :: & value_dvx_dx, & value_dvx_dy, & value_dvy_dx, & value_dvy_dy, & value_dsigma_xx_dx, & value_dsigma_yy_dy, & value_dsigma_xy_dx, & value_dsigma_xy_dy ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half, & one_over_K_x,one_over_K_x_half double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half, & one_over_K_y,one_over_K_y_half double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized ! for the source double precision :: a,t,force_x,force_y,force_source_term ! for receivers ! Please note something important: the two components of the velocity vector are not defined at the same location, ! Vy is half a grid cell away from Vx (see ASCII figure at the beginning of this program). ! Thus this means there are "two receivers" rather than one, one recording Vx and another one, half a grid cell away, recording Vy. ! If you need to use both components in real applications (and of course we will), ! you will need to interpolate Vy to the location of Vx using: ! ! interpolate vy back at the location of vx, to be able to use both at the same location ! vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1)) ! double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec integer :: myNREC ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sispressure integer :: i,j,it,irec double precision :: Courant_number,velocnorm ! for attenuation (viscoelasticity) ! attenuation quality factors Qp and Qs to use ! BEWARE: we use Qp and Qs here, not QKappa and Qmu. ! BEWARE: While Qmu is always equal to Qs, QKappa is not equal to Qp, ! BEWARE: to convert from one to the other if your input data have Qkappa and Qmu you can use ! BEWARE: the program conversion_between_Qp_Qs_and_Qkappa_Qmu_from_Dahlen_Tromp_959_960_in_3D_and_in_2D_plane_strain.f90 ! BEWARE: that is included in this software package. double precision, parameter :: Qp = 65.d0 double precision, parameter :: Qs = 55.d0 ! number of Zener standard linear solids in parallel integer, parameter :: N_SLS = 3 ! attenuation constants double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,one_over_tau_sigma_nu1, & HALF_DELTAT_over_tau_sigma_nu1,multiplication_factor_tau_sigma_nu1,DELTAT_phi_nu1 double precision, dimension(N_SLS) :: tau_epsilon_nu2,tau_sigma_nu2,one_over_tau_sigma_nu2, & HALF_DELTAT_over_tau_sigma_nu2,multiplication_factor_tau_sigma_nu2,DELTAT_phi_nu2 ! memory variable and other arrays for attenuation double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e1_dot,memory_variable_R_e1_dot_old double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e11_dot,memory_variable_R_e11_dot_old double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e13_dot,memory_variable_R_e13_dot_old integer :: i_sls double precision :: sum_of_memory_variables_e1,sum_of_memory_variables_e11,sum_of_memory_variables_e13 ! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band double precision :: f_min_attenuation,f_max_attenuation !--- !--- program starts here !--- print * print *,'2D viscoelastic finite-difference code in velocity and stress formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print * print *,'Total number of grid points = ',NX * NY print * ! for attenuation (viscoelasticity) if (VISCOELASTIC_ATTENUATION) then print *,'Qp quality factor used for attenuation = ',Qp print *,'Qs quality factor used for attenuation = ',Qs print *,'Number of Zener standard linear solids used to mimic the viscoelastic behavior (N_SLS) = ',N_SLS print * ! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band ! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0) f_min_attenuation = exp(log(f0)-log(12.d0)/2.d0) f_max_attenuation = 12.d0 * f_min_attenuation ! call the SolvOpt() nonlinear optimization routine to compute the tau_epsilon and tau_sigma values from a given Q factor print *,'Values for Qp:' print * call compute_attenuation_coeffs(N_SLS,Qp,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu1,tau_sigma_nu1) print *,'Values for Qs:' print * call compute_attenuation_coeffs(N_SLS,Qs,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu2,tau_sigma_nu2) else ! dummy values in the non-dissipative case tau_epsilon_nu1(:) = 1.d0 tau_sigma_nu1(:) = 1.d0 tau_epsilon_nu2(:) = 1.d0 tau_sigma_nu2(:) = 1.d0 endif ! precompute the inverse once and for all, to save computation time in the time loop below ! (on computers, a multiplication is very significantly cheaper than a division) one_over_tau_sigma_nu1(:) = 1.d0 / tau_sigma_nu1(:) one_over_tau_sigma_nu2(:) = 1.d0 / tau_sigma_nu2(:) HALF_DELTAT_over_tau_sigma_nu1(:) = 0.5d0 * DELTAT / tau_sigma_nu1(:) HALF_DELTAT_over_tau_sigma_nu2(:) = 0.5d0 * DELTAT / tau_sigma_nu2(:) multiplication_factor_tau_sigma_nu1(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu1(:)) multiplication_factor_tau_sigma_nu2(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu2(:)) ! use the right formula with 1/N included DELTAT_phi_nu1(:) = DELTAT * (1.d0 - tau_epsilon_nu1(:)/tau_sigma_nu1(:)) / tau_sigma_nu1(:) / sum(tau_epsilon_nu1/tau_sigma_nu1) DELTAT_phi_nu2(:) = DELTAT * (1.d0 - tau_epsilon_nu2(:)/tau_sigma_nu2(:)) / tau_sigma_nu2(:) / sum(tau_epsilon_nu2/tau_sigma_nu2) !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y) print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print * d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- left edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- right edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- bottom edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- top edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! precompute the inverse once and for all, to save computation time in the time loop below ! (on computers, a multiplication is very significantly cheaper than a division) one_over_K_x(:) = 1.d0 / K_x(:) one_over_K_x_half(:) = 1.d0 / K_x_half(:) one_over_K_y(:) = 1.d0 / K_y(:) one_over_K_y_half(:) = 1.d0 / K_y_half(:) ! compute the Lame parameter and density do j = 1,NY do i = 1,NX rho(i,j) = density mu_unrelaxed(i,j) = density*cs_unrelaxed*cs_unrelaxed lambda_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed - 2.d0*mu_unrelaxed(i,j) enddo enddo ! print position of the source print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print *,'There are ',nrec,' receivers' print * if (NREC > 1) then ! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1 myNREC = NREC xspacerec = (xfin-xdeb) / dble(myNREC-1) yspacerec = (yfin-ydeb) / dble(myNREC-1) else xspacerec = 0.d0 yspacerec = 0.d0 endif do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant, K. O. Friedrichs and H. Lewy (1928) ! For this O(2,2) scheme, when DELTAX == DELTAY the Courant number is 1/sqrt(2) = 0.707 if (DELTAX == DELTAY) then Courant_number = cp_unrelaxed * DELTAT / DELTAX print *,'Courant number is ',Courant_number print *,' (the maximum possible value is 1/sqrt(2) = 0.707; & &in practice for accuracy reasons a value not larger than 0.30 is recommended)' print * if (Courant_number > 1.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable' endif ! suppress old files (can be commented out if "call system" is missing in your compiler) call system('rm -f Vx_file*.dat Vy_file*.dat image*.pnm image*.gif') ! initialize arrays vx(:,:) = ZERO vy(:,:) = ZERO sigma_xx(:,:) = ZERO sigma_yy(:,:) = ZERO sigma_xy(:,:) = ZERO memory_variable_R_e1_dot(:,:,:) = ZERO memory_variable_R_e1_dot_old(:,:,:) = ZERO memory_variable_R_e11_dot(:,:,:) = ZERO memory_variable_R_e11_dot_old(:,:,:) = ZERO memory_variable_R_e13_dot(:,:,:) = ZERO memory_variable_R_e13_dot_old(:,:,:) = ZERO ! PML memory_dvx_dx(:,:) = ZERO memory_dvx_dy(:,:) = ZERO memory_dvy_dx(:,:) = ZERO memory_dvy_dy(:,:) = ZERO memory_dsigma_xx_dx(:,:) = ZERO memory_dsigma_yy_dy(:,:) = ZERO memory_dsigma_xy_dx(:,:) = ZERO memory_dsigma_xy_dy(:,:) = ZERO ! initialize seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO sispressure(:,:) = ZERO ! initialize total energy total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO if (VISCOELASTIC_ATTENUATION) then print *,'adding VISCOELASTIC_ATTENUATION (i.e., running a viscoelastic simulation)' else print *,'not adding VISCOELASTIC_ATTENUATION (i.e., running a purely elastic simulation)' endif print * !--- !--- beginning of time loop !--- do it = 1,NSTEP !----------------------------------------------------------------------- ! compute the stress tensor and update memory variables for C-PML ! also update memory variables for viscoelastic attenuation if needed !----------------------------------------------------------------------- ! we purposely leave this "if" test outside of the loops to make sure the compiler can optimize these loops; ! with an "if" test inside most compilers cannot if (.not. VISCOELASTIC_ATTENUATION) then do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j)) mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j)) lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j) sigma_xx(i,j) = sigma_xx(i,j) + (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) * DELTAT sigma_yy(i,j) = sigma_yy(i,j) + (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) * DELTAT enddo enddo do j = 1,NY-1 do i = 2,NX ! interpolate material parameters at the right location in the staggered grid cell mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j)) value_dvy_dx = (vy(i,j) - vy(i-1,j)) * ONE_OVER_DELTAX value_dvx_dy = (vx(i,j+1) - vx(i,j)) * ONE_OVER_DELTAY memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j) value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j) sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy) * DELTAT enddo enddo else ! the present becomes the past for the memory variables. ! in C or C++ we could replace this with an exchange of pointers on the arrays ! in order to avoid a memory copy of the whole array. memory_variable_R_e1_dot_old(:,:,:) = memory_variable_R_e1_dot(:,:,:) memory_variable_R_e11_dot_old(:,:,:) = memory_variable_R_e11_dot(:,:,:) memory_variable_R_e13_dot_old(:,:,:) = memory_variable_R_e13_dot(:,:,:) do j = 2,NY do i = 1,NX-1 ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j)) mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j)) lambda_plus_mu_half_x = lambda_half_x + mu_half_x lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_DELTAY memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j) value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j) ! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following ! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here sum_of_memory_variables_e1 = 0.d0 sum_of_memory_variables_e11 = 0.d0 do i_sls = 1,N_SLS ! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) memory_variable_R_e1_dot(i,j,i_sls) = (memory_variable_R_e1_dot_old(i,j,i_sls) + & (value_dvx_dx + value_dvy_dy) * DELTAT_phi_nu1(i_sls) - & memory_variable_R_e1_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu1(i_sls)) & * multiplication_factor_tau_sigma_nu1(i_sls) memory_variable_R_e11_dot(i,j,i_sls) = (memory_variable_R_e11_dot_old(i,j,i_sls) + & 0.5d0 * (value_dvx_dx - value_dvy_dy) * DELTAT_phi_nu2(i_sls) - & memory_variable_R_e11_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) & * multiplication_factor_tau_sigma_nu2(i_sls) sum_of_memory_variables_e1 = sum_of_memory_variables_e1 + & memory_variable_R_e1_dot(i,j,i_sls) + memory_variable_R_e1_dot_old(i,j,i_sls) sum_of_memory_variables_e11 = sum_of_memory_variables_e11 + & memory_variable_R_e11_dot(i,j,i_sls) + memory_variable_R_e11_dot_old(i,j,i_sls) enddo sigma_xx(i,j) = sigma_xx(i,j) + & (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy & ! use the right formula with 1/N included ! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189)) ! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) + (0.5d0 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 + mu_half_x * sum_of_memory_variables_e11)) * DELTAT sigma_yy(i,j) = sigma_yy(i,j) + & (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy & ! use the right formula with 1/N included ! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189)) ! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) + (0.5d0 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 - mu_half_x * sum_of_memory_variables_e11)) * DELTAT enddo enddo do j = 1,NY-1 do i = 2,NX ! interpolate material parameters at the right location in the staggered grid cell mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j)) value_dvy_dx = (vy(i,j) - vy(i-1,j)) * ONE_OVER_DELTAX value_dvx_dy = (vx(i,j+1) - vx(i,j)) * ONE_OVER_DELTAY memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j) value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j) ! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following ! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here sum_of_memory_variables_e13 = 0.d0 do i_sls = 1,N_SLS ! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) memory_variable_R_e13_dot(i,j,i_sls) = (memory_variable_R_e13_dot_old(i,j,i_sls) + & (value_dvy_dx + value_dvx_dy) * DELTAT_phi_nu2(i_sls) - & memory_variable_R_e13_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) & * multiplication_factor_tau_sigma_nu2(i_sls) sum_of_memory_variables_e13 = sum_of_memory_variables_e13 + & memory_variable_R_e13_dot(i,j,i_sls) + memory_variable_R_e13_dot_old(i,j,i_sls) enddo sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy & ! use the right formula with 1/N included ! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189)) ! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) + 0.5d0 * sum_of_memory_variables_e13) * DELTAT enddo enddo endif !-------------------------------------------------------- ! compute velocity and update memory variables for C-PML !-------------------------------------------------------- do j = 2,NY do i = 2,NX value_dsigma_xx_dx = (sigma_xx(i,j) - sigma_xx(i-1,j)) * ONE_OVER_DELTAX value_dsigma_xy_dy = (sigma_xy(i,j) - sigma_xy(i,j-1)) * ONE_OVER_DELTAY memory_dsigma_xx_dx(i,j) = b_x(i) * memory_dsigma_xx_dx(i,j) + a_x(i) * value_dsigma_xx_dx memory_dsigma_xy_dy(i,j) = b_y(j) * memory_dsigma_xy_dy(i,j) + a_y(j) * value_dsigma_xy_dy value_dsigma_xx_dx = value_dsigma_xx_dx / K_x(i) + memory_dsigma_xx_dx(i,j) value_dsigma_xy_dy = value_dsigma_xy_dy / K_y(j) + memory_dsigma_xy_dy(i,j) vx(i,j) = vx(i,j) + (value_dsigma_xx_dx + value_dsigma_xy_dy) * DELTAT / rho(i,j) enddo enddo do j = 1,NY-1 do i = 1,NX-1 ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) value_dsigma_xy_dx = (sigma_xy(i+1,j) - sigma_xy(i,j)) * ONE_OVER_DELTAX value_dsigma_yy_dy = (sigma_yy(i,j+1) - sigma_yy(i,j)) * ONE_OVER_DELTAY memory_dsigma_xy_dx(i,j) = b_x_half(i) * memory_dsigma_xy_dx(i,j) + a_x_half(i) * value_dsigma_xy_dx memory_dsigma_yy_dy(i,j) = b_y_half(j) * memory_dsigma_yy_dy(i,j) + a_y_half(j) * value_dsigma_yy_dy value_dsigma_xy_dx = value_dsigma_xy_dx / K_x_half(i) + memory_dsigma_xy_dx(i,j) value_dsigma_yy_dy = value_dsigma_yy_dy / K_y_half(j) + memory_dsigma_yy_dy(i,j) vy(i,j) = vy(i,j) + (value_dsigma_xy_dx + value_dsigma_yy_dy) * DELTAT / rho_half_x_half_y enddo enddo ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! force_source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a) ! first derivative of a Gaussian ! force_source_term = factor * (t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) force_source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) ! to get the right amplitude of the force, we need to divide by the area of a grid cell ! (we checked that against the analytical solution in a homogeneous medium for a force source) force_source_term = force_source_term / (DELTAX * DELTAY) ! define location of the source i = ISOURCE j = JSOURCE force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term ! interpolate density at the right location in the staggered grid cell rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1)) ! we want seismograms to be representing velocity, for the case of the seismic wave equation ! representing displacement for a Ricker (i.e., second derivative of a Gaussian) source in displacement. ! Since the force source is added to d(velocity)/dt in this split velocity and stress scheme ! we need to select the second derivative of a Gaussian as a source time wavelet ! by analogy with a Ricker (i.e. a second derivative) added to d2(displacement)/dt2 ! as in the unsplit equation written in displacement only. ! Since the formula is d(velocity)/dt = (velocity_new - velocity_old) / DELTAT = force_source_term ! we also need to multiply by DELTAT here to avoid having an amplitude of the seismogram ! that varies when one changes the time step, i.e. we write: ! velocity_new = velocity_old + force_source_term * DELTAT at the source grid point vx(i,j) = vx(i,j) + force_x * DELTAT / rho(i,j) vy(i,j) = vy(i,j) + force_y * DELTAT / rho_half_x_half_y ! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers vx(1,:) = ZERO vx(NX,:) = ZERO vx(:,1) = ZERO vx(:,NY) = ZERO vy(1,:) = ZERO vy(NX,:) = ZERO vy(:,1) = ZERO vy(:,NY) = ZERO ! store seismograms do irec = 1,NREC ! beware here that the two components of the velocity vector are not defined at the same point ! in a staggered grid, and thus the two components of the velocity vector are recorded at slightly different locations, ! vy is staggered by half a grid cell along X and along Y with respect to vx sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec)) sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec)) ! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction, ! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5): ! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as ! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor. ! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3 ! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij ! = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij ! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx ! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy ! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz ! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon) ! ! to compute pressure in 2D in an elastic solid in the plane strain convention i.e. in the P-SV case, ! one still uses pressure = - trace(sigma) / 3 but taking into account the fact ! that the off-plane strain epsilon_zz is zero by definition of the plane strain convention ! but thus the off-plane stress sigma_zz is not equal to zero, ! one has instead: sigma_zz = lambda * (epsilon_xx + epsilon_yy), thus ! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij ! = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij ! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx ! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy ! sigma_zz = lambda * (epsilon_xx + epsilon_yy) ! pressure = - trace(sigma) / 3 = - (lambda + 2*mu/3) (epsilon_xx + epsilon_yy) i = ix_rec(irec) j = iy_rec(irec) ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j)) mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j)) epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * & sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x)) epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * & sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x)) sispressure(it,irec) = - (lambda_half_x + TWO_THIRDS*mu_half_x) * (epsilon_xx + epsilon_yy) enddo ! compute total energy in the medium (without the PML layers) if (COMPUTE_ENERGY) then ! compute kinetic energy first, defined as 1/2 rho ||v||^2 total_energy_kinetic(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! interpolate vy back at the location of vx, to be able to use both at the same location vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1)) total_energy_kinetic(it) = total_energy_kinetic(it) + 0.5d0 * rho(i,j) * (vx(i,j)**2 + vy_interpolated**2) enddo enddo ! add potential energy, defined as 1/2 epsilon_ij sigma_ij total_energy_potential(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! interpolate material parameters at the right location in the staggered grid cell lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j)) mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j)) mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j)) epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * & sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x)) epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * & sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x)) epsilon_xy = sigma_xy(i,j) / (2.d0 * mu_half_y) total_energy_potential(it) = total_energy_potential(it) + & 0.5d0 * (epsilon_xx * sigma_xx(i,j) + epsilon_yy * sigma_yy(i,j) + 2.d0 * epsilon_xy * sigma_xy(i,j)) enddo enddo endif ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then ! print maximum of norm of velocity velocnorm = maxval(sqrt(vx**2 + vy**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',velocnorm if (COMPUTE_ENERGY) print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) print * ! check stability of the code, exit if unstable if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1) call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2) ! save the part of the seismograms that has been computed so far, so that users can monitor the progress of the simulation call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0) if (COMPUTE_ENERGY) then ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "cpml_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) endif ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_CPML_2D_viscoelast_second !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,sispressure,nt,nrec,DELTAT,t0) implicit none integer nt,nrec double precision DELTAT,t0 double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) double precision sispressure(nt,nrec) integer irec,it character(len=100) file_name ! pressure do irec=1,nrec write(file_name,"('pressure_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt ! in the scheme of eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994) ! pressure is defined at time t + DELTAT/2, i.e. staggered in time with respect to velocity. ! Here we must thus take this shift of DELTAT/2 into account to save the seismograms at the right time write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec)) enddo close(11) enddo ! X component of velocity do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component of velocity do irec=1,nrec write(file_name,"('Vy_file_half_a_grid_cell_away_from_Vx_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it else if (field_number == 3) then write(file_name,"('image',i6.6,'_pressure.pnm')") it write(system_command,"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')") & it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ! !---- include the SolvOpt() routine that is used to compute the tau_epsilon and tau_sigma values from a given Q attenuation factor ! include "attenuation_model_with_SolvOpt.f90" ================================================ FILE: seismic_CPML_3D_isotropic_MPI_OpenMP.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.1, November 2009. ! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! This software is a computer program whose purpose is to solve ! the three-dimensional isotropic elastic wave equation ! using a finite-difference method with Convolutional Perfectly Matched ! Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_CPML_3D_iso_MPI_OpenMP ! 3D elastic finite-difference code in velocity and stress formulation ! with Convolutional-PML (C-PML) absorbing conditions. ! Dimitri Komatitsch, University of Pau, France, April 2007. ! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used. ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! ! Parallel implementation based on both MPI and OpenMP. ! Type for instance "setenv OMP_NUM_THREADS 4" before running in OpenMP if you want 4 tasks. ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these ! articles: ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! To display the results as color images in the selected 2D cut plane, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! header which contains standard MPI declarations include 'mpif.h' ! total number of grid points in each direction of the grid integer, parameter :: NX = 101 integer, parameter :: NY = 641 integer, parameter :: NZ = 640 ! even number in order to cut along Z axis ! number of processes used in the MPI run ! and local number of points (for simplicity we cut the mesh along Z only) integer, parameter :: NPROC = 64 integer, parameter :: NZ_LOCAL = NZ / NPROC ! size of a grid cell double precision, parameter :: DELTAX = 10.d0, ONE_OVER_DELTAX = 1.d0 / DELTAX double precision, parameter :: DELTAY = DELTAX, DELTAZ = DELTAX double precision, parameter :: ONE_OVER_DELTAY = ONE_OVER_DELTAX, ONE_OVER_DELTAZ = ONE_OVER_DELTAX ! P-velocity, S-velocity and density double precision, parameter :: cp = 3300.d0 double precision, parameter :: cs = cp / 1.732d0 double precision, parameter :: rho = 2800.d0 double precision, parameter :: mu = rho*cs*cs double precision, parameter :: lambda = rho*(cp*cp - 2.d0*cs*cs) double precision, parameter :: lambdaplustwomu = rho*cp*cp ! total number of time steps integer, parameter :: NSTEP = 2500 ! time step in seconds double precision, parameter :: DELTAT = 1.6d-3 ! parameters for the source double precision, parameter :: f0 = 7.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d7 ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. logical, parameter :: USE_PML_ZMIN = .true. logical, parameter :: USE_PML_ZMAX = .true. ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! source ! Since we cut the domain into slices along the Z direction in order to implement MPI, ! we have to tell the code in which MPI slice of the mesh the source is, ! and inside that mesh slice we need to tell it at which iz grid point it is, in the slice, thus between 1 and NZ_LOCAL. ! Here in this demo code we put the source in the middle of the model in the Z direction, ! i.e. in NZ/2, which means putting it in the cut plane (i.e. only the processor for which ! rank == rank_cut_plane will do it, and it will put it in its last point along Z, in NZ_LOCAL. ! if one wants to put the source at another location, one can invert the formulas below ! and define the grid point (ISOURCE, JSOURCE) to use as: ! double precision, parameter :: xsource = ...put here the coordinate you want... ! double precision, parameter :: ysource = ...put here the coordinate you want... ! integer, parameter :: ISOURCE = xsource / DELTAX + 1 ! integer, parameter :: JSOURCE = ysource / DELTAY + 1 integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1 integer, parameter :: JSOURCE = 2 * NY / 3 + 1 double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY ! angle of source force clockwise with respect to vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 135.d0 ! receivers integer, parameter :: NREC = 2 double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters double precision, parameter :: xfin = xsource ! last receiver x in meters double precision, parameter :: yfin = 300.d0 ! last receiver y in meters ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 100 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 1.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(NX,NY,NZ_LOCAL) :: & memory_dvx_dx, & memory_dvx_dy, & memory_dvx_dz, & memory_dvy_dx, & memory_dvy_dy, & memory_dvy_dz, & memory_dvz_dx, & memory_dvz_dy, & memory_dvz_dz, & memory_dsigmaxx_dx, & memory_dsigmayy_dy, & memory_dsigmazz_dz, & memory_dsigmaxy_dx, & memory_dsigmaxy_dy, & memory_dsigmaxz_dx, & memory_dsigmaxz_dz, & memory_dsigmayz_dy, & memory_dsigmayz_dz double precision :: & value_dvx_dx, & value_dvx_dy, & value_dvx_dz, & value_dvy_dx, & value_dvy_dy, & value_dvy_dz, & value_dvz_dx, & value_dvz_dy, & value_dvz_dz, & value_dsigmaxx_dx, & value_dsigmayy_dy, & value_dsigmazz_dz, & value_dsigmaxy_dx, & value_dsigmaxy_dy, & value_dsigmaxz_dx, & value_dsigmaxz_dz, & value_dsigmayz_dy, & value_dsigmayz_dz ! 1D arrays for the damping profiles double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half double precision, dimension(NZ) :: d_z,K_z,alpha_z,a_z,b_z,d_z_half,K_z_half,alpha_z_half,a_z_half,b_z_half ! PML double precision thickness_PML_x,thickness_PML_y,thickness_PML_z double precision xoriginleft,xoriginright,yoriginbottom,yorigintop,zoriginbottom,zorigintop double precision Rcoef,d0_x,d0_y,d0_z,xval,yval,zval,abscissa_in_PML,abscissa_normalized ! change dimension of Z axis to add two planes for MPI double precision, dimension(NX,NY,0:NZ_LOCAL+1) :: vx,vy,vz,sigmaxx,sigmayy,sigmazz,sigmaxy,sigmaxz,sigmayz integer, parameter :: number_of_arrays = 9 + 2*9 ! for the source double precision a,t,force_x,force_y,source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy ! for evolution of total energy in the medium double precision :: epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz double precision :: total_energy_kinetic,total_energy_potential double precision, dimension(NSTEP) :: total_energy integer :: irec ! precompute some parameters once and for all double precision, parameter :: DELTAT_lambda = DELTAT*lambda double precision, parameter :: DELTAT_mu = DELTAT*mu double precision, parameter :: DELTAT_lambdaplus2mu = DELTAT*lambdaplustwomu double precision, parameter :: DELTAT_over_rho = DELTAT/rho integer :: i,j,k,it double precision :: Vsolidnorm,Courant_number ! timer to count elapsed time character(len=8) datein character(len=10) timein character(len=5) :: zone integer, dimension(8) :: time_values integer ihours,iminutes,iseconds,int_tCPU double precision :: time_start,time_end,tCPU ! names of the time stamp files character(len=150) outputname ! main I/O file integer, parameter :: IOUT = 41 ! array needed for MPI_RECV integer, dimension(MPI_STATUS_SIZE) :: message_status ! tag of the message to send integer, parameter :: message_tag = 0 ! number of values to send or receive integer, parameter :: number_of_values = NX*NY integer :: nb_procs,rank,code,rank_cut_plane,kmin,kmax,kglobal,offset_k,k2begin,kminus1end integer :: sender_right_shift,receiver_right_shift,sender_left_shift,receiver_left_shift !--- !--- program starts here !--- ! start MPI processes call MPI_INIT(code) ! get total number of MPI processes in variable nb_procs call MPI_COMM_SIZE(MPI_COMM_WORLD, nb_procs, code) ! get the rank of our process from 0 (master) to nb_procs-1 (workers) call MPI_COMM_RANK(MPI_COMM_WORLD, rank, code) ! slice number for the cut plane in the middle of the mesh rank_cut_plane = nb_procs/2 - 1 if (rank == rank_cut_plane) then print * print *,'3D elastic finite-difference code in velocity and stress formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print *,'NZ = ',NZ print * print *,'NZ_LOCAL = ',NZ_LOCAL print *,'NPROC = ',NPROC print * print *,'size of the model along X = ',(NX - 1) * DELTAX print *,'size of the model along Y = ',(NY - 1) * DELTAY print *,'size of the model along Y = ',(NZ - 1) * DELTAZ print * print *,'Total number of grid points = ',NX * NY * NZ print *,'Number of points of all the arrays = ',dble(NX)*dble(NY)*dble(NZ)*number_of_arrays print *,'Size in GB of all the arrays = ',dble(NX)*dble(NY)*dble(NZ)*number_of_arrays*8.d0/(1024.d0*1024.d0*1024.d0) print * print *,'In each slice:' print * print *,'Total number of grid points = ',NX * NY * NZ_LOCAL print *,'Number of points of the arrays = ',dble(NX)*dble(NY)*dble(NZ_LOCAL)*number_of_arrays print *,'Size in GB of the arrays = ',dble(NX)*dble(NY)*dble(NZ_LOCAL)*number_of_arrays*8.d0/(1024.d0*1024.d0*1024.d0) print * endif ! check that code was compiled with the right number of slices if (nb_procs /= NPROC) then print *,'nb_procs,NPROC = ',nb_procs,NPROC stop 'nb_procs must be equal to NPROC' endif ! we restrict ourselves to an even number of slices ! in order to have a cut plane in the middle of the mesh for visualization purposes if (mod(nb_procs,2) /= 0) stop 'nb_procs must be even' ! check that we can cut along Z in an exact number of slices if (mod(NZ,nb_procs) /= 0) stop 'NZ must be a multiple of nb_procs' ! check that a slice is at least as thick as a PML layer if (NZ_LOCAL < NPOINTS_PML) stop 'NZ_LOCAL must be greater than NPOINTS_PML' ! offset of this slice when we cut along Z offset_k = rank * NZ_LOCAL !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY thickness_PML_z = NPOINTS_PML * DELTAZ ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_y) d0_z = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_z) if (rank == rank_cut_plane) then print * print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print *,'d0_z = ',d0_z endif ! PML d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO d_z(:) = ZERO d_z_half(:) = ZERO K_z(:) = 1.d0 K_z_half(:) = 1.d0 alpha_z(:) = ZERO alpha_z_half(:) = ZERO a_z(:) = ZERO a_z_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- xmin edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- xmax edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- ymin edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- ymax edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! damping in the Z direction ! origin of the PML layer (position of right edge minus thickness, in meters) zoriginbottom = thickness_PML_z zorigintop = (NZ-1)*DELTAZ - thickness_PML_z do k = 1,NZ ! abscissa of current grid point along the damping profile zval = DELTAZ * dble(k-1) !---------- zmin edge if (USE_PML_ZMIN) then ! define damping profile at the grid points abscissa_in_PML = zoriginbottom - zval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_z d_z(k) = d0_z * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_z(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_z(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = zoriginbottom - (zval + DELTAZ/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_z d_z_half(k) = d0_z * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_z_half(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_z_half(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- zmax edge if (USE_PML_ZMAX) then ! define damping profile at the grid points abscissa_in_PML = zval - zorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_z d_z(k) = d0_z * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_z(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_z(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = zval + DELTAZ/2.d0 - zorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_z d_z_half(k) = d0_z * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_z_half(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_z_half(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_z(k) = exp(- (d_z(k) / K_z(k) + alpha_z(k)) * DELTAT) b_z_half(k) = exp(- (d_z_half(k) / K_z_half(k) + alpha_z_half(k)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_z(k)) > 1.d-6) a_z(k) = d_z(k) * (b_z(k) - 1.d0) / (K_z(k) * (d_z(k) + K_z(k) * alpha_z(k))) if (abs(d_z_half(k)) > 1.d-6) a_z_half(k) = d_z_half(k) * & (b_z_half(k) - 1.d0) / (K_z_half(k) * (d_z_half(k) + K_z_half(k) * alpha_z_half(k))) enddo if (rank == rank_cut_plane) then ! print position of the source print * print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print * print *,'There are ',nrec,' receivers' print * xspacerec = (xfin-xdeb) / dble(NREC-1) yspacerec = (yfin-ydeb) / dble(NREC-1) do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo endif ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number = cp * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2 + 1.d0/DELTAZ**2) if (rank == rank_cut_plane) then print *,'Courant number is ',Courant_number print * endif if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable' ! erase main arrays vx(:,:,:) = ZERO vy(:,:,:) = ZERO vz(:,:,:) = ZERO sigmaxy(:,:,:) = ZERO sigmayy(:,:,:) = ZERO sigmazz(:,:,:) = ZERO sigmaxz(:,:,:) = ZERO sigmazz(:,:,:) = ZERO sigmayz(:,:,:) = ZERO ! PML memory_dvx_dx(:,:,:) = ZERO memory_dvx_dy(:,:,:) = ZERO memory_dvx_dz(:,:,:) = ZERO memory_dvy_dx(:,:,:) = ZERO memory_dvy_dy(:,:,:) = ZERO memory_dvy_dz(:,:,:) = ZERO memory_dvz_dx(:,:,:) = ZERO memory_dvz_dy(:,:,:) = ZERO memory_dvz_dz(:,:,:) = ZERO memory_dsigmaxx_dx(:,:,:) = ZERO memory_dsigmayy_dy(:,:,:) = ZERO memory_dsigmazz_dz(:,:,:) = ZERO memory_dsigmaxy_dx(:,:,:) = ZERO memory_dsigmaxy_dy(:,:,:) = ZERO memory_dsigmaxz_dx(:,:,:) = ZERO memory_dsigmaxz_dz(:,:,:) = ZERO memory_dsigmayz_dy(:,:,:) = ZERO memory_dsigmayz_dz(:,:,:) = ZERO ! erase seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO ! initialize total energy total_energy(:) = ZERO call date_and_time(datein,timein,zone,time_values) ! time_values(3): day of the month ! time_values(5): hour of the day ! time_values(6): minutes of the hour ! time_values(7): seconds of the minute ! time_values(8): milliseconds of the second ! this fails if we cross the end of the month time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + & 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0 !--- ! we receive from the process on the left, and send to the process on the right sender_right_shift = rank - 1 receiver_right_shift = rank + 1 ! if we are the first process, there is no neighbor on the left if (rank == 0) sender_right_shift = MPI_PROC_NULL ! if we are the last process, there is no neighbor on the right if (rank == nb_procs - 1) receiver_right_shift = MPI_PROC_NULL !--- ! we receive from the process on the right, and send to the process on the left sender_left_shift = rank + 1 receiver_left_shift = rank - 1 ! if we are the first process, there is no neighbor on the left if (rank == 0) receiver_left_shift = MPI_PROC_NULL ! if we are the last process, there is no neighbor on the right if (rank == nb_procs - 1) sender_left_shift = MPI_PROC_NULL k2begin = 1 if (rank == 0) k2begin = 2 kminus1end = NZ_LOCAL if (rank == nb_procs - 1) kminus1end = NZ_LOCAL - 1 !--- !--- beginning of time loop !--- do it = 1,NSTEP if (rank == rank_cut_plane) print *,'it = ',it !---------------------- ! compute stress sigma !---------------------- ! vx(k+1), left shift call MPI_SENDRECV(vx(:,:,1),number_of_values,MPI_DOUBLE_PRECISION, & receiver_left_shift,message_tag,vx(:,:,NZ_LOCAL+1),number_of_values, & MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code) ! vy(k+1), left shift call MPI_SENDRECV(vy(:,:,1),number_of_values,MPI_DOUBLE_PRECISION, & receiver_left_shift,message_tag,vy(:,:,NZ_LOCAL+1),number_of_values, & MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code) ! vz(k-1), right shift call MPI_SENDRECV(vz(:,:,NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, & receiver_right_shift,message_tag,vz(:,:,0),number_of_values, & MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code) !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, & !$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, & !$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, & !$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, & !$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, & !$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, & !$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, & !$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, & !$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, & !$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, & !$OMP a_y,b_y,K_y,a_y_half,b_y_half,K_y_half,a_z,b_z,K_z,a_z_half,b_z_half,K_z_half,k2begin,offset_k) do k=k2begin,NZ_LOCAL kglobal = k + offset_k do j=2,NY do i=1,NX-1 value_dvx_dx = (vx(i+1,j,k)-vx(i,j,k)) * ONE_OVER_DELTAX value_dvy_dy = (vy(i,j,k)-vy(i,j-1,k)) * ONE_OVER_DELTAY value_dvz_dz = (vz(i,j,k)-vz(i,j,k-1)) * ONE_OVER_DELTAZ memory_dvx_dx(i,j,k) = b_x_half(i) * memory_dvx_dx(i,j,k) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j,k) = b_y(j) * memory_dvy_dy(i,j,k) + a_y(j) * value_dvy_dy memory_dvz_dz(i,j,k) = b_z(kglobal) * memory_dvz_dz(i,j,k) + a_z(kglobal) * value_dvz_dz value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j,k) value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j,k) value_dvz_dz = value_dvz_dz / K_z(kglobal) + memory_dvz_dz(i,j,k) sigmaxx(i,j,k) = DELTAT_lambdaplus2mu*value_dvx_dx + & DELTAT_lambda*(value_dvy_dy + value_dvz_dz) + sigmaxx(i,j,k) sigmayy(i,j,k) = DELTAT_lambda*(value_dvx_dx + value_dvz_dz) + & DELTAT_lambdaplus2mu*value_dvy_dy + sigmayy(i,j,k) sigmazz(i,j,k) = DELTAT_lambda*(value_dvx_dx + value_dvy_dy) + DELTAT_lambdaplus2mu*value_dvz_dz + sigmazz(i,j,k) enddo enddo enddo !$OMP END PARALLEL DO !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, & !$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, & !$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, & !$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, & !$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, & !$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, & !$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, & !$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, & !$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, & !$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, & !$OMP a_y,b_y,K_y,a_y_half,b_y_half,K_y_half,a_z,b_z,K_z,a_z_half,b_z_half,K_z_half) do k=1,NZ_LOCAL do j=1,NY-1 do i=2,NX value_dvy_dx = (vy(i,j,k)-vy(i-1,j,k)) * ONE_OVER_DELTAX value_dvx_dy = (vx(i,j+1,k)-vx(i,j,k)) * ONE_OVER_DELTAY memory_dvy_dx(i,j,k) = b_x(i) * memory_dvy_dx(i,j,k) + a_x(i) * value_dvy_dx memory_dvx_dy(i,j,k) = b_y_half(j) * memory_dvx_dy(i,j,k) + a_y_half(j) * value_dvx_dy value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j,k) value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j,k) sigmaxy(i,j,k) = DELTAT_mu*(value_dvy_dx + value_dvx_dy) + sigmaxy(i,j,k) enddo enddo enddo !$OMP END PARALLEL DO !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, & !$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, & !$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, & !$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, & !$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, & !$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, & !$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, & !$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, & !$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, & !$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, & !$OMP a_y,b_y,K_y,a_y_half,b_y_half,K_y_half,a_z,b_z,K_z,a_z_half,b_z_half,K_z_half,kminus1end,offset_k) do k=1,kminus1end kglobal = k + offset_k do j=1,NY do i=2,NX value_dvz_dx = (vz(i,j,k)-vz(i-1,j,k)) * ONE_OVER_DELTAX value_dvx_dz = (vx(i,j,k+1)-vx(i,j,k)) * ONE_OVER_DELTAZ memory_dvz_dx(i,j,k) = b_x(i) * memory_dvz_dx(i,j,k) + a_x(i) * value_dvz_dx memory_dvx_dz(i,j,k) = b_z_half(kglobal) * memory_dvx_dz(i,j,k) + a_z_half(kglobal) * value_dvx_dz value_dvz_dx = value_dvz_dx / K_x(i) + memory_dvz_dx(i,j,k) value_dvx_dz = value_dvx_dz / K_z_half(kglobal) + memory_dvx_dz(i,j,k) sigmaxz(i,j,k) = DELTAT_mu*(value_dvz_dx + value_dvx_dz) + sigmaxz(i,j,k) enddo enddo do j=1,NY-1 do i=1,NX value_dvz_dy = (vz(i,j+1,k)-vz(i,j,k)) * ONE_OVER_DELTAY value_dvy_dz = (vy(i,j,k+1)-vy(i,j,k)) * ONE_OVER_DELTAZ memory_dvz_dy(i,j,k) = b_y_half(j) * memory_dvz_dy(i,j,k) + a_y_half(j) * value_dvz_dy memory_dvy_dz(i,j,k) = b_z_half(kglobal) * memory_dvy_dz(i,j,k) + a_z_half(kglobal) * value_dvy_dz value_dvz_dy = value_dvz_dy / K_y_half(j) + memory_dvz_dy(i,j,k) value_dvy_dz = value_dvy_dz / K_z_half(kglobal) + memory_dvy_dz(i,j,k) sigmayz(i,j,k) = DELTAT_mu*(value_dvz_dy + value_dvy_dz) + sigmayz(i,j,k) enddo enddo enddo !$OMP END PARALLEL DO !------------------ ! compute velocity !------------------ ! sigmazz(k+1), left shift call MPI_SENDRECV(sigmazz(:,:,1),number_of_values,MPI_DOUBLE_PRECISION, & receiver_left_shift,message_tag,sigmazz(:,:,NZ_LOCAL+1),number_of_values, & MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code) ! sigmayz(k-1), right shift call MPI_SENDRECV(sigmayz(:,:,NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, & receiver_right_shift,message_tag,sigmayz(:,:,0),number_of_values, & MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code) ! sigmaxz(k-1), right shift call MPI_SENDRECV(sigmaxz(:,:,NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, & receiver_right_shift,message_tag,sigmaxz(:,:,0),number_of_values, & MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code) !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, & !$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, & !$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, & !$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, & !$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, & !$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, & !$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, & !$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, & !$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, & !$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, & !$OMP a_y,b_y,K_y,a_y_half,b_y_half,K_y_half,a_z,b_z,K_z,a_z_half,b_z_half,K_z_half,k2begin,offset_k) do k=k2begin,NZ_LOCAL kglobal = k + offset_k do j=2,NY do i=2,NX value_dsigmaxx_dx = (sigmaxx(i,j,k)-sigmaxx(i-1,j,k)) * ONE_OVER_DELTAX value_dsigmaxy_dy = (sigmaxy(i,j,k)-sigmaxy(i,j-1,k)) * ONE_OVER_DELTAY value_dsigmaxz_dz = (sigmaxz(i,j,k)-sigmaxz(i,j,k-1)) * ONE_OVER_DELTAZ memory_dsigmaxx_dx(i,j,k) = b_x(i) * memory_dsigmaxx_dx(i,j,k) + a_x(i) * value_dsigmaxx_dx memory_dsigmaxy_dy(i,j,k) = b_y(j) * memory_dsigmaxy_dy(i,j,k) + a_y(j) * value_dsigmaxy_dy memory_dsigmaxz_dz(i,j,k) = b_z(kglobal) * memory_dsigmaxz_dz(i,j,k) + a_z(kglobal) * value_dsigmaxz_dz value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j,k) value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j,k) value_dsigmaxz_dz = value_dsigmaxz_dz / K_z(kglobal) + memory_dsigmaxz_dz(i,j,k) vx(i,j,k) = DELTAT_over_rho*(value_dsigmaxx_dx + value_dsigmaxy_dy + value_dsigmaxz_dz) + vx(i,j,k) enddo enddo do j=1,NY-1 do i=1,NX-1 value_dsigmaxy_dx = (sigmaxy(i+1,j,k)-sigmaxy(i,j,k)) * ONE_OVER_DELTAX value_dsigmayy_dy = (sigmayy(i,j+1,k)-sigmayy(i,j,k)) * ONE_OVER_DELTAY value_dsigmayz_dz = (sigmayz(i,j,k)-sigmayz(i,j,k-1)) * ONE_OVER_DELTAZ memory_dsigmaxy_dx(i,j,k) = b_x_half(i) * memory_dsigmaxy_dx(i,j,k) + a_x_half(i) * value_dsigmaxy_dx memory_dsigmayy_dy(i,j,k) = b_y_half(j) * memory_dsigmayy_dy(i,j,k) + a_y_half(j) * value_dsigmayy_dy memory_dsigmayz_dz(i,j,k) = b_z(kglobal) * memory_dsigmayz_dz(i,j,k) + a_z(kglobal) * value_dsigmayz_dz value_dsigmaxy_dx = value_dsigmaxy_dx / K_x_half(i) + memory_dsigmaxy_dx(i,j,k) value_dsigmayy_dy = value_dsigmayy_dy / K_y_half(j) + memory_dsigmayy_dy(i,j,k) value_dsigmayz_dz = value_dsigmayz_dz / K_z(kglobal) + memory_dsigmayz_dz(i,j,k) vy(i,j,k) = DELTAT_over_rho*(value_dsigmaxy_dx + value_dsigmayy_dy + value_dsigmayz_dz) + vy(i,j,k) enddo enddo enddo !$OMP END PARALLEL DO !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, & !$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, & !$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, & !$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, & !$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, & !$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, & !$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, & !$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, & !$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, & !$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, & !$OMP a_y,b_y,K_y,a_y_half,b_y_half,K_y_half,a_z,b_z,K_z,a_z_half,b_z_half,K_z_half,kminus1end,offset_k) do k=1,kminus1end kglobal = k + offset_k do j=2,NY do i=1,NX-1 value_dsigmaxz_dx = (sigmaxz(i+1,j,k)-sigmaxz(i,j,k)) * ONE_OVER_DELTAX value_dsigmayz_dy = (sigmayz(i,j,k)-sigmayz(i,j-1,k)) * ONE_OVER_DELTAY value_dsigmazz_dz = (sigmazz(i,j,k+1)-sigmazz(i,j,k)) * ONE_OVER_DELTAZ memory_dsigmaxz_dx(i,j,k) = b_x_half(i) * memory_dsigmaxz_dx(i,j,k) + a_x_half(i) * value_dsigmaxz_dx memory_dsigmayz_dy(i,j,k) = b_y(j) * memory_dsigmayz_dy(i,j,k) + a_y(j) * value_dsigmayz_dy memory_dsigmazz_dz(i,j,k) = b_z_half(kglobal) * memory_dsigmazz_dz(i,j,k) + a_z_half(kglobal) * value_dsigmazz_dz value_dsigmaxz_dx = value_dsigmaxz_dx / K_x_half(i) + memory_dsigmaxz_dx(i,j,k) value_dsigmayz_dy = value_dsigmayz_dy / K_y(j) + memory_dsigmayz_dy(i,j,k) value_dsigmazz_dz = value_dsigmazz_dz / K_z_half(kglobal) + memory_dsigmazz_dz(i,j,k) vz(i,j,k) = DELTAT_over_rho*(value_dsigmaxz_dx + value_dsigmayz_dy + value_dsigmazz_dz) + vz(i,j,k) enddo enddo enddo !$OMP END PARALLEL DO if (rank == rank_cut_plane) then ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! first derivative of a Gaussian source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term ! define location of the source i = ISOURCE j = JSOURCE ! here in this demo code we put the source in the middle of the model in the Z direction, ! i.e. in NZ/2, which means putting it in the cut plane (i.e. only the processor for which ! rank == rank_cut_plane will do it, and it will put it in its last point along Z, in NZ_LOCAL vx(i,j,NZ_LOCAL) = vx(i,j,NZ_LOCAL) + force_x * DELTAT / rho vy(i,j,NZ_LOCAL) = vy(i,j,NZ_LOCAL) + force_y * DELTAT / rho endif ! implement Dirichlet boundary conditions on the six edges of the grid !$OMP PARALLEL WORKSHARE ! xmin vx(1,:,:) = ZERO vy(1,:,:) = ZERO vz(1,:,:) = ZERO ! xmax vx(NX,:,:) = ZERO vy(NX,:,:) = ZERO vz(NX,:,:) = ZERO ! ymin vx(:,1,:) = ZERO vy(:,1,:) = ZERO vz(:,1,:) = ZERO ! ymax vx(:,NY,:) = ZERO vy(:,NY,:) = ZERO vz(:,NY,:) = ZERO !$OMP END PARALLEL WORKSHARE ! zmin if (rank == 0) then vx(:,:,1) = ZERO vy(:,:,1) = ZERO vz(:,:,1) = ZERO endif ! zmax if (rank == nb_procs-1) then vx(:,:,NZ_LOCAL) = ZERO vy(:,:,NZ_LOCAL) = ZERO vz(:,:,NZ_LOCAL) = ZERO endif ! store seismograms if (rank == rank_cut_plane) then do irec = 1,NREC sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec),NZ_LOCAL) sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec),NZ_LOCAL) enddo endif ! compute total energy in the medium (without the PML layers) total_energy_kinetic = ZERO total_energy_potential = ZERO kmin = 1 kmax = NZ_LOCAL if (rank == 0) kmin = NPOINTS_PML+1 if (rank == nb_procs-1) kmax = NZ_LOCAL-NPOINTS_PML !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz) & !$OMP SHARED(kmin,kmax,vx,vy,vz,sigmaxx,sigmayy,sigmazz, & !$OMP sigmaxy,sigmaxz,sigmayz) REDUCTION(+:total_energy_kinetic,total_energy_potential) do k = kmin,kmax do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! compute kinetic energy first, defined as 1/2 rho ||v||^2 ! in principle we should use rho_half_x_half_y instead of rho for vy ! in order to interpolate density at the right location in the staggered grid cell ! but in a homogeneous medium we can safely ignore it total_energy_kinetic = total_energy_kinetic + 0.5d0 * rho*( & vx(i,j,k)**2 + vy(i,j,k)**2 + vz(i,j,k)**2) ! add potential energy, defined as 1/2 epsilon_ij sigma_ij ! in principle we should interpolate the medium parameters at the right location ! in the staggered grid cell but in a homogeneous medium we can safely ignore it ! compute total field from split components epsilon_xx = (2.d0*(lambda + mu) * sigmaxx(i,j,k) - lambda * sigmayy(i,j,k) - & lambda*sigmazz(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu)) epsilon_yy = (2.d0*(lambda + mu) * sigmayy(i,j,k) - lambda * sigmaxx(i,j,k) - & lambda*sigmazz(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu)) epsilon_zz = (2.d0*(lambda + mu) * sigmazz(i,j,k) - lambda * sigmaxx(i,j,k) - & lambda*sigmayy(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu)) epsilon_xy = sigmaxy(i,j,k) / (2.d0 * mu) epsilon_xz = sigmaxz(i,j,k) / (2.d0 * mu) epsilon_yz = sigmayz(i,j,k) / (2.d0 * mu) total_energy_potential = total_energy_potential + & 0.5d0 * (epsilon_xx * sigmaxx(i,j,k) + epsilon_yy * sigmayy(i,j,k) + & epsilon_yy * sigmayy(i,j,k)+ 2.d0 * epsilon_xy * sigmaxy(i,j,k) + & 2.d0*epsilon_xz * sigmaxz(i,j,k)+2.d0*epsilon_yz * sigmayz(i,j,k)) enddo enddo enddo !$OMP END PARALLEL DO call MPI_REDUCE(total_energy_kinetic + total_energy_potential,total_energy(it),1, & MPI_DOUBLE_PRECISION,MPI_SUM,rank_cut_plane,MPI_COMM_WORLD,code) ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then call MPI_REDUCE(maxval(sqrt(vx(:,:,1:NZ_LOCAL)**2 + vy(:,:,1:NZ_LOCAL)**2 + & vz(:,:,1:NZ_LOCAL)**2)),Vsolidnorm,1,MPI_DOUBLE_PRECISION,MPI_MAX,rank_cut_plane,MPI_COMM_WORLD,code) if (rank == rank_cut_plane) then print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',Vsolidnorm print *,'Total energy = ',total_energy(it) ! check stability of the code, exit if unstable if (Vsolidnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up in solid' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) ! time_values(3): day of the month ! time_values(5): hour of the day ! time_values(6): minutes of the hour ! time_values(7): seconds of the minute ! time_values(8): milliseconds of the second ! this fails if we cross the end of the month time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + & 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0 ! elapsed time since beginning of the simulation tCPU = time_end - time_start int_tCPU = int(tCPU) ihours = int_tCPU / 3600 iminutes = (int_tCPU - 3600*ihours) / 60 iseconds = int_tCPU - 3600*ihours - 60*iminutes write(*,*) 'Elapsed time in seconds = ',tCPU write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it) write(*,*) ! write time stamp file to give information about progression of simulation write(outputname,"('timestamp',i6.6)") it open(unit=IOUT,file=outputname,status='unknown') write(IOUT,*) 'Time step # ',it write(IOUT,*) 'Time: ',sngl((it-1)*DELTAT),' seconds' write(IOUT,*) 'Max norm velocity vector V (m/s) = ',Vsolidnorm write(IOUT,*) 'Total energy = ',total_energy(it) write(IOUT,*) 'Elapsed time in seconds = ',tCPU write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it) close(IOUT) ! save seismograms print *,'saving seismograms' print * call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) call create_color_image(vx(:,:,NZ_LOCAL),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1) call create_color_image(vy(:,:,NZ_LOCAL),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2) endif endif ! --- end of time loop enddo if (rank == rank_cut_plane) then ! save seismograms call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),total_energy(it) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "CPML3D_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" t ''Total energy'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vz_receiver_001.eps"' write(20,*) 'plot "Vz_file_001.dat" t ''Vz C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vz_receiver_002.eps"' write(20,*) 'plot "Vz_file_002.dat" t ''Vz C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * endif ! close MPI program call MPI_FINALIZE(code) end program seismic_CPML_3D_iso_MPI_OpenMP !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT) implicit none integer nt,nrec double precision DELTAT double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_CPML_3D_viscoelastic_MPI.f90 ================================================ ! ! SEISMIC_CPML Version 1.2, April 2015. ! ! Copyright CNRS, France. ! Contributors: Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr ! and Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! April 2015: Dimitri Komatitsch added support for the SolvOpt algorithm to compute ! the attenuation parameters in an optimized way. If you use it please cite: ! ! @Article{BlKoChLoXi15, ! Title = {Positivity-preserving highly-accurate optimization of the {Z}ener viscoelastic model, with application ! to wave propagation in the presence of strong attenuation}, ! Author = {\'Emilie Blanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard and Zhinan Xie}, ! Journal = {Geophysical Journal International}, ! Year = {2015}, ! Note = {in press.}} ! ! This software is a computer program whose purpose is to solve ! the three-dimensional isotropic viscoelastic wave equation ! using a fourth order finite-difference method with Convolutional Perfectly Matched Layer (C-PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_visco_CPML_3D_MPI_OpenMP ! 3D fourth order viscoelastic finite-difference code in velocity and stress formulation ! with Convolutional-PML (C-PML) absorbing conditions using 2 mechanisms of attenuation ! with 6 equations per mechanism. ! Roland Martin, University of Pau, France, October 2009. ! based on the elastic code of Komatitsch and Martin, 2007. ! April 2015: Dimitri Komatitsch added support for the SolvOpt algorithm to compute ! the attenuation parameters in an optimized way. ! The fourth-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used. ! *BEWARE* that the attenuation model implemented below is that of J. M. Carcione, ! Seismic modeling in viscoelastic media, Geophysics, vol. 58(1), p. 110-120 (1993), which is NON causal, ! i.e., waves speed up instead of slowing down when turning attenuation on. ! This comes from the fact that in that model the relaxed state at zero frequency is used as a reference instead of ! the unrelaxed state at infinite frequency. These days a causal model should be used instead, ! i.e. one using the unrelaxed state at infinite frequency as a reference. ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! ! Parallel implementation based on MPI. ! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000). ! If you use this code for your own research, please cite some (or all) of these articles: ! ! @Article{BlKoChLoXi15, ! Title = {Positivity-preserving highly-accurate optimization of the {Z}ener viscoelastic model, with application ! to wave propagation in the presence of strong attenuation}, ! Author = {\'Emilie Blanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard and Zhinan Xie}, ! Journal = {Geophysical Journal International}, ! Year = {2015}, ! Note = {in press.}} ! ! @ARTICLE{MaKo09, ! author = {Roland Martin and Dimitri Komatitsch}, ! title = {An unsplit convolutional perfectly matched layer technique improved ! at grazing incidence for the viscoelastic wave equation}, ! journal = {Geophysical Journal International}, ! year = {2009}, ! volume = {179}, ! pages = {333-344}, ! number = {1}, ! doi = {10.1111/j.1365-246X.2009.04278.x}} ! ! @ARTICLE{MaKoEz08, ! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani}, ! title = {An unsplit convolutional perfectly matched layer improved at grazing ! incidence for seismic wave equation in poroelastic media}, ! journal = {Geophysics}, ! year = {2008}, ! volume = {73}, ! pages = {T51-T61}, ! number = {4}, ! doi = {10.1190/1.2939484}} ! ! @ARTICLE{MaKoGe08, ! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney}, ! title = {A variational formulation of a stabilized unsplit convolutional perfectly ! matched layer for the isotropic or anisotropic seismic wave equation}, ! journal = {Computer Modeling in Engineering and Sciences}, ! year = {2008}, ! volume = {37}, ! pages = {274-304}, ! number = {3}} ! ! @ARTICLE{KoMa07, ! author = {Dimitri Komatitsch and Roland Martin}, ! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved ! at grazing incidence for the seismic wave equation}, ! journal = {Geophysics}, ! year = {2007}, ! volume = {72}, ! number = {5}, ! pages = {SM155-SM167}, ! doi = {10.1190/1.2757586}} ! ! The original CPML technique for Maxwell's equations is described in: ! ! @ARTICLE{RoGe00, ! author = {J. A. Roden and S. D. Gedney}, ! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation ! of the {CFS}-{PML} for Arbitrary Media}, ! journal = {Microwave and Optical Technology Letters}, ! year = {2000}, ! volume = {27}, ! number = {5}, ! pages = {334-339}, ! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}} ! ! To display the results as color images in the selected 2D cut plane, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. use mpi implicit none ! total number of grid points in each direction of the grid integer, parameter :: NX = 210 integer, parameter :: NY = 800 integer, parameter :: NZ = 220 ! even number in order to cut along Z axis ! number of processes used in the MPI run ! and local number of points (for simplicity we cut the mesh along Z only) integer, parameter :: NPROC = 4 !! 20 integer, parameter :: NZ_LOCAL = NZ / NPROC ! size of a grid cell double precision, parameter :: DELTAX = 4.d0, ONE_OVER_DELTAX = 1.d0 / DELTAX double precision, parameter :: DELTAY = DELTAX, DELTAZ = DELTAX double precision, parameter :: ONE_OVER_DELTAY = ONE_OVER_DELTAX, ONE_OVER_DELTAZ = ONE_OVER_DELTAX double precision, parameter :: ONE=1.d0,TWO=2.d0, DIM=3.d0 ! P-velocity, S-velocity and density double precision, parameter :: cp = 3000.d0 double precision, parameter :: cs = 2000.d0 double precision, parameter :: rho = 2000.d0 double precision, parameter :: mu = rho*cs*cs double precision, parameter :: lambda = rho*(cp*cp - 2.d0*cs*cs) double precision, parameter :: lambdaplustwomu = rho*cp*cp ! total number of time steps integer, parameter :: NSTEP = 100000 ! time step in seconds double precision, parameter :: DELTAT = 4.d-4 ! parameters for the source double precision, parameter :: f0 = 18.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d7 ! parameters for attenuation ! number of standard linear solids integer, parameter :: N_SLS = 2 ! Qp approximately equal to 13, Qkappa approximately to 20 and Qmu / Qs approximately to 10 double precision, parameter :: QKappa_att = 20.d0, QMu_att = 10.d0 double precision, parameter :: f0_attenuation = 16 ! in Hz ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. logical, parameter :: USE_PML_ZMIN = .true. logical, parameter :: USE_PML_ZMAX = .true. ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! source ! integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1 integer, parameter :: ISOURCE = NPOINTS_PML+20 integer, parameter :: JSOURCE = NY / 5 + 1 double precision, parameter :: xsource = (ISOURCE) * DELTAX double precision, parameter :: ysource = (JSOURCE) * DELTAY ! angle of source force clockwise with respect to vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 0.d0 ! receivers integer, parameter :: NREC = 3 double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters double precision, parameter :: xfin = xsource ! last receiver x in meters double precision, parameter :: yfin = 300.d0 ! last receiver y in meters ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 10000 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! power to compute d0 profile double precision, parameter :: NPOWER = 2.d0 ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11 double precision, parameter :: K_MAX_PML = 7.d0 double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte ! arrays for the memory variables ! could declare these arrays in PML only to save a lot of memory, but proof of concept only here double precision, dimension(0:NX+1,0:NY+1,-1:NZ_LOCAL+2) :: & memory_dvx_dx, & memory_dvx_dy, & memory_dvx_dz, & memory_dvy_dx, & memory_dvy_dy, & memory_dvy_dz, & memory_dvz_dx, & memory_dvz_dy, & memory_dvz_dz, & memory_dsigmaxx_dx, & memory_dsigmayy_dy, & memory_dsigmazz_dz, & memory_dsigmaxy_dx, & memory_dsigmaxy_dy, & memory_dsigmaxz_dx, & memory_dsigmaxz_dz, & memory_dsigmayz_dy, & memory_dsigmayz_dz double precision :: & value_dvx_dx, & value_dvx_dy, & value_dvx_dz, & value_dvy_dx, & value_dvy_dy, & value_dvy_dz, & value_dvz_dx, & value_dvz_dy, & value_dvz_dz, & value_dsigmaxx_dx, & value_dsigmayy_dy, & value_dsigmazz_dz, & value_dsigmaxy_dx, & value_dsigmaxy_dy, & value_dsigmaxz_dx, & value_dsigmaxz_dz, & value_dsigmayz_dy, & value_dsigmayz_dz double precision :: duxdx,duxdy,duxdz,duydx,duydy,duydz,duzdx,duzdy,duzdz,div ! 1D arrays for the damping profiles double precision, dimension(1:NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half double precision, dimension(1:NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half double precision, dimension(1:NZ) :: d_z,K_z,alpha_z,a_z,b_z,d_z_half,K_z_half,alpha_z_half,a_z_half,b_z_half ! PML double precision thickness_PML_x,thickness_PML_y,thickness_PML_z double precision xoriginleft,xoriginright,yoriginbottom,yorigintop,zoriginbottom,zorigintop double precision Rcoef,d0_x,d0_y,d0_z,xval,yval,zval,abscissa_in_PML,abscissa_normalized ! change dimension of Z axis to add two planes for MPI double precision, dimension(0:NX+1,0:NY+1,-1:NZ_LOCAL+2) :: vx,vy,vz,sigmaxx,sigmayy,sigmazz,sigmaxy,sigmaxz,sigmayz double precision, dimension(0:NX+1,0:NY+1,-1:NZ_LOCAL+2) :: sigmaxx_R,sigmayy_R,sigmazz_R,sigmaxy_R,sigmaxz_R,sigmayz_R double precision, dimension(N_SLS,0:NX+1,0:NY+1,-1:NZ_LOCAL+2) :: e1,e11,e22,e12,e13,e23 integer, parameter :: number_of_arrays = 9 + 2*9 + 12 ! for the source double precision a,t,force_x,force_y,source_term ! for attenuation double precision :: f_min_attenuation, f_max_attenuation double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,tau_epsilon_nu2,tau_sigma_nu2 ! for receivers double precision distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec ! for seismograms double precision, dimension(NSTEP,NREC) :: sisvx,sisvy ! max amplitude for color snapshots double precision max_amplitudeVx double precision max_amplitudeVy ! for evolution of total energy in the medium double precision :: epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz double precision, dimension(NSTEP) :: total_energy,total_energy_kinetic,total_energy_potential double precision :: local_energy_kinetic,local_energy_potential integer :: irec ! precompute some parameters once and for all double precision, parameter :: DELTAT_lambda = DELTAT*lambda double precision, parameter :: DELTAT_mu = DELTAT*mu double precision, parameter :: DELTAT_lambdaplus2mu = DELTAT*lambdaplustwomu double precision, parameter :: DELTAT_over_rho = DELTAT/rho double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed double precision :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed double precision :: Un,Sn,Unp1,Mu_nu1,Mu_nu2 double precision :: phi_nu1(N_SLS) double precision :: phi_nu2(N_SLS) double precision :: tauinv,inv_tau_sigma_nu1(N_SLS) double precision :: taumin,taumax,tau1,tau2,tau3,tau4 double precision :: inv_tau_sigma_nu2(N_SLS) double precision :: tauinvUn integer :: i,j,k,it,it2 double precision :: Vsolidnorm,Courant_number ! timer to count elapsed time character(len=8) datein character(len=10) timein character(len=5) :: zone integer, dimension(8) :: time_values integer ihours,iminutes,iseconds,int_tCPU double precision :: time_start,time_end,tCPU ! names of the time stamp files character(len=150) outputname ! main I/O file integer, parameter :: IOUT = 41 ! array needed for MPI_RECV integer, dimension(MPI_STATUS_SIZE) :: message_status ! tag of the message to send integer, parameter :: message_tag = 0 ! number of values to send or receive integer, parameter :: number_of_values = 2*(NX+2)*(NY+2) integer :: nb_procs,rank,code,rank_cut_plane,kmin,kmax,kglobal,offset_k,k2begin,kminus1end integer :: sender_right_shift,receiver_right_shift,sender_left_shift,receiver_left_shift !--- !--- program starts here !--- ! start MPI processes call MPI_INIT(code) ! get total number of MPI processes in variable nb_procs call MPI_COMM_SIZE(MPI_COMM_WORLD, nb_procs, code) ! get the rank of our process from 0 (master) to nb_procs-1 (workers) call MPI_COMM_RANK(MPI_COMM_WORLD, rank, code) ! attenuation constants for standard linear solids ! nu1 is the dilatation/incompressibility mode (QKappa) ! nu2 is the shear mode (Qmu) ! array index (1) is the first standard linear solid, (2) is the second etc. ! from J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics, ! vol. 58(1), p. 110-120 (1993) for two memory-variable mechanisms (page 112). ! Beware: these values implement specific values of the quality factors: ! Qp approximately equal to 13, Qkappa approximately to 20 and Qmu / Qs approximately to 10, ! which means very high attenuation, see that paper for details. ! tau_epsilon_nu1(1) = 0.0334d0 ! tau_sigma_nu1(1) = 0.0303d0 ! tau_epsilon_nu2(1) = 0.0352d0 ! tau_sigma_nu2(1) = 0.0287d0 ! tau_epsilon_nu1(2) = 0.0028d0 ! tau_sigma_nu1(2) = 0.0025d0 ! tau_epsilon_nu2(2) = 0.0029d0 ! tau_sigma_nu2(2) = 0.0024d0 ! from J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation ! in a linear viscoelastic medium, Geophysical Journal International, ! vol. 95, p. 597-611 (1988) for two memory-variable mechanisms (page 604). ! Beware: these values implement specific values of the quality factors: ! Qkappa approximately to 27 and Qmu / Qs approximately to 20, ! which means very high attenuation, see that paper for details. ! tau_epsilon_nu1(1) = 0.0325305d0 ! tau_sigma_nu1(1) = 0.0311465d0 ! tau_epsilon_nu2(1) = 0.0332577d0 ! tau_sigma_nu2(1) = 0.0304655d0 ! tau_epsilon_nu1(2) = 0.0032530d0 ! tau_sigma_nu1(2) = 0.0031146d0 ! tau_epsilon_nu2(2) = 0.0033257d0 ! tau_sigma_nu2(2) = 0.0030465d0 ! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0) f_min_attenuation = exp(log(f0_attenuation)-log(12.d0)/2.d0) f_max_attenuation = 12.d0 * f_min_attenuation ! use new SolvOpt nonlinear optimization with constraints from Emilie Blanc, Bruno Lombard and Dimitri Komatitsch ! to compute attenuation mechanisms call compute_attenuation_coeffs(N_SLS,QKappa_att,f0_attenuation,f_min_attenuation,f_max_attenuation, & tau_epsilon_nu1,tau_sigma_nu1) call compute_attenuation_coeffs(N_SLS,QMu_att,f0_attenuation,f_min_attenuation,f_max_attenuation, & tau_epsilon_nu2,tau_sigma_nu2) if (rank == 0) then print * print *,'with new SolvOpt routine for attenuation:' print * print *,'N_SLS, QKappa_att, QMu_att = ',N_SLS, QKappa_att, QMu_att print *,'f0_attenuation,f_min_attenuation,f_max_attenuation = ',f0_attenuation,f_min_attenuation,f_max_attenuation print *,'tau_epsilon_nu1 = ',tau_epsilon_nu1 print *,'tau_sigma_nu1 = ',tau_sigma_nu1 print *,'tau_epsilon_nu2 = ',tau_epsilon_nu2 print *,'tau_sigma_nu2 = ',tau_sigma_nu2 print * endif tau1 = tau_sigma_nu1(1)/tau_epsilon_nu1(1) tau2 = tau_sigma_nu2(1)/tau_epsilon_nu2(1) tau3 = tau_sigma_nu1(2)/tau_epsilon_nu1(2) tau4 = tau_sigma_nu2(2)/tau_epsilon_nu2(2) taumax = max(1.d0/tau1,1.d0/tau2,1.d0/tau3,1.d0/tau4) taumin = min(1.d0/tau1,1.d0/tau2,1.d0/tau3,1.d0/tau4) inv_tau_sigma_nu1(1) = ONE / tau_sigma_nu1(1) inv_tau_sigma_nu2(1) = ONE / tau_sigma_nu2(1) inv_tau_sigma_nu1(2) = ONE / tau_sigma_nu1(2) inv_tau_sigma_nu2(2) = ONE / tau_sigma_nu2(2) phi_nu1(1) = (ONE - tau_epsilon_nu1(1)/tau_sigma_nu1(1)) / tau_sigma_nu1(1) phi_nu2(1) = (ONE - tau_epsilon_nu2(1)/tau_sigma_nu2(1)) / tau_sigma_nu2(1) phi_nu1(2) = (ONE - tau_epsilon_nu1(2)/tau_sigma_nu1(2)) / tau_sigma_nu1(2) phi_nu2(2) = (ONE - tau_epsilon_nu2(2)/tau_sigma_nu2(2)) / tau_sigma_nu2(2) Mu_nu1 = ONE - (ONE - tau_epsilon_nu1(1)/tau_sigma_nu1(1)) - (ONE - tau_epsilon_nu1(2)/tau_sigma_nu1(2)) Mu_nu2 = ONE - (ONE - tau_epsilon_nu2(1)/tau_sigma_nu2(1)) - (ONE - tau_epsilon_nu2(2)/tau_sigma_nu2(2)) ! slice number for the cut plane in the middle of the mesh rank_cut_plane = nb_procs/2 - 1 if (rank == rank_cut_plane) then print * print *,'3D elastic finite-difference code in velocity and stress formulation with C-PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print *,'NZ = ',NZ print * print *,'NZ_LOCAL = ',NZ_LOCAL print *,'NPROC = ',NPROC print * print *,'size of the model along X = ',(NX+1) * DELTAX print *,'size of the model along Y = ',(NY+1) * DELTAY print *,'size of the model along Y = ',(NZ+1) * DELTAZ print * print *,'Total number of grid points = ',(NX+2) * (NY+2) * (NZ+2) print *,'Number of points of all the arrays = ',dble(NX+2)*dble(NY+2)*dble(NZ+2)*number_of_arrays print *,'Size in GB of all the arrays = ',dble(NX+2)*dble(NY+2)*dble(NZ+2)*number_of_arrays*8.d0/(1024.d0*1024.d0*1024.d0) print * print *,'In each slice:' print * print *,'Total number of grid points = ',(NX+2) * (NY+2) * NZ_LOCAL print *,'Number of points of the arrays = ',dble(NX+2)*dble(NY+2)*dble(NZ_LOCAL)*number_of_arrays print *,'Size in GB of the arrays = ',dble(NX+2)*dble(NY+2)*dble(NZ_LOCAL)*number_of_arrays*8.d0/(1024.d0*1024.d0*1024.d0) print * endif ! check that code was compiled with the right number of slices if (nb_procs /= NPROC) then print *,'error in MPI number of slices: nb_procs,NPROC = ',nb_procs,NPROC,' but they should be equal' stop 'nb_procs must be equal to NPROC' endif ! we restrict ourselves to an even number of slices ! in order to have a cut plane in the middle of the mesh for visualization purposes if (mod(nb_procs,2) /= 0) stop 'nb_procs must be even' ! check that we can cut along Z in an exact number of slices if (mod(NZ,nb_procs) /= 0) stop 'NZ must be a multiple of nb_procs' ! check that a slice is at least as thick as a PML layer if (NZ_LOCAL < NPOINTS_PML) stop 'NZ_LOCAL must be greater than NPOINTS_PML' ! offset of this slice when we cut along Z offset_k = rank * NZ_LOCAL !--- define profile of absorption in PML region ! thickness of the PML layer in meters thickness_PML_x = NPOINTS_PML * DELTAX thickness_PML_y = NPOINTS_PML * DELTAY thickness_PML_z = NPOINTS_PML * DELTAZ ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.0001d0 ! check that NPOWER is okay if (NPOWER < 1) stop 'NPOWER must be greater than 1' ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0_x = - (NPOWER + 1) * cp *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_x) d0_y = - (NPOWER + 1) * cp *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_y) d0_z = - (NPOWER + 1) * cp *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_z) if (rank == rank_cut_plane) then print * print *,'d0_x = ',d0_x print *,'d0_y = ',d0_y print *,'d0_z = ',d0_z endif ! PML d_x(:) = ZERO d_x_half(:) = ZERO K_x(:) = 1.d0 K_x_half(:) = 1.d0 alpha_x(:) = ZERO alpha_x_half(:) = ZERO a_x(:) = ZERO a_x_half(:) = ZERO d_y(:) = ZERO d_y_half(:) = ZERO K_y(:) = 1.d0 K_y_half(:) = 1.d0 alpha_y(:) = ZERO alpha_y_half(:) = ZERO a_y(:) = ZERO a_y_half(:) = ZERO d_z(:) = ZERO d_z_half(:) = ZERO K_z(:) = 1.d0 K_z_half(:) = 1.d0 alpha_z(:) = ZERO alpha_z_half(:) = ZERO a_z(:) = ZERO a_z_half(:) = ZERO ! damping in the X direction ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = thickness_PML_x xoriginright = (NX-1)*DELTAX - thickness_PML_x do i = 1,NX ! abscissa of current grid point along the damping profile xval = DELTAX * dble(i-1) !---------- xmin edge if (USE_PML_XMIN) then ! define damping profile at the grid points abscissa_in_PML = xoriginleft - xval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- xmax edge if (USE_PML_XMAX) then ! define damping profile at the grid points abscissa_in_PML = xval - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_x d_x_half(i) = d0_x * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif ! just in case, for -5 at the end if (alpha_x(i) < ZERO) alpha_x(i) = ZERO if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT) b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i))) if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * & (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i))) enddo ! damping in the Y direction ! origin of the PML layer (position of right edge minus thickness, in meters) yoriginbottom = thickness_PML_y yorigintop = (NY-1)*DELTAY - thickness_PML_y do j = 1,NY ! abscissa of current grid point along the damping profile yval = DELTAY * dble(j-1) !---------- ymin edge if (USE_PML_YMIN) then ! define damping profile at the grid points abscissa_in_PML = yoriginbottom - yval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- ymax edge if (USE_PML_YMAX) then ! define damping profile at the grid points abscissa_in_PML = yval - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_y d_y_half(j) = d0_y * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT) b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j))) if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * & (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j))) enddo ! damping in the Z direction ! origin of the PML layer (position of right edge minus thickness, in meters) zoriginbottom = thickness_PML_z zorigintop = (NZ-1)*DELTAZ - thickness_PML_z do k = 1,NZ ! abscissa of current grid point along the damping profile zval = DELTAZ * dble(k-1) !---------- zmin edge if (USE_PML_ZMIN) then ! define damping profile at the grid points abscissa_in_PML = zoriginbottom - zval if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_z d_z(k) = d0_z * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_z(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_z(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = zoriginbottom - (zval + DELTAZ/2.d0) if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_z d_z_half(k) = d0_z * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_z_half(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_z_half(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif !---------- zmax edge if (USE_PML_ZMAX) then ! define damping profile at the grid points abscissa_in_PML = zval - zorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_z d_z(k) = d0_z * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_z(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_z(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif ! define damping profile at half the grid points abscissa_in_PML = zval + DELTAZ/2.d0 - zorigintop if (abscissa_in_PML >= ZERO) then abscissa_normalized = abscissa_in_PML / thickness_PML_z d_z_half(k) = d0_z * abscissa_normalized**NPOWER ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2 K_z_half(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER alpha_z_half(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized) endif endif b_z(k) = exp(- (d_z(k) / K_z(k) + alpha_z(k)) * DELTAT) b_z_half(k) = exp(- (d_z_half(k) / K_z_half(k) + alpha_z_half(k)) * DELTAT) ! this to avoid division by zero outside the PML if (abs(d_z(k)) > 1.d-6) a_z(k) = d_z(k) * (b_z(k) - 1.d0) / (K_z(k) * (d_z(k) + K_z(k) * alpha_z(k))) if (abs(d_z_half(k)) > 1.d-6) a_z_half(k) = d_z_half(k) * & (b_z_half(k) - 1.d0) / (K_z_half(k) * (d_z_half(k) + K_z_half(k) * alpha_z_half(k))) enddo if (rank == rank_cut_plane) then ! print position of the source print * print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print * print *,'There are ',nrec,' receivers' print * ! xspacerec = (xfin-xdeb) / dble(NREC-1) ! yspacerec = (yfin-ydeb) / dble(NREC-1) ! do irec=1,nrec ! xrec(irec) = xdeb + dble(irec-1)*xspacerec ! yrec(irec) = ydeb + dble(irec-1)*yspacerec ! enddo xrec(1)=xsource+500.d0 ! first receiver x in meters yrec(1)=ysource+500.d0 ! first receiver y in meters xrec(2)=xsource ! first receiver x in meters yrec(2)=ysource+2260.d0 ! first receiver y in meters xrec(3)=xsource+500.d0 ! first receiver x in meters yrec(3)=ysource+2260.d0 ! first receiver y in meters ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((DELTAX*dble(i) - xrec(irec))**2 + (DELTAY*dble(j) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo endif ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number = cp * dsqrt(taumax)* DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2 + 1.d0/DELTAZ**2) if (rank == rank_cut_plane) then print *,'Courant number is ',Courant_number print *,'Vpmax=',cp*dsqrt(taumax) endif if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable' print *, "Number of points per wavelength =",cs*dsqrt(taumin)/(2.5d0*f0)/DELTAX,'Vsmin=',cs*dsqrt(taumin) ! erase main arrays vx(:,:,:) = ZERO vy(:,:,:) = ZERO vz(:,:,:) = ZERO sigmaxy(:,:,:) = ZERO sigmayy(:,:,:) = ZERO sigmazz(:,:,:) = ZERO sigmaxz(:,:,:) = ZERO sigmazz(:,:,:) = ZERO sigmayz(:,:,:) = ZERO e1(:,:,:,:) = ZERO e11(:,:,:,:) = ZERO e12(:,:,:,:) = ZERO e13(:,:,:,:) = ZERO e23(:,:,:,:) = ZERO e22(:,:,:,:) = ZERO ! PML memory_dvx_dx(:,:,:) = ZERO memory_dvx_dy(:,:,:) = ZERO memory_dvx_dz(:,:,:) = ZERO memory_dvy_dx(:,:,:) = ZERO memory_dvy_dy(:,:,:) = ZERO memory_dvy_dz(:,:,:) = ZERO memory_dvz_dx(:,:,:) = ZERO memory_dvz_dy(:,:,:) = ZERO memory_dvz_dz(:,:,:) = ZERO memory_dsigmaxx_dx(:,:,:) = ZERO memory_dsigmayy_dy(:,:,:) = ZERO memory_dsigmazz_dz(:,:,:) = ZERO memory_dsigmaxy_dx(:,:,:) = ZERO memory_dsigmaxy_dy(:,:,:) = ZERO memory_dsigmaxz_dx(:,:,:) = ZERO memory_dsigmaxz_dz(:,:,:) = ZERO memory_dsigmayz_dy(:,:,:) = ZERO memory_dsigmayz_dz(:,:,:) = ZERO ! erase seismograms sisvx(:,:) = ZERO sisvy(:,:) = ZERO ! initialize total energy total_energy(:) = ZERO total_energy_kinetic(:) = ZERO total_energy_potential(:) = ZERO call date_and_time(datein,timein,zone,time_values) ! time_values(3): day of the month ! time_values(5): hour of the day ! time_values(6): minutes of the hour ! time_values(7): seconds of the minute ! time_values(8): milliseconds of the second ! this fails if we cross the end of the month time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + & 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0 !--- ! we receive from the process on the left, and send to the process on the right sender_right_shift = rank - 1 receiver_right_shift = rank + 1 ! if we are the first process, there is no neighbor on the left if (rank == 0) sender_right_shift = MPI_PROC_NULL ! if we are the last process, there is no neighbor on the right if (rank == nb_procs - 1) receiver_right_shift = MPI_PROC_NULL !--- ! we receive from the process on the right, and send to the process on the left sender_left_shift = rank + 1 receiver_left_shift = rank - 1 ! if we are the first process, there is no neighbor on the left if (rank == 0) receiver_left_shift = MPI_PROC_NULL ! if we are the last process, there is no neighbor on the right if (rank == nb_procs - 1) sender_left_shift = MPI_PROC_NULL k2begin = 1 if (rank == 0) k2begin = 2 kminus1end = NZ_LOCAL if (rank == nb_procs - 1) kminus1end = NZ_LOCAL - 1 !--- !--- beginning of time loop !--- do it = 1,NSTEP if (rank == rank_cut_plane .and. mod(it,20) == 0) print *,'it = ',it !---------------------- ! compute stress sigma !---------------------- ! vx(k+1), left shift call MPI_SENDRECV(vx(:,:,1:2),number_of_values,MPI_DOUBLE_PRECISION, & receiver_left_shift,message_tag,vx(:,:,NZ_LOCAL+1:NZ_LOCAL+2),number_of_values, & MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code) ! vy(k+1), left shift call MPI_SENDRECV(vy(:,:,1:2),number_of_values,MPI_DOUBLE_PRECISION, & receiver_left_shift,message_tag,vy(:,:,NZ_LOCAL+1:NZ_LOCAL+2),number_of_values, & MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code) ! vz(k-1), right shift call MPI_SENDRECV(vz(:,:,NZ_LOCAL-1:NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, & receiver_right_shift,message_tag,vz(:,:,-1:0),number_of_values, & MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code) do k=k2begin,NZ_LOCAL kglobal = k + offset_k do j=2,NY do i=1,NX-1 mul_relaxed = mu lambdal_relaxed = lambda lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed lambdal_unrelaxed = (lambdal_relaxed + 2.d0/DIM*mul_relaxed) * Mu_nu1 - 2.d0/DIM*mul_relaxed * Mu_nu2 mul_unrelaxed = mul_relaxed * Mu_nu2 lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed value_dvx_dx = (27.d0*vx(i+1,j,k)-27.d0*vx(i,j,k)-vx(i+2,j,k)+vx(i-1,j,k)) * ONE_OVER_DELTAX/24.d0 value_dvy_dy = (27.d0*vy(i,j,k)-27.d0*vy(i,j-1,k)-vy(i,j+1,k)+vy(i,j-2,k)) * ONE_OVER_DELTAY/24.d0 value_dvz_dz = (27.d0*vz(i,j,k)-27.d0*vz(i,j,k-1)-vz(i,j,k+1)+vz(i,j,k-2)) * ONE_OVER_DELTAZ/24.d0 memory_dvx_dx(i,j,k) = b_x_half(i) * memory_dvx_dx(i,j,k) + a_x_half(i) * value_dvx_dx memory_dvy_dy(i,j,k) = b_y(j) * memory_dvy_dy(i,j,k) + a_y(j) * value_dvy_dy memory_dvz_dz(i,j,k) = b_z(kglobal) * memory_dvz_dz(i,j,k) + a_z(kglobal) * value_dvz_dz duxdx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j,k) duydy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j,k) duzdz = value_dvz_dz / K_z(kglobal) + memory_dvz_dz(i,j,k) div=duxdx+duydy+duzdz ! evolution e1(1) tauinv = - inv_tau_sigma_nu1(1) Un = e1(1,i,j,k) Sn = div * phi_nu1(1) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e1(1,i,j,k) = Unp1 ! evolution e1(2) tauinv = - inv_tau_sigma_nu1(2) Un = e1(2,i,j,k) Sn = div * phi_nu1(2) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e1(2,i,j,k) = Unp1 ! evolution e11(1) tauinv = - inv_tau_sigma_nu2(1) Un = e11(1,i,j,k) Sn = (duxdx - div/DIM) * phi_nu2(1) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e11(1,i,j,k) = Unp1 ! evolution e11(2) tauinv = - inv_tau_sigma_nu2(2) Un = e11(2,i,j,k) Sn = (duxdx - div/DIM) * phi_nu2(2) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e11(2,i,j,k) = Unp1 ! evolution e22(1) tauinv = - inv_tau_sigma_nu2(1) Un = e22(1,i,j,k) Sn = (duydy - div/DIM) * phi_nu2(1) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e22(1,i,j,k) = Unp1 ! evolution e22(2) tauinv = - inv_tau_sigma_nu2(2) Un = e22(2,i,j,k) Sn = (duydy - div/DIM) * phi_nu2(2) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e22(2,i,j,k) = Unp1 !add the memory variables using the relaxed parameters (Carcione page 111) ! : there is a bug in Carcione's equation for sigma_zz sigmaxx(i,j,k) = sigmaxx(i,j,k)+deltat*((lambdal_relaxed + 2.d0/DIM*mul_relaxed)* & (e1(1,i,j,k) + e1(2,i,j,k)) + TWO * mul_relaxed * (e11(1,i,j,k) + e11(2,i,j,k))) sigmayy(i,j,k) = sigmayy(i,j,k)+deltat*((lambdal_relaxed + 2.d0/DIM*mul_relaxed)* & (e1(1,i,j,k) + e1(2,i,j,k)) + TWO * mul_relaxed * (e22(1,i,j,k) + e22(2,i,j,k))) sigmazz(i,j,k) = sigmazz(i,j,k)+deltat*((lambdal_relaxed + 2.d0*mul_relaxed)* & (e1(1,i,j,k) + e1(2,i,j,k)) - TWO/DIM * mul_relaxed * (e11(1,i,j,k) + e11(2,i,j,k)& +e22(1,i,j,k) + e22(2,i,j,k))) ! compute the stress using the unrelaxed Lame parameters (Carcione page 111) sigmaxx(i,j,k) = sigmaxx(i,j,k) + & (lambdalplus2mul_unrelaxed * (duxdx) + & lambdal_unrelaxed* (duydy) + & lambdal_unrelaxed* (duzdz) )* DELTAT sigmayy(i,j,k) = sigmayy(i,j,k) + & (lambdal_unrelaxed * (duxdx) + & lambdalplus2mul_unrelaxed* (duydy) +& lambdal_unrelaxed* (duzdz)) * DELTAT sigmazz(i,j,k) = sigmazz(i,j,k) + & (lambdal_unrelaxed * (duxdx) + & lambdal_unrelaxed* (duydy) + & lambdalplus2mul_unrelaxed* (duzdz)) * DELTAT sigmaxx_R(i,j,k) = sigmaxx_R(i,j,k) + & (lambdalplus2mul_relaxed * (duxdx) + & lambdal_relaxed* (duydy) + & lambdal_relaxed* (duzdz) )* DELTAT sigmayy_R(i,j,k) = sigmayy_R(i,j,k) + & (lambdal_relaxed * (duxdx) + & lambdalplus2mul_relaxed* (duydy) +& lambdal_relaxed* (duzdz)) * DELTAT sigmazz_R(i,j,k) = sigmazz_R(i,j,k) + & (lambdal_relaxed * (duxdx) + & lambdal_relaxed* (duydy) + & lambdalplus2mul_relaxed* (duzdz)) * DELTAT enddo enddo enddo do k=1,NZ_LOCAL do j=1,NY-1 do i=2,NX mul_relaxed = mu mul_unrelaxed = mul_relaxed * Mu_nu2 value_dvy_dx = (27.d0*vy(i,j,k)-27.d0*vy(i-1,j,k)-vy(i+1,j,k)+vy(i-2,j,k)) * ONE_OVER_DELTAX/24.d0 value_dvx_dy = (27.d0*vx(i,j+1,k)-27.d0*vx(i,j,k)-vx(i,j+2,k)+vx(i,j-1,k)) * ONE_OVER_DELTAY/24.d0 memory_dvy_dx(i,j,k) = b_x(i) * memory_dvy_dx(i,j,k) + a_x(i) * value_dvy_dx memory_dvx_dy(i,j,k) = b_y_half(j) * memory_dvx_dy(i,j,k) + a_y_half(j) * value_dvx_dy duydx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j,k) duxdy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j,k) ! evolution e12(1) tauinv = - inv_tau_sigma_nu2(1) Un = e12(1,i,j,k) Sn = (duxdy+duydx) * phi_nu2(1) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e12(1,i,j,k) = Unp1 ! evolution e12(2) tauinv = - inv_tau_sigma_nu2(2) Un = e12(2,i,j,k) Sn = (duxdy+duydx) * phi_nu2(2) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e12(2,i,j,k) = Unp1 sigmaxy(i,j,k) = sigmaxy(i,j,k)+deltat*mul_relaxed * (e12(1,i,j,k) + e12(2,i,j,k)) sigmaxy(i,j,k) = sigmaxy(i,j,k) + & mul_unrelaxed * (duxdy+duydx) * DELTAT sigmaxy_R(i,j,k) = sigmaxy_R(i,j,k) + & mul_relaxed * (duxdy+duydx) * DELTAT enddo enddo enddo do k=1,kminus1end kglobal = k + offset_k do j=1,NY do i=2,NX mul_relaxed = mu mul_unrelaxed = mul_relaxed * Mu_nu2 value_dvz_dx = (27.d0*vz(i,j,k)-27.d0*vz(i-1,j,k)-vz(i+1,j,k)+vz(i-2,j,k)) * ONE_OVER_DELTAX/24.d0 value_dvx_dz = (27.d0*vx(i,j,k+1)-27.d0*vx(i,j,k)-vx(i,j,k+2)+vx(i,j,k-1)) * ONE_OVER_DELTAZ/24.d0 memory_dvz_dx(i,j,k) = b_x(i) * memory_dvz_dx(i,j,k) + a_x(i) * value_dvz_dx memory_dvx_dz(i,j,k) = b_z_half(kglobal) * memory_dvx_dz(i,j,k) + a_z_half(kglobal) * value_dvx_dz duzdx = value_dvz_dx / K_x(i) + memory_dvz_dx(i,j,k) duxdz = value_dvx_dz / K_z_half(kglobal) + memory_dvx_dz(i,j,k) ! evolution e13(1) tauinv = - inv_tau_sigma_nu2(1) Un = e13(1,i,j,k) Sn = (duxdz+duzdx) * phi_nu2(1) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e13(1,i,j,k) = Unp1 ! evolution e13(2) tauinv = - inv_tau_sigma_nu2(2) Un = e13(2,i,j,k) Sn = (duxdz+duzdx) * phi_nu2(2) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e13(2,i,j,k) = Unp1 sigmaxz(i,j,k) = sigmaxz(i,j,k)+deltat*mul_relaxed * (e13(1,i,j,k) + e13(2,i,j,k)) sigmaxz(i,j,k) = sigmaxz(i,j,k) + & mul_unrelaxed * (duxdz+duzdx) * DELTAT sigmaxz_R(i,j,k) = sigmaxz_R(i,j,k) + & mul_relaxed * (duxdz+duzdx) * DELTAT enddo enddo do j=1,NY-1 do i=1,NX mul_relaxed = mu mul_unrelaxed = mul_relaxed * Mu_nu2 value_dvz_dy = (27.d0*vz(i,j+1,k)-27.d0*vz(i,j,k)-vz(i,j+2,k)+vz(i,j-1,k)) * ONE_OVER_DELTAY/24.d0 value_dvy_dz = (27.d0*vy(i,j,k+1)-27.d0*vy(i,j,k)-vy(i,j,k+2)+vy(i,j,k-1)) * ONE_OVER_DELTAZ/24.d0 memory_dvz_dy(i,j,k) = b_y_half(j) * memory_dvz_dy(i,j,k) + a_y_half(j) * value_dvz_dy memory_dvy_dz(i,j,k) = b_z_half(kglobal) * memory_dvy_dz(i,j,k) + a_z_half(kglobal) * value_dvy_dz duzdy = value_dvz_dy / K_y_half(j) + memory_dvz_dy(i,j,k) duydz = value_dvy_dz / K_z_half(kglobal) + memory_dvy_dz(i,j,k) ! evolution e23(1) tauinv = - inv_tau_sigma_nu2(1) Un = e23(1,i,j,k) Sn = (duydz+duzdy) * phi_nu2(1) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e23(1,i,j,k) = Unp1 ! evolution e23(2) tauinv = - inv_tau_sigma_nu2(2) Un = e23(2,i,j,k) Sn = (duydz+duzdy) * phi_nu2(2) tauinvUn = tauinv * Un Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv) e23(2,i,j,k) = Unp1 sigmayz(i,j,k) = sigmayz(i,j,k)+deltat*mul_relaxed * (e23(1,i,j,k) + e23(2,i,j,k)) sigmayz(i,j,k) = sigmayz(i,j,k) + & mul_unrelaxed * (duydz+duzdy) * DELTAT sigmayz_R(i,j,k) = sigmayz_R(i,j,k) + & mul_relaxed * (duydz+duzdy) * DELTAT enddo enddo enddo !------------------ ! compute velocity !------------------ ! sigmazz(k+1), left shift call MPI_SENDRECV(sigmazz(:,:,1:2),number_of_values,MPI_DOUBLE_PRECISION, & receiver_left_shift,message_tag,sigmazz(:,:,NZ_LOCAL+1:NZ_LOCAL+2),number_of_values, & MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code) ! sigmayz(k-1), right shift call MPI_SENDRECV(sigmayz(:,:,NZ_LOCAL-1:NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, & receiver_right_shift,message_tag,sigmayz(:,:,-1:0),number_of_values, & MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code) ! sigmaxz(k-1), right shift call MPI_SENDRECV(sigmaxz(:,:,NZ_LOCAL-1:NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, & receiver_right_shift,message_tag,sigmaxz(:,:,-1:0),number_of_values, & MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code) do k=k2begin,NZ_LOCAL kglobal = k + offset_k do j=2,NY do i=2,NX value_dsigmaxx_dx = (27.d0*sigmaxx(i,j,k)-27.d0*sigmaxx(i-1,j,k)-sigmaxx(i+1,j,k)+sigmaxx(i-2,j,k)) * ONE_OVER_DELTAX/24.d0 value_dsigmaxy_dy = (27.d0*sigmaxy(i,j,k)-27.d0*sigmaxy(i,j-1,k)-sigmaxy(i,j+1,k)+sigmaxy(i,j-2,k)) * ONE_OVER_DELTAY/24.d0 value_dsigmaxz_dz = (27.d0*sigmaxz(i,j,k)-27.d0*sigmaxz(i,j,k-1)-sigmaxz(i,j,k+1)+sigmaxz(i,j,k-2)) * ONE_OVER_DELTAZ/24.d0 memory_dsigmaxx_dx(i,j,k) = b_x(i) * memory_dsigmaxx_dx(i,j,k) + a_x(i) * value_dsigmaxx_dx memory_dsigmaxy_dy(i,j,k) = b_y(j) * memory_dsigmaxy_dy(i,j,k) + a_y(j) * value_dsigmaxy_dy memory_dsigmaxz_dz(i,j,k) = b_z(kglobal) * memory_dsigmaxz_dz(i,j,k) + a_z(kglobal) * value_dsigmaxz_dz value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j,k) value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j,k) value_dsigmaxz_dz = value_dsigmaxz_dz / K_z(kglobal) + memory_dsigmaxz_dz(i,j,k) vx(i,j,k) = DELTAT_over_rho*(value_dsigmaxx_dx + value_dsigmaxy_dy + value_dsigmaxz_dz) + vx(i,j,k) enddo enddo do j=1,NY-1 do i=1,NX-1 value_dsigmaxy_dx = (27.d0*sigmaxy(i+1,j,k)-27.d0*sigmaxy(i,j,k)-sigmaxy(i+2,j,k)+sigmaxy(i-1,j,k)) * ONE_OVER_DELTAX/24.d0 value_dsigmayy_dy = (27.d0*sigmayy(i,j+1,k)-27.d0*sigmayy(i,j,k)-sigmayy(i,j+2,k)+sigmayy(i,j-1,k)) * ONE_OVER_DELTAY/24.d0 value_dsigmayz_dz = (27.d0*sigmayz(i,j,k)-27.d0*sigmayz(i,j,k-1)-sigmayz(i,j,k+1)+sigmayz(i,j,k-2)) * ONE_OVER_DELTAZ/24.d0 memory_dsigmaxy_dx(i,j,k) = b_x_half(i) * memory_dsigmaxy_dx(i,j,k) + a_x_half(i) * value_dsigmaxy_dx memory_dsigmayy_dy(i,j,k) = b_y_half(j) * memory_dsigmayy_dy(i,j,k) + a_y_half(j) * value_dsigmayy_dy memory_dsigmayz_dz(i,j,k) = b_z(kglobal) * memory_dsigmayz_dz(i,j,k) + a_z(kglobal) * value_dsigmayz_dz value_dsigmaxy_dx = value_dsigmaxy_dx / K_x_half(i) + memory_dsigmaxy_dx(i,j,k) value_dsigmayy_dy = value_dsigmayy_dy / K_y_half(j) + memory_dsigmayy_dy(i,j,k) value_dsigmayz_dz = value_dsigmayz_dz / K_z(kglobal) + memory_dsigmayz_dz(i,j,k) vy(i,j,k) = DELTAT_over_rho*(value_dsigmaxy_dx + value_dsigmayy_dy + value_dsigmayz_dz) + vy(i,j,k) enddo enddo enddo do k=1,kminus1end kglobal = k + offset_k do j=2,NY do i=1,NX-1 value_dsigmaxz_dx = (27.d0*sigmaxz(i+1,j,k)-27.d0*sigmaxz(i,j,k)-sigmaxz(i+2,j,k)+sigmaxz(i-1,j,k)) * ONE_OVER_DELTAX/24.d0 value_dsigmayz_dy = (27.d0*sigmayz(i,j,k)-27.d0*sigmayz(i,j-1,k)-sigmayz(i,j+1,k)+sigmayz(i,j-2,k)) * ONE_OVER_DELTAY/24.d0 value_dsigmazz_dz = (27.d0*sigmazz(i,j,k+1)-27.d0*sigmazz(i,j,k)-sigmazz(i,j,k+2)+sigmazz(i,j,k-1)) * ONE_OVER_DELTAZ/24.d0 memory_dsigmaxz_dx(i,j,k) = b_x_half(i) * memory_dsigmaxz_dx(i,j,k) + a_x_half(i) * value_dsigmaxz_dx memory_dsigmayz_dy(i,j,k) = b_y(j) * memory_dsigmayz_dy(i,j,k) + a_y(j) * value_dsigmayz_dy memory_dsigmazz_dz(i,j,k) = b_z_half(kglobal) * memory_dsigmazz_dz(i,j,k) + a_z_half(kglobal) * value_dsigmazz_dz value_dsigmaxz_dx = value_dsigmaxz_dx / K_x_half(i) + memory_dsigmaxz_dx(i,j,k) value_dsigmayz_dy = value_dsigmayz_dy / K_y(j) + memory_dsigmayz_dy(i,j,k) value_dsigmazz_dz = value_dsigmazz_dz / K_z_half(kglobal) + memory_dsigmazz_dz(i,j,k) vz(i,j,k) = DELTAT_over_rho*(value_dsigmaxz_dx + value_dsigmayz_dy + value_dsigmazz_dz) + vz(i,j,k) enddo enddo enddo if (rank == rank_cut_plane) then ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! first derivative of a Gaussian source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term ! define location of the source i = ISOURCE j = JSOURCE vx(i,j,NZ_LOCAL) = vx(i,j,NZ_LOCAL) + force_x * DELTAT / rho vy(i,j,NZ_LOCAL) = vy(i,j,NZ_LOCAL) + force_y * DELTAT / rho endif ! implement Dirichlet boundary conditions on the six edges of the grid ! xmin vx(0:1,:,:) = ZERO vy(0:1,:,:) = ZERO vz(0:1,:,:) = ZERO ! xmax vx(NX:NX+1,:,:) = ZERO vy(NX:NX+1,:,:) = ZERO vz(NX:NX+1,:,:) = ZERO ! ymin vx(:,0:1,:) = ZERO vy(:,0:1,:) = ZERO vz(:,0:1,:) = ZERO ! ymax vx(:,NY:NY+1,:) = ZERO vy(:,NY:NY+1,:) = ZERO vz(:,NY:NY+1,:) = ZERO ! zmin if (rank == 0) then vx(:,:,0:1) = ZERO vy(:,:,0:1) = ZERO vz(:,:,0:1) = ZERO endif ! zmax if (rank == nb_procs-1) then vx(:,:,NZ_LOCAL:NZ_LOCAL+1) = ZERO vy(:,:,NZ_LOCAL:NZ_LOCAL+1) = ZERO vz(:,:,NZ_LOCAL:NZ_LOCAL+1) = ZERO endif ! store seismograms if (rank == rank_cut_plane) then do irec = 1,NREC sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec),NZ_LOCAL) sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec),NZ_LOCAL) enddo endif ! compute total energy in the medium (without the PML layers) local_energy_kinetic = ZERO local_energy_potential = ZERO kmin = 1 kmax = NZ_LOCAL if (rank == 0) kmin = NPOINTS_PML if (rank == nb_procs-1) kmax = NZ_LOCAL-NPOINTS_PML+1 do k = kmin,kmax do j = NPOINTS_PML, NY-NPOINTS_PML+1 do i = NPOINTS_PML, NX-NPOINTS_PML+1 ! compute kinetic energy first, defined as 1/2 rho ||v||^2 ! in principle we should use rho_half_x_half_y instead of rho for vy ! in order to interpolate density at the right location in the staggered grid cell ! but in a homogeneous medium we can safely ignore it local_energy_kinetic = local_energy_kinetic + 0.5d0 * rho*( & vx(i,j,k)**2 + vy(i,j,k)**2 + vz(i,j,k)**2) ! add potential energy, defined as 1/2 epsilon_ij sigma_ij ! in principle we should interpolate the medium parameters at the right location ! in the staggered grid cell but in a homogeneous medium we can safely ignore it ! compute total field from split components epsilon_xx = (2.d0*(lambda + mu) * sigmaxx(i,j,k) - lambda * sigmayy(i,j,k) - & lambda*sigmazz(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu)) epsilon_yy = (2.d0*(lambda + mu) * sigmayy(i,j,k) - lambda * sigmaxx(i,j,k) - & lambda*sigmazz(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu)) epsilon_zz = (2.d0*(lambda + mu) * sigmazz(i,j,k) - lambda * sigmaxx(i,j,k) - & lambda*sigmayy(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu)) epsilon_xy = sigmaxy_R(i,j,k) / (2.d0 * mu) epsilon_xz = sigmaxz_R(i,j,k) / (2.d0 * mu) epsilon_yz = sigmayz_R(i,j,k) / (2.d0 * mu) local_energy_potential = local_energy_potential + & 0.5d0 * (epsilon_xx * sigmaxx_R(i,j,k) + epsilon_yy * sigmayy_R(i,j,k) + & epsilon_yy * sigmayy_R(i,j,k)+ 2.d0 * epsilon_xy * sigmaxy_R(i,j,k) + & 2.d0*epsilon_xz * sigmaxz_R(i,j,k)+2.d0*epsilon_yz * sigmayz_R(i,j,k)) enddo enddo enddo call MPI_REDUCE(local_energy_kinetic + local_energy_potential,total_energy(it),1, & MPI_DOUBLE_PRECISION,MPI_SUM,rank_cut_plane,MPI_COMM_WORLD,code) call MPI_REDUCE(local_energy_kinetic,total_energy_kinetic(it),1, & MPI_DOUBLE_PRECISION,MPI_SUM,rank_cut_plane,MPI_COMM_WORLD,code) call MPI_REDUCE(local_energy_potential,total_energy_potential(it),1, & MPI_DOUBLE_PRECISION,MPI_SUM,rank_cut_plane,MPI_COMM_WORLD,code) ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then call MPI_REDUCE(maxval(sqrt(vx(:,:,1:NZ_LOCAL)**2 + vy(:,:,1:NZ_LOCAL)**2 + & vz(:,:,1:NZ_LOCAL)**2)),Vsolidnorm,1,MPI_DOUBLE_PRECISION,MPI_MAX,rank_cut_plane,MPI_COMM_WORLD,code) if (rank == rank_cut_plane) then print *,'Time step # ',it,' out of ',NSTEP,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',Vsolidnorm print *,'Total energy = ',total_energy(it) ! check stability of the code, exit if unstable if (Vsolidnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up in solid' ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) ! time_values(3): day of the month ! time_values(5): hour of the day ! time_values(6): minutes of the hour ! time_values(7): seconds of the minute ! time_values(8): milliseconds of the second ! this fails if we cross the end of the month time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + & 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0 ! elapsed time since beginning of the simulation tCPU = time_end - time_start int_tCPU = int(tCPU) ihours = int_tCPU / 3600 iminutes = (int_tCPU - 3600*ihours) / 60 iseconds = int_tCPU - 3600*ihours - 60*iminutes write(*,*) 'Elapsed time in seconds = ',tCPU write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it) write(*,*) ! write time stamp file to give information about progression of simulation write(outputname,"('timestamp',i6.6)") it open(unit=IOUT,file=outputname,status='unknown') write(IOUT,*) 'Time step # ',it write(IOUT,*) 'Time: ',sngl((it-1)*DELTAT),' seconds' write(IOUT,*) 'Max norm velocity vector V (m/s) = ',Vsolidnorm write(IOUT,*) 'Total energy = ',total_energy(it) write(IOUT,*) 'Elapsed time in seconds = ',tCPU write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it) close(IOUT) ! save energy open(unit=21,file='energy.dat',status='unknown') do it2=1,NSTEP write(21,*) sngl(dble(it2-1)*DELTAT),sngl(total_energy_kinetic(it2)), & sngl(total_energy_potential(it2)),sngl(total_energy(it2)) enddo close(21) ! save seismograms print *,'saving seismograms' print * call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT,t0) call create_color_image(vx(1:NX,1:NY,NZ_LOCAL),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1,max_amplitudeVx) call create_color_image(vy(1:NX,1:NY,NZ_LOCAL),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2,max_amplitudeVy) endif endif ! --- end of time loop enddo if (rank == rank_cut_plane) then ! save seismograms call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT,t0) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "CPML3D_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" t ''Total energy'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vz_receiver_001.eps"' write(20,*) 'plot "Vz_file_001.dat" t ''Vz C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vz_receiver_002.eps"' write(20,*) 'plot "Vz_file_002.dat" t ''Vz C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * endif ! close MPI program call MPI_FINALIZE(code) end program seismic_visco_CPML_3D_MPI_OpenMP ! include the SolvOpt routines include "attenuation_model_with_SolvOpt.f90" !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT,t0) implicit none integer nt,nrec double precision DELTAT,t0 double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT-t0),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT-t0),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number,max_amplitude) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=150) :: file_name ! character(len=150) :: system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it ! write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it ! write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude if (it <= 2301) max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_PML_Collino_2D_anisotropic_fourth.f90 ================================================ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Program seismic_PML_Collino_2D_ani_4th, fourth-order accurate in space and second-order accurate in time ! ! This anisotropic code with classical split PML is modified by Jingyi Chen from program 'seismic_PML_Collino_2D_iso' ! written by Dimitri Komatitsch. ! ! Jingyi Chen, Department of Geosciences, University of Tulsa, USA. Email: jingyi-chen AT utulsa DOT edu ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributors: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! Jingyi Chen, jingyi-chen AT utulsa DOT edu ! ! This software is a computer program whose purpose is to solve ! the two-dimensional anisotropic elastic wave equation ! using a finite-difference method with classical split Perfectly Matched ! Layer (PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_PML_Collino_2D_ani_4th ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! ! PML implemented in the two directions (x and y directions). ! ! Version 1.0 July, 2010 ! Jingyi Chen,the Department of Geosciences, The University of Tulsa, USA. Email: jingyi-chen@utulsa.edu ! ! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! ! ! To display the 2D results as color images, use: ! ! " display image* " or " gimp image* " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! total number of grid points in each direction of the grid integer, parameter :: NX = 401 integer, parameter :: NY = 401 ! size of a grid cell double precision, parameter :: h = 5.d0 ! flags to add PML layers to the edges of the grid logical, parameter :: USE_PML_XMIN = .true. logical, parameter :: USE_PML_XMAX = .true. logical, parameter :: USE_PML_YMIN = .true. logical, parameter :: USE_PML_YMAX = .true. ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! model I from Becache, Fauqueux and Joly, which is stable ! Model was also used in Dimitri Komatitsch and Roland Martin (2007),geophysics double precision, parameter :: scale_aniso = 1.d10 double precision, parameter :: c11 = 4.d0 * scale_aniso double precision, parameter :: c12 = 3.8d0 * scale_aniso double precision, parameter :: c22 = 20.d0 * scale_aniso double precision, parameter :: c33 = 2.d0 * scale_aniso double precision, parameter :: rho = 4000.d0 ! used to be 1. ! double precision, parameter :: f0 = 25.d0 ! total number of time steps integer, parameter :: NSTEP = 3000 ! time step in seconds double precision, parameter :: DELTAT = 1.d-3/2 double precision, parameter :: ONE_OVER_DELTAT = 1.d0 / DELTAT ! parameters for the source double precision, parameter :: f0 = 25.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d7 ! source integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1 integer, parameter :: JSOURCE = 2 * NY / 3 + 1 double precision, parameter :: xsource = (ISOURCE - 1) * h double precision, parameter :: ysource = (JSOURCE - 1) * h ! angle of source force clockwise with respect to vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 135.d0 ! receivers integer, parameter :: NREC = 2 double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters double precision, parameter :: xfin = xsource ! last receiver x in meters double precision, parameter :: yfin = 300.d0 ! last receiver y in meters ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 200 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! definition of the split velocity vector and stress tensor: ! ! vx(:,:) = vx_1(:,:) + vx_2(:,:) ! vy(:,:) = vy_1(:,:) + vy_2(:,:) ! ! sigmaxx(:,:) = sigmaxx_1(:,:) + sigmaxx_2(:,:) ! sigmayy(:,:) = sigmayy_1(:,:) + sigmayy_2(:,:) ! sigmaxy(:,:) = sigmaxy_1(:,:) + sigmaxy_2(:,:) ! main arrays double precision, dimension(NX,NY) :: vx_1,vx_2,vy_1,vy_2, & sigmaxx_1,sigmaxx_2,sigmayy_1,sigmayy_2,sigmaxy_1,sigmaxy_2 ! additional array used for display only double precision, dimension(NX,NY) :: image_data_2D double precision, dimension(NX) :: dx_over_two,dx_half_over_two double precision, dimension(NY) :: dy_over_two,dy_half_over_two ! for stability estimate double precision :: quasi_cp_max,aniso_stability_criterion,aniso2,aniso3 ! for the source double precision a,t,force_x,force_y,source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec double precision, dimension(NSTEP,NREC) :: sisvx,sisvy ! for evolution of total energy in the medium double precision :: epsilon_xx,epsilon_yy,epsilon_xy double precision :: sigmaxx_total,sigmayy_total,sigmaxy_total double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential integer :: i,j,it,irec double precision :: xval,delta,xoriginleft,xoriginright,rcoef,d0,velocnorm,Courant_number,value_dx,value_dy,d ! ******************* ! program starts here ! ******************* print * print *,'2D elastic anisotropic finite-difference code in velocity and stress formulation with split PML' print * ! display size of the model print * print *,'NX = ',NX print *,'NY = ',NY print * print *,'size of the model along X = ',(NX - 1) * h print *,'size of the model along Y = ',(NY - 1) * h print * print *,'Total number of grid points = ',NX * NY print * print *,'Velocity of qP along vertical axis. . . . =',sqrt(c22/rho) print *,'Velocity of qP along horizontal axis. . . =',sqrt(c11/rho) print * print *,'Velocity of qSV along vertical axis . . . =',sqrt(c33/rho) print *,'Velocity of qSV along horizontal axis . . =',sqrt(c33/rho) print * ! from Becache et al., INRIA report, equation 7 page 5 http://hal.inria.fr/docs/00/07/22/83/PDF/RR-4304.pdf if (c11*c22 - c12*c12 <= 0.d0) stop 'problem in definition of orthotropic material' ! check intrinsic mathematical stability of PML model for an anisotropic material ! from E. B\'ecache, S. Fauqueux and P. Joly, Stability of Perfectly Matched Layers, group ! velocities and anisotropic waves, Journal of Computational Physics, 188(2), p. 399-433 (2003) aniso_stability_criterion = ((c12+c33)**2 - c11*(c22-c33)) * ((c12+c33)**2 + c33*(c22-c33)) print *,'PML anisotropy stability criterion from Becache et al. 2003 = ',aniso_stability_criterion if (aniso_stability_criterion > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) & print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 1' print * aniso2 = (c12 + 2*c33)**2 - c11*c22 print *,'PML aniso2 stability criterion from Becache et al. 2003 = ',aniso2 if (aniso2 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) & print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 2' print * aniso3 = (c12 + c33)**2 - c11*c22 - c33**2 print *,'PML aniso3 stability criterion from Becache et al. 2003 = ',aniso3 if (aniso3 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) & print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 3' print * ! to compute d0 below, and for stability estimate quasi_cp_max = max(sqrt(c22/rho),sqrt(c11/rho)) !--- define profile of absorption in PML region ! thickness of the layer in meters delta = NPOINTS_PML * h ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0 = 3.d0 * quasi_cp_max * log(1.d0/Rcoef) / (2.d0 * delta) print *,'d0 = ',d0 print * ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = delta xoriginright = (NX-1)*h - delta do i=1,NX xval = h*dble(i-1) if (xval < xoriginleft) then dx_over_two(i) = d0 * ((xoriginleft-xval)/delta)**2 dx_half_over_two(i) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2 ! fix problem with dx_half_over_two() exactly on the edge else if (xval >= 0.9999d0*xoriginright) then dx_over_two(i) = d0 * ((xval-xoriginright)/delta)**2 dx_half_over_two(i) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2 else dx_over_two(i) = 0.d0 dx_half_over_two(i) = 0.d0 endif enddo ! divide the whole profile by two once and for all dx_over_two(:) = dx_over_two(:) / 2.d0 dx_half_over_two(:) = dx_half_over_two(:) / 2.d0 ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = delta xoriginright = (NY-1)*h - delta do j=1,NY xval = h*dble(j-1) if (xval < xoriginleft) then dy_over_two(j) = d0 * ((xoriginleft-xval)/delta)**2 dy_half_over_two(j) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2 ! fix problem with dy_half_over_two() exactly on the edge else if (xval >= 0.9999d0*xoriginright) then dy_over_two(j) = d0 * ((xval-xoriginright)/delta)**2 dy_half_over_two(j) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2 else dy_over_two(j) = 0.d0 dy_half_over_two(j) = 0.d0 endif enddo ! divide the whole profile by two once and for all dy_over_two(:) = dy_over_two(:) / 2.d0 dy_half_over_two(:) = dy_half_over_two(:) / 2.d0 ! print position of the source print * print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print * print *,'There are ',nrec,' receivers' print * xspacerec = (xfin-xdeb) / dble(NREC-1) yspacerec = (yfin-ydeb) / dble(NREC-1) do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((h*dble(i-1) - xrec(irec))**2 + (h*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number = quasi_cp_max * DELTAT * sqrt(1.d0/h**2 + 1.d0/h**2) print *,'Courant number is ',Courant_number print * if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable' ! suppress old files (can be commented out if "call system" is missing in your compiler) ! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif') ! initialize arrays vx_1(:,:) = 0.d0 vy_1(:,:) = 0.d0 vx_2(:,:) = 0.d0 vy_2(:,:) = 0.d0 sigmaxx_1(:,:) = 0.d0 sigmayy_1(:,:) = 0.d0 sigmaxy_1(:,:) = 0.d0 sigmaxx_2(:,:) = 0.d0 sigmayy_2(:,:) = 0.d0 sigmaxy_2(:,:) = 0.d0 ! initialize seismograms sisvx(:,:) = 0.d0 sisvy(:,:) = 0.d0 ! initialize total energy total_energy_kinetic(:) = 0.d0 total_energy_potential(:) = 0.d0 !--- !--- beginning of time loop !--- do it = 1,NSTEP !---------------------- ! compute stress sigma !---------------------- do j = 3,NY-1 do i = 2,NX-2 value_dx = (27.d0*vx_1(i+1,j) - 27.d0*vx_1(i,j)-vx_1(i+2,j)+vx_1(i-1,j)) / (24.d0*h) & + (27.d0*vx_2(i+1,j) - 27.d0*vx_2(i,j)-vx_2(i+2,j)+vx_2(i-1,j)) / (24.d0*h) value_dy = (27.d0*vy_1(i,j) - 27.d0*vy_1(i,j-1)-vy_1(i,j+1)+vy_1(i,j-2)) / (24.d0*h) & + (27.d0*vy_2(i,j) - 27.d0*vy_2(i,j-1)-vy_2(i,j+1)+vy_2(i,j-2)) / (24.d0*h) d = dx_half_over_two(i) sigmaxx_1(i,j) = ( sigmaxx_1(i,j)*(ONE_OVER_DELTAT - d) + c11 * value_dx ) / (ONE_OVER_DELTAT + d) sigmayy_1(i,j) = ( sigmayy_1(i,j)*(ONE_OVER_DELTAT - d) + c12 * value_dx ) / (ONE_OVER_DELTAT + d) d = dy_over_two(j) sigmaxx_2(i,j) = ( sigmaxx_2(i,j)*(ONE_OVER_DELTAT - d) + c12 * value_dy ) / (ONE_OVER_DELTAT + d) sigmayy_2(i,j) = ( sigmayy_2(i,j)*(ONE_OVER_DELTAT - d) + c22 * value_dy ) / (ONE_OVER_DELTAT + d) enddo enddo do j = 2,NY-2 do i = 3,NX-1 value_dx = (27.d0*vy_1(i,j) - 27.d0*vy_1(i-1,j)-vy_1(i+1,j)+vy_1(i-2,j)) / (24.d0*h) & + (27.d0*vy_2(i,j) - 27.d0*vy_2(i-1,j)-vy_2(i+1,j)+vy_2(i-2,j)) / (24.d0*h) value_dy = (27.d0*vx_1(i,j+1) - 27.d0*vx_1(i,j)-vx_1(i,j+2)+vx_1(i,j-1)) / (24.d0*h) & + (27.d0*vx_2(i,j+1) - 27.d0*vx_2(i,j)-vx_2(i,j+2)+vx_2(i,j-1)) / (24.d0*h) d = dx_over_two(i) sigmaxy_1(i,j) = ( sigmaxy_1(i,j)*(ONE_OVER_DELTAT - d) + c33 * value_dx ) / (ONE_OVER_DELTAT + d) d = dy_half_over_two(j) sigmaxy_2(i,j) = ( sigmaxy_2(i,j)*(ONE_OVER_DELTAT - d) + c33 * value_dy ) / (ONE_OVER_DELTAT + d) enddo enddo !------------------ ! compute velocity !------------------ do j = 3,NY-1 do i = 3,NX-1 value_dx = (27.d0*sigmaxx_1(i,j) - 27.d0*sigmaxx_1(i-1,j)-sigmaxx_1(i+1,j)+sigmaxx_1(i-2,j)) / (24.d0*h) & + (27.d0*sigmaxx_2(i,j) - 27.d0*sigmaxx_2(i-1,j)-sigmaxx_2(i+1,j)+sigmaxx_2(i-2,j)) / (24.d0*h) value_dy = (27.d0*sigmaxy_1(i,j) - 27.d0*sigmaxy_1(i,j-1)-sigmaxy_1(i,j+1)+sigmaxy_1(i,j-2)) / (24.d0*h) & + (27.d0*sigmaxy_2(i,j) - 27.d0*sigmaxy_2(i,j-1)-sigmaxy_2(i,j+1)+sigmaxy_2(i,j-2)) / (24.d0*h) d = dx_over_two(i) vx_1(i,j) = ( vx_1(i,j)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d) d = dy_over_two(j) vx_2(i,j) = ( vx_2(i,j)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d) enddo enddo do j = 2,NY-2 do i = 2,NX-2 value_dx = (27.d0*sigmaxy_1(i+1,j) - 27.d0*sigmaxy_1(i,j)-sigmaxy_1(i+2,j)+sigmaxy_1(i-1,j)) / (24.d0*h) & + (27.d0*sigmaxy_2(i+1,j) - 27.d0*sigmaxy_2(i,j)-sigmaxy_2(i+2,j)+sigmaxy_2(i-1,j)) / (24.d0*h) value_dy = (27.d0*sigmayy_1(i,j+1) - 27.d0*sigmayy_1(i,j)-sigmayy_1(i,j+2)+sigmayy_1(i,j-1)) / (24.d0*h) & + (27.d0*sigmayy_2(i,j+1) - 27.d0*sigmayy_2(i,j)-sigmayy_2(i,j+2)+sigmayy_2(i,j-1)) / (24.d0*h) d = dx_half_over_two(i) vy_1(i,j) = ( vy_1(i,j)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d) d = dy_half_over_two(j) vy_2(i,j) = ( vy_2(i,j)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d) enddo enddo ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! first derivative of a Gaussian ! source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term ! define location of the source i = ISOURCE j = JSOURCE ! add the source to one of the two components of the split field vx_1(i,j) = vx_1(i,j) + force_x * DELTAT / rho vy_1(i,j) = vy_1(i,j) + force_y * DELTAT / rho ! implement Dirichlet boundary conditions on the four edges of the grid ! xmin vx_1(1,:) = 0.d0 vy_1(1,:) = 0.d0 vx_2(1,:) = 0.d0 vy_2(1,:) = 0.d0 ! xmax vx_1(NX,:) = 0.d0 vy_1(NX,:) = 0.d0 vx_2(NX,:) = 0.d0 vy_2(NX,:) = 0.d0 ! ymin vx_1(:,1) = 0.d0 vy_1(:,1) = 0.d0 vx_2(:,1) = 0.d0 vy_2(:,1) = 0.d0 ! ymax vx_1(:,NY) = 0.d0 vy_1(:,NY) = 0.d0 vx_2(:,NY) = 0.d0 vy_2(:,NY) = 0.d0 ! store seismograms do irec = 1,NREC sisvx(it,irec) = vx_1(ix_rec(irec),iy_rec(irec)) + vx_2(ix_rec(irec),iy_rec(irec)) sisvy(it,irec) = vy_1(ix_rec(irec),iy_rec(irec)) + vy_2(ix_rec(irec),iy_rec(irec)) enddo ! compute total energy in the medium (without the PML layers) ! compute kinetic energy first, defined as 1/2 rho ||v||^2 ! in principle we should use rho_half_x_half_y instead of rho for vy ! in order to interpolate density at the right location in the staggered grid cell ! but in a homogeneous medium we can safely ignore it total_energy_kinetic(it) = 0.5d0 * sum(rho*( & (vx_1(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML) + & vx_2(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML))**2 + & (vy_1(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML) + & vy_2(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML))**2)) ! add potential energy, defined as 1/2 epsilon_ij sigma_ij ! in principle we should interpolate the medium parameters at the right location ! in the staggered grid cell but in a homogeneous medium we can safely ignore it total_energy_potential(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! compute total field from split components sigmaxx_total = sigmaxx_1(i,j) + sigmaxx_2(i,j) sigmayy_total = sigmayy_1(i,j) + sigmayy_2(i,j) sigmaxy_total = sigmaxy_1(i,j) + sigmaxy_2(i,j) epsilon_xx = (c22 * sigmaxx_total - c12 * sigmayy_total) / (c11*c22-c12**2) epsilon_yy = (c11 * sigmayy_total - c12 * sigmaxx_total) / (c11*c22-c12**2) epsilon_xy = sigmaxy_total / (2.d0 * c33) total_energy_potential(it) = total_energy_potential(it) + & 0.5d0 * (epsilon_xx * sigmaxx_total + epsilon_yy * sigmayy_total + 2.d0 * epsilon_xy * sigmaxy_total) enddo enddo ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then velocnorm = maxval(sqrt((vx_1 + vx_2)**2 + (vy_1 + vy_2)**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',velocnorm print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) print * ! check stability of the code, exit if unstable if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' image_data_2D = vx_1 + vx_2 call create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,.true.,.true.,.true.,.true.,1) image_data_2D = vy_1 + vy_2 call create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,.true.,.true.,.true.,.true.,2) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "collino_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_PML_Collino_2D_ani_4th !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT) implicit none integer nt,nrec double precision DELTAT double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_PML_Collino_2D_isotropic.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.1, November 2009. ! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! ! This software is a computer program whose purpose is to solve ! the two-dimensional isotropic elastic wave equation ! using a finite-difference method with classical split Perfectly Matched ! Layer (PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_PML_Collino_2D_iso ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! ! 2D explicit PML velocity-stress FD code based upon INRIA report: ! ! Francis Collino and Chrysoula Tsogka ! Application of the PML Absorbing Layer Model to the Linear ! Elastodynamic Problem in Anisotropic Heteregeneous Media ! INRIA Research Report RR-3471, August 1998 ! http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf ! ! and ! ! @ARTICLE{CoTs01, ! author = {F. Collino and C. Tsogka}, ! title = {Application of the {PML} absorbing layer model to the linear elastodynamic ! problem in anisotropic heterogeneous media}, ! journal = {Geophysics}, ! year = {2001}, ! volume = {66}, ! number = {1}, ! pages = {294-307}} ! ! PML implemented in the two directions (x and y directions). ! ! Dimitri Komatitsch, University of Pau, France, April 2007. ! ! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used: ! ! ^ y ! | ! | ! ! +-------------------+ ! | | ! | | ! | | ! | | ! | v_y | ! sigma_xy +---------+ | ! | | | ! | | | ! | | | ! | | | ! | | | ! +---------+---------+ ---> x ! v_x sigma_xx ! sigma_yy ! ! ! To display the 2D results as color images, use: ! ! " display image* " or " gimp image* " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! total number of grid points in each direction of the grid integer, parameter :: NX = 101 integer, parameter :: NY = 641 ! size of a grid cell double precision, parameter :: h = 10.d0 ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! P-velocity, S-velocity and density double precision, parameter :: cp = 3300.d0 double precision, parameter :: cs = cp / 1.732d0 double precision, parameter :: rho = 2800.d0 double precision, parameter :: mu = rho*cs*cs double precision, parameter :: lambda = rho*(cp*cp - 2.d0*cs*cs) double precision, parameter :: lambda_plus_two_mu = rho*cp*cp ! total number of time steps integer, parameter :: NSTEP = 2000 ! time step in seconds double precision, parameter :: DELTAT = 2.d-3 double precision, parameter :: ONE_OVER_DELTAT = 1.d0 / DELTAT ! parameters for the source double precision, parameter :: f0 = 7.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d7 ! source integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1 integer, parameter :: JSOURCE = 2 * NY / 3 + 1 double precision, parameter :: xsource = (ISOURCE - 1) * h double precision, parameter :: ysource = (JSOURCE - 1) * h ! angle of source force clockwise with respect to vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 135.d0 ! receivers integer, parameter :: NREC = 2 double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters double precision, parameter :: xfin = xsource ! last receiver x in meters double precision, parameter :: yfin = 300.d0 ! last receiver y in meters ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 100 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! definition of the split velocity vector and stress tensor: ! ! vx(:,:) = vx_1(:,:) + vx_2(:,:) ! vy(:,:) = vy_1(:,:) + vy_2(:,:) ! ! sigmaxx(:,:) = sigmaxx_1(:,:) + sigmaxx_2(:,:) ! sigmayy(:,:) = sigmayy_1(:,:) + sigmayy_2(:,:) ! sigmaxy(:,:) = sigmaxy_1(:,:) + sigmaxy_2(:,:) ! main arrays double precision, dimension(NX,NY) :: vx_1,vx_2,vy_1,vy_2, & sigmaxx_1,sigmaxx_2,sigmayy_1,sigmayy_2,sigmaxy_1,sigmaxy_2 ! additional array used for display only double precision, dimension(NX,NY) :: image_data_2D double precision, dimension(NX) :: dx_over_two,dx_half_over_two double precision, dimension(NY) :: dy_over_two,dy_half_over_two ! for the source double precision a,t,force_x,force_y,source_term ! for receivers double precision xspacerec,yspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec double precision, dimension(NREC) :: xrec,yrec double precision, dimension(NSTEP,NREC) :: sisvx,sisvy ! for evolution of total energy in the medium double precision :: epsilon_xx,epsilon_yy,epsilon_xy double precision :: sigmaxx_total,sigmayy_total,sigmaxy_total double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential integer :: i,j,it,irec double precision :: xval,delta,xoriginleft,xoriginright,rcoef,d0,velocnorm,Courant_number,value_dx,value_dy,d ! ******************* ! program starts here ! ******************* !--- define profile of absorption in PML region ! thickness of the layer in meters delta = NPOINTS_PML * h ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0 = 3.d0 * cp * log(1.d0/Rcoef) / (2.d0 * delta) print *,'d0 = ',d0 print * ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = delta xoriginright = (NX-1)*h - delta do i=1,NX xval = h*dble(i-1) if (xval < xoriginleft) then dx_over_two(i) = d0 * ((xoriginleft-xval)/delta)**2 dx_half_over_two(i) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2 ! fix problem with dx_half_over_two() exactly on the edge else if (xval >= 0.9999d0*xoriginright) then dx_over_two(i) = d0 * ((xval-xoriginright)/delta)**2 dx_half_over_two(i) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2 else dx_over_two(i) = 0.d0 dx_half_over_two(i) = 0.d0 endif enddo ! divide the whole profile by two once and for all dx_over_two(:) = dx_over_two(:) / 2.d0 dx_half_over_two(:) = dx_half_over_two(:) / 2.d0 ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = delta xoriginright = (NY-1)*h - delta do j=1,NY xval = h*dble(j-1) if (xval < xoriginleft) then dy_over_two(j) = d0 * ((xoriginleft-xval)/delta)**2 dy_half_over_two(j) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2 ! fix problem with dy_half_over_two() exactly on the edge else if (xval >= 0.9999d0*xoriginright) then dy_over_two(j) = d0 * ((xval-xoriginright)/delta)**2 dy_half_over_two(j) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2 else dy_over_two(j) = 0.d0 dy_half_over_two(j) = 0.d0 endif enddo ! divide the whole profile by two once and for all dy_over_two(:) = dy_over_two(:) / 2.d0 dy_half_over_two(:) = dy_half_over_two(:) / 2.d0 ! print position of the source print * print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print * ! define location of receivers print * print *,'There are ',nrec,' receivers' print * xspacerec = (xfin-xdeb) / dble(NREC-1) yspacerec = (yfin-ydeb) / dble(NREC-1) do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do j = 1,NY do i = 1,NX distval = sqrt((h*dble(i-1) - xrec(irec))**2 + (h*dble(j-1) - yrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j endif enddo enddo print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec) print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number = cp * DELTAT / h print *,'Courant number is ',Courant_number print * if (Courant_number > 1.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable' ! suppress old files (can be commented out if "call system" is missing in your compiler) ! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif') ! initialize arrays vx_1(:,:) = 0.d0 vy_1(:,:) = 0.d0 vx_2(:,:) = 0.d0 vy_2(:,:) = 0.d0 sigmaxx_1(:,:) = 0.d0 sigmayy_1(:,:) = 0.d0 sigmaxy_1(:,:) = 0.d0 sigmaxx_2(:,:) = 0.d0 sigmayy_2(:,:) = 0.d0 sigmaxy_2(:,:) = 0.d0 ! initialize seismograms sisvx(:,:) = 0.d0 sisvy(:,:) = 0.d0 ! initialize total energy total_energy_kinetic(:) = 0.d0 total_energy_potential(:) = 0.d0 !--- !--- beginning of time loop !--- do it = 1,NSTEP !---------------------- ! compute stress sigma !---------------------- do j = 2,NY do i = 1,NX-1 value_dx = (vx_1(i+1,j) - vx_1(i,j)) / h & + (vx_2(i+1,j) - vx_2(i,j)) / h value_dy = (vy_1(i,j) - vy_1(i,j-1)) / h & + (vy_2(i,j) - vy_2(i,j-1)) / h d = dx_half_over_two(i) sigmaxx_1(i,j) = ( sigmaxx_1(i,j)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dx ) / (ONE_OVER_DELTAT + d) sigmayy_1(i,j) = ( sigmayy_1(i,j)*(ONE_OVER_DELTAT - d) + lambda * value_dx ) / (ONE_OVER_DELTAT + d) d = dy_over_two(j) sigmaxx_2(i,j) = ( sigmaxx_2(i,j)*(ONE_OVER_DELTAT - d) + lambda * value_dy ) / (ONE_OVER_DELTAT + d) sigmayy_2(i,j) = ( sigmayy_2(i,j)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dy ) / (ONE_OVER_DELTAT + d) enddo enddo do j = 1,NY-1 do i = 2,NX value_dx = (vy_1(i,j) - vy_1(i-1,j)) / h & + (vy_2(i,j) - vy_2(i-1,j)) / h value_dy = (vx_1(i,j+1) - vx_1(i,j)) / h & + (vx_2(i,j+1) - vx_2(i,j)) / h d = dx_over_two(i) sigmaxy_1(i,j) = ( sigmaxy_1(i,j)*(ONE_OVER_DELTAT - d) + mu * value_dx ) / (ONE_OVER_DELTAT + d) d = dy_half_over_two(j) sigmaxy_2(i,j) = ( sigmaxy_2(i,j)*(ONE_OVER_DELTAT - d) + mu * value_dy ) / (ONE_OVER_DELTAT + d) enddo enddo !------------------ ! compute velocity !------------------ do j = 2,NY do i = 2,NX value_dx = (sigmaxx_1(i,j) - sigmaxx_1(i-1,j)) / h & + (sigmaxx_2(i,j) - sigmaxx_2(i-1,j)) / h value_dy = (sigmaxy_1(i,j) - sigmaxy_1(i,j-1)) / h & + (sigmaxy_2(i,j) - sigmaxy_2(i,j-1)) / h d = dx_over_two(i) vx_1(i,j) = ( vx_1(i,j)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d) d = dy_over_two(j) vx_2(i,j) = ( vx_2(i,j)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d) enddo enddo do j = 1,NY-1 do i = 1,NX-1 value_dx = (sigmaxy_1(i+1,j) - sigmaxy_1(i,j)) / h & + (sigmaxy_2(i+1,j) - sigmaxy_2(i,j)) / h value_dy = (sigmayy_1(i,j+1) - sigmayy_1(i,j)) / h & + (sigmayy_2(i,j+1) - sigmayy_2(i,j)) / h d = dx_half_over_two(i) vy_1(i,j) = ( vy_1(i,j)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d) d = dy_half_over_two(j) vy_2(i,j) = ( vy_2(i,j)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d) enddo enddo ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! first derivative of a Gaussian source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term ! define location of the source i = ISOURCE j = JSOURCE ! add the source to one of the two components of the split field vx_1(i,j) = vx_1(i,j) + force_x * DELTAT / rho vy_1(i,j) = vy_1(i,j) + force_y * DELTAT / rho ! implement Dirichlet boundary conditions on the four edges of the grid ! xmin vx_1(1,:) = 0.d0 vy_1(1,:) = 0.d0 vx_2(1,:) = 0.d0 vy_2(1,:) = 0.d0 ! xmax vx_1(NX,:) = 0.d0 vy_1(NX,:) = 0.d0 vx_2(NX,:) = 0.d0 vy_2(NX,:) = 0.d0 ! ymin vx_1(:,1) = 0.d0 vy_1(:,1) = 0.d0 vx_2(:,1) = 0.d0 vy_2(:,1) = 0.d0 ! ymax vx_1(:,NY) = 0.d0 vy_1(:,NY) = 0.d0 vx_2(:,NY) = 0.d0 vy_2(:,NY) = 0.d0 ! store seismograms do irec = 1,NREC sisvx(it,irec) = vx_1(ix_rec(irec),iy_rec(irec)) + vx_2(ix_rec(irec),iy_rec(irec)) sisvy(it,irec) = vy_1(ix_rec(irec),iy_rec(irec)) + vy_2(ix_rec(irec),iy_rec(irec)) enddo ! compute total energy in the medium (without the PML layers) ! compute kinetic energy first, defined as 1/2 rho ||v||^2 ! in principle we should use rho_half_x_half_y instead of rho for vy ! in order to interpolate density at the right location in the staggered grid cell ! but in a homogeneous medium we can safely ignore it total_energy_kinetic(it) = 0.5d0 * sum(rho*( & (vx_1(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML) + & vx_2(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML))**2 + & (vy_1(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML) + & vy_2(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML))**2)) ! add potential energy, defined as 1/2 epsilon_ij sigma_ij ! in principle we should interpolate the medium parameters at the right location ! in the staggered grid cell but in a homogeneous medium we can safely ignore it total_energy_potential(it) = ZERO do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! compute total field from split components sigmaxx_total = sigmaxx_1(i,j) + sigmaxx_2(i,j) sigmayy_total = sigmayy_1(i,j) + sigmayy_2(i,j) sigmaxy_total = sigmaxy_1(i,j) + sigmaxy_2(i,j) epsilon_xx = ((lambda + 2.d0*mu) * sigmaxx_total - lambda * sigmayy_total) / (4.d0 * mu * (lambda + mu)) epsilon_yy = ((lambda + 2.d0*mu) * sigmayy_total - lambda * sigmaxx_total) / (4.d0 * mu * (lambda + mu)) epsilon_xy = sigmaxy_total / (2.d0 * mu) total_energy_potential(it) = total_energy_potential(it) + & 0.5d0 * (epsilon_xx * sigmaxx_total + epsilon_yy * sigmayy_total + 2.d0 * epsilon_xy * sigmaxy_total) enddo enddo ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then velocnorm = maxval(sqrt((vx_1 + vx_2)**2 + (vy_1 + vy_2)**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',velocnorm print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it) print * ! check stability of the code, exit if unstable if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' image_data_2D = vx_1 + vx_2 call create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,.true.,.true.,.true.,.true.,1) image_data_2D = vy_1 + vy_2 call create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,.true.,.true.,.true.,.true.,2) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), & sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it)) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "collino_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 & & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_PML_Collino_2D_iso !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT) implicit none integer nt,nrec double precision DELTAT double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image ================================================ FILE: seismic_PML_Collino_3D_isotropic_OpenMP.f90 ================================================ ! ! SEISMIC_CPML Version 1.1.1, November 2009. ! ! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France. ! Contributors: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr ! and Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr ! ! This software is a computer program whose purpose is to solve ! the three-dimensional isotropic elastic wave equation ! using a finite-difference method with classical split Perfectly Matched ! Layer (PML) conditions. ! ! 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, write to the Free Software Foundation, Inc., ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ! ! The full text of the license is available in file "LICENSE". program seismic_PML_Collino_3D_iso ! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster). ! If you want you can thus force automatic conversion to single precision at compile time ! or change all the declarations and constants in the code from double precision to single. implicit none ! ! 3D explicit PML velocity-stress FD code based upon INRIA report for the 2D case: ! ! Francis Collino and Chrysoula Tsogka ! Application of the PML Absorbing Layer Model to the Linear ! Elastodynamic Problem in Anisotropic Heteregeneous Media ! INRIA Research Report RR-3471, August 1998 ! http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf ! ! and ! ! @ARTICLE{CoTs01, ! author = {F. Collino and C. Tsogka}, ! title = {Application of the {PML} absorbing layer model to the linear elastodynamic ! problem in anisotropic heterogeneous media}, ! journal = {Geophysics}, ! year = {2001}, ! volume = {66}, ! number = {1}, ! pages = {294-307}} ! ! PML implemented in the three directions (x, y and z). ! ! Dimitri Komatitsch and Roland Martin, University of Pau, France, April 2007. ! ! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used. ! ! Parallel implementation based on OpenMP. ! Type for instance "setenv OMP_NUM_THREADS 4" before running in OpenMP if you want 4 tasks. ! ! To display the results as color images in the selected 2D cut plane, use: ! ! " display image*.gif " or " gimp image*.gif " ! ! or ! ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif " ! " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif " ! then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif " ! then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif " ! ! total number of grid points in each direction of the grid integer, parameter :: NX = 101 integer, parameter :: NY = 641 integer, parameter :: NZ = 640 ! size of a grid cell double precision, parameter :: h = 10.d0 ! thickness of the PML layer in grid points integer, parameter :: NPOINTS_PML = 10 ! P-velocity, S-velocity and density double precision, parameter :: cp = 3300.d0 double precision, parameter :: cs = cp / 1.732d0 double precision, parameter :: rho = 2800.d0 double precision, parameter :: mu = rho*cs*cs double precision, parameter :: lambda = rho*(cp*cp - 2.d0*cs*cs) double precision, parameter :: lambda_plus_two_mu = rho*cp*cp ! total number of time steps integer, parameter :: NSTEP = 2500 ! time step in seconds double precision, parameter :: DELTAT = 1.6d-3 double precision, parameter :: ONE_OVER_DELTAT = 1.d0 / DELTAT ! parameters for the source double precision, parameter :: f0 = 7.d0 double precision, parameter :: t0 = 1.20d0 / f0 double precision, parameter :: factor = 1.d7 ! source ! if one wants to put the source at another location, one can invert the formulas below ! and define the grid point (ISOURCE, JSOURCE, KSOURCE) to use as: ! double precision, parameter :: xsource = ...put here the coordinate you want... ! double precision, parameter :: ysource = ...put here the coordinate you want... ! double precision, parameter :: zsource = ...put here the coordinate you want... ! integer, parameter :: ISOURCE = xsource / h + 1 ! integer, parameter :: JSOURCE = ysource / h + 1 ! integer, parameter :: KSOURCE = zsource / h + 1 ! (h is the size of mesh cells) integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1 integer, parameter :: JSOURCE = 2 * NY / 3 + 1 integer, parameter :: KSOURCE = NZ / 2 double precision, parameter :: xsource = (ISOURCE - 1) * h double precision, parameter :: ysource = (JSOURCE - 1) * h double precision, parameter :: zsource = (KSOURCE - 1) * h ! angle of source force clockwise with respect to vertical (Y) axis double precision, parameter :: ANGLE_FORCE = 135.d0 ! receivers integer, parameter :: NREC = 2 double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters double precision, parameter :: zdeb = zsource ! first receiver y in meters double precision, parameter :: xfin = xsource ! last receiver x in meters double precision, parameter :: yfin = 300.d0 ! last receiver y in meters double precision, parameter :: zfin = zsource ! last receiver y in meters ! display information on the screen from time to time integer, parameter :: IT_DISPLAY = 100 ! value of PI double precision, parameter :: PI = 3.141592653589793238462643d0 ! conversion from degrees to radians double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0 ! zero double precision, parameter :: ZERO = 0.d0 ! large value for maximum double precision, parameter :: HUGEVAL = 1.d+30 ! velocity threshold above which we consider that the code became unstable double precision, parameter :: STABILITY_THRESHOLD = 1.d+25 ! main arrays double precision, dimension(NX,NY,NZ) :: vx_1,vx_2,vx_3, & vy_1,vy_2,vy_3, & vz_1,vz_2,vz_3, & sigmaxx_1,sigmaxx_2,sigmaxx_3, & sigmayy_1,sigmayy_2,sigmayy_3, & sigmazz_1,sigmazz_2,sigmazz_3, & sigmaxy_1,sigmaxy_2, & sigmaxz_1,sigmaxz_3, & sigmayz_2,sigmayz_3 double precision, dimension(NX) :: dx_over_two,dx_half_over_two double precision, dimension(NY) :: dy_over_two,dy_half_over_two double precision, dimension(NZ) :: dz_over_two,dz_half_over_two ! for the source double precision a,t,force_x,force_y,force_z,source_term ! for receivers double precision xspacerec,yspacerec,zspacerec,distval,dist integer, dimension(NREC) :: ix_rec,iy_rec,iz_rec double precision, dimension(NREC) :: xrec,yrec,zrec double precision, dimension(NSTEP,NREC) :: sisvx,sisvy ! for evolution of total energy in the medium double precision :: epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz double precision :: sigmaxx_total,sigmayy_total,sigmazz_total double precision :: sigmaxy_total,sigmaxz_total,sigmayz_total double precision :: total_energy_kinetic,total_energy_potential double precision, dimension(NSTEP) :: total_energy integer :: i,j,k,it,irec,iplane double precision :: xval,delta,xoriginleft,xoriginright,rcoef,d0,Vsolidnorm,Courant_number,value_dx,value_dy,value_dz,d ! timer to count elapsed time character(len=8) datein character(len=10) timein character(len=5) :: zone integer, dimension(8) :: time_values integer ihours,iminutes,iseconds,int_tCPU double precision :: time_start,time_end,tCPU ! names of the time stamp files character(len=150) outputname ! main I/O file integer, parameter :: IOUT = 41 !--- !--- program starts here !--- !--- define profile of absorption in PML region ! thickness of the layer in meters delta = NPOINTS_PML * h ! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf Rcoef = 0.001d0 ! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf d0 = 3.d0 * cp * log(1.d0/Rcoef) / (2.d0 * delta) print *,'d0 = ',d0 print * ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = delta xoriginright = (NX-1)*h - delta do i=1,NX xval = h*dble(i-1) if (xval < xoriginleft) then dx_over_two(i) = d0 * ((xoriginleft-xval)/delta)**2 dx_half_over_two(i) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2 ! fix problem with dx_half_over_two() exactly on the edge else if (xval >= 0.9999d0*xoriginright) then dx_over_two(i) = d0 * ((xval-xoriginright)/delta)**2 dx_half_over_two(i) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2 else dx_over_two(i) = 0.d0 dx_half_over_two(i) = 0.d0 endif enddo ! divide the whole profile by two once and for all dx_over_two(:) = dx_over_two(:) / 2.d0 dx_half_over_two(:) = dx_half_over_two(:) / 2.d0 ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = delta xoriginright = (NY-1)*h - delta do j=1,NY xval = h*dble(j-1) if (xval < xoriginleft) then dy_over_two(j) = d0 * ((xoriginleft-xval)/delta)**2 dy_half_over_two(j) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2 ! fix problem with dy_half_over_two() exactly on the edge else if (xval >= 0.9999d0*xoriginright) then dy_over_two(j) = d0 * ((xval-xoriginright)/delta)**2 dy_half_over_two(j) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2 else dy_over_two(j) = 0.d0 dy_half_over_two(j) = 0.d0 endif enddo ! divide the whole profile by two once and for all dy_over_two(:) = dy_over_two(:) / 2.d0 dy_half_over_two(:) = dy_half_over_two(:) / 2.d0 ! origin of the PML layer (position of right edge minus thickness, in meters) xoriginleft = delta xoriginright = (NZ-1)*h - delta do k=1,NZ xval = h*dble(k-1) if (xval < xoriginleft) then dz_over_two(k) = d0 * ((xoriginleft-xval)/delta)**2 dz_half_over_two(k) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2 ! fix problem with dy_half_over_two() exactly on the edge else if (xval >= 0.9999d0*xoriginright) then dz_over_two(k) = d0 * ((xval-xoriginright)/delta)**2 dz_half_over_two(k) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2 else dz_over_two(k) = 0.d0 dz_half_over_two(k) = 0.d0 endif enddo ! divide the whole profile by two once and for all dz_over_two(:) = dz_over_two(:) / 2.d0 dz_half_over_two(:) = dz_half_over_two(:) / 2.d0 ! print position of the source print * print *,'Position of the source:' print * print *,'x = ',xsource print *,'y = ',ysource print *,'z = ',zsource print * ! define location of receivers print * print *,'There are ',nrec,' receivers' print * xspacerec = (xfin-xdeb) / dble(NREC-1) yspacerec = (yfin-ydeb) / dble(NREC-1) zspacerec = (zfin-zdeb) / dble(NREC-1) do irec=1,nrec xrec(irec) = xdeb + dble(irec-1)*xspacerec yrec(irec) = ydeb + dble(irec-1)*yspacerec zrec(irec) = zdeb + dble(irec-1)*zspacerec enddo ! find closest grid point for each receiver do irec=1,nrec dist = HUGEVAL do k = 1,NZ do j = 1,NY do i = 1,NX distval = sqrt((h*dble(i-1) - xrec(irec))**2 + (h*dble(j-1) - yrec(irec))**2 + (h*dble(k-1) - zrec(irec))**2) if (distval < dist) then dist = distval ix_rec(irec) = i iy_rec(irec) = j iz_rec(irec) = k endif enddo enddo enddo print *,'receiver ',irec,' x_target,y_target,z_target = ',xrec(irec),yrec(irec),zrec(irec) print *,'closest grid point found at distance ',dist,' in i,j,k = ',ix_rec(irec),iy_rec(irec),iz_rec(irec) print * enddo ! check the Courant stability condition for the explicit time scheme ! R. Courant et K. O. Friedrichs et H. Lewy (1928) Courant_number = cp * DELTAT / h print *,'Courant number is ',Courant_number print * if (Courant_number > 1.d0/sqrt(3.d0)) stop 'time step is too large, simulation will be unstable' ! suppress old files (can be commented out if "call system" is missing in your compiler) ! call system('rm -f Vx_*.dat Vy_*.dat Vz_*.dat image*.pnm image*.gif timestamp*') ! initialize arrays vx_1(:,:,:) = 0.d0 vy_1(:,:,:) = 0.d0 vz_1(:,:,:) = 0.d0 vx_2(:,:,:) = 0.d0 vy_2(:,:,:) = 0.d0 vz_2(:,:,:) = 0.d0 vx_3(:,:,:) = 0.d0 vy_3(:,:,:) = 0.d0 vz_3(:,:,:) = 0.d0 sigmaxx_1(:,:,:) = 0.d0 sigmayy_1(:,:,:) = 0.d0 sigmazz_1(:,:,:) = 0.d0 sigmaxy_1(:,:,:) = 0.d0 sigmaxz_1(:,:,:) = 0.d0 sigmaxx_2(:,:,:) = 0.d0 sigmayy_2(:,:,:) = 0.d0 sigmazz_2(:,:,:) = 0.d0 sigmaxy_2(:,:,:) = 0.d0 sigmayz_2(:,:,:) = 0.d0 sigmaxx_3(:,:,:) = 0.d0 sigmayy_3(:,:,:) = 0.d0 sigmazz_3(:,:,:) = 0.d0 sigmaxz_3(:,:,:) = 0.d0 sigmayz_3(:,:,:) = 0.d0 ! initialize seismograms sisvx(:,:) = 0.d0 sisvy(:,:) = 0.d0 ! initialize total energy total_energy(:) = 0.d0 call date_and_time(datein,timein,zone,time_values) ! time_values(3): day of the month ! time_values(5): hour of the day ! time_values(6): minutes of the hour ! time_values(7): seconds of the minute ! time_values(8): milliseconds of the second ! this fails if we cross the end of the month time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + & 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0 !--- !--- beginning of time loop !--- do it = 1,NSTEP print *,'it = ',it !---------------------- ! compute stress sigma !---------------------- !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy,value_dz) & !$OMP SHARED(vx_1,vx_2,vx_3,vy_1,vy_2,vy_3,vz_1,vz_2,vz_3,sigmaxx_1,sigmaxx_2,sigmaxx_3, & !$OMP sigmayy_1,sigmayy_2,sigmayy_3,sigmazz_1,sigmazz_2,sigmazz_3,dx_half_over_two,dy_over_two,dz_over_two) do k=2,NZ do j = 2,NY do i = 1,NX-1 value_dx = (vx_1(i+1,j,k) - vx_1(i,j,k)) / h & + (vx_2(i+1,j,k) - vx_2(i,j,k)) / h & + (vx_3(i+1,j,k) - vx_3(i,j,k)) / h value_dy = (vy_1(i,j,k) - vy_1(i,j-1,k)) / h & + (vy_2(i,j,k) - vy_2(i,j-1,k)) / h & + (vy_3(i,j,k) - vy_3(i,j-1,k)) / h value_dz = (vz_1(i,j,k) - vz_1(i,j,k-1)) / h & + (vz_2(i,j,k) - vz_2(i,j,k-1)) / h & + (vz_3(i,j,k) - vz_3(i,j,k-1)) / h d = dx_half_over_two(i) sigmaxx_1(i,j,k) = ( sigmaxx_1(i,j,k)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dx ) / (ONE_OVER_DELTAT + d) sigmayy_1(i,j,k) = ( sigmayy_1(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dx ) / (ONE_OVER_DELTAT + d) sigmazz_1(i,j,k) = ( sigmazz_1(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dx ) / (ONE_OVER_DELTAT + d) d = dy_over_two(j) sigmaxx_2(i,j,k) = ( sigmaxx_2(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dy ) / (ONE_OVER_DELTAT + d) sigmayy_2(i,j,k) = ( sigmayy_2(i,j,k)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dy ) / (ONE_OVER_DELTAT + d) sigmazz_2(i,j,k) = ( sigmazz_2(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dy ) / (ONE_OVER_DELTAT + d) d = dz_over_two(k) sigmaxx_3(i,j,k) = ( sigmaxx_3(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dz ) / (ONE_OVER_DELTAT + d) sigmayy_3(i,j,k) = ( sigmayy_3(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dz ) / (ONE_OVER_DELTAT + d) sigmazz_3(i,j,k) = ( sigmazz_3(i,j,k)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dz ) / (ONE_OVER_DELTAT + d) enddo enddo enddo !$OMP END PARALLEL DO !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy) SHARED(vx_1,vx_2,vx_3,vy_1, & !$OMP vy_2,vy_3,sigmaxy_1,sigmaxy_2,dy_half_over_two,dx_over_two) do k=1,NZ do j = 1,NY-1 do i = 2,NX value_dx = (vy_1(i,j,k) - vy_1(i-1,j,k)) / h & + (vy_2(i,j,k) - vy_2(i-1,j,k)) / h & + (vy_3(i,j,k) - vy_3(i-1,j,k)) / h value_dy = (vx_1(i,j+1,k) - vx_1(i,j,k)) / h & + (vx_2(i,j+1,k) - vx_2(i,j,k)) / h & + (vx_3(i,j+1,k) - vx_3(i,j,k)) / h d = dx_over_two(i) sigmaxy_1(i,j,k) = ( sigmaxy_1(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dx ) / (ONE_OVER_DELTAT + d) d = dy_half_over_two(j) sigmaxy_2(i,j,k) = ( sigmaxy_2(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dy ) / (ONE_OVER_DELTAT + d) enddo enddo enddo !$OMP END PARALLEL DO !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dz) SHARED(vx_1,vx_2,vx_3, & !$OMP vz_1,vz_2,vz_3,sigmaxz_1,sigmaxz_3,dz_half_over_two,dx_over_two) do k=1,NZ-1 do j = 1,NY do i = 2,NX value_dx = (vz_1(i,j,k) - vz_1(i-1,j,k)) / h & + (vz_2(i,j,k) - vz_2(i-1,j,k)) / h & + (vz_3(i,j,k) - vz_3(i-1,j,k)) / h value_dz = (vx_1(i,j,k+1) - vx_1(i,j,k)) / h & + (vx_2(i,j,k+1) - vx_2(i,j,k)) / h & + (vx_3(i,j,k+1) - vx_3(i,j,k)) / h d = dx_over_two(i) sigmaxz_1(i,j,k) = ( sigmaxz_1(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dx ) / (ONE_OVER_DELTAT + d) d = dz_half_over_two(k) sigmaxz_3(i,j,k) = ( sigmaxz_3(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dz ) / (ONE_OVER_DELTAT + d) enddo enddo enddo !$OMP END PARALLEL DO !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dy,value_dz) SHARED(vy_1,vy_2,vy_3, & !$OMP vz_1,vz_2,vz_3,sigmayz_2,sigmayz_3,dy_half_over_two,dz_half_over_two) do k=1,NZ-1 do j = 1,NY-1 do i = 1,NX value_dy = (vz_1(i,j+1,k) - vz_1(i,j,k)) / h & + (vz_2(i,j+1,k) - vz_2(i,j,k)) / h & + (vz_3(i,j+1,k) - vz_3(i,j,k)) / h value_dz = (vy_1(i,j,k+1) - vy_1(i,j,k)) / h & + (vy_2(i,j,k+1) - vy_2(i,j,k)) / h & + (vy_3(i,j,k+1) - vy_3(i,j,k)) / h d = dy_half_over_two(j) sigmayz_2(i,j,k) = ( sigmayz_2(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dy ) / (ONE_OVER_DELTAT + d) d = dz_half_over_two(k) sigmayz_3(i,j,k) = ( sigmayz_3(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dz ) / (ONE_OVER_DELTAT + d) enddo enddo enddo !$OMP END PARALLEL DO !------------------ ! compute velocity !------------------ !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy,value_dz) SHARED(vx_1,vx_2, & !$OMP vx_3,sigmaxx_1,sigmaxx_2,sigmaxx_3,sigmaxy_1,sigmaxy_2,sigmaxz_1,sigmaxz_3,dx_over_two,dy_over_two,dz_over_two) do k = 2,NZ do j = 2,NY do i = 2,NX value_dx = (sigmaxx_1(i,j,k) - sigmaxx_1(i-1,j,k)) / h & + (sigmaxx_2(i,j,k) - sigmaxx_2(i-1,j,k)) / h & + (sigmaxx_3(i,j,k) - sigmaxx_3(i-1,j,k)) / h value_dy = (sigmaxy_1(i,j,k) - sigmaxy_1(i,j-1,k)) / h & + (sigmaxy_2(i,j,k) - sigmaxy_2(i,j-1,k)) / h value_dz = (sigmaxz_1(i,j,k) - sigmaxz_1(i,j,k-1)) / h & + (sigmaxz_3(i,j,k) - sigmaxz_3(i,j,k-1)) / h d = dx_over_two(i) vx_1(i,j,k) = ( vx_1(i,j,k)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d) d = dy_over_two(j) vx_2(i,j,k) = ( vx_2(i,j,k)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d) d = dz_over_two(k) vx_3(i,j,k) = ( vx_3(i,j,k)*(ONE_OVER_DELTAT - d) + value_dz / rho ) / (ONE_OVER_DELTAT + d) enddo enddo enddo !$OMP END PARALLEL DO !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy,value_dz) SHARED(vy_1,vy_2, & !$OMP vy_3,sigmayy_1,sigmayy_2,sigmayy_3,sigmaxy_1,sigmaxy_2,sigmayz_2,sigmayz_3,dx_half_over_two,dy_half_over_two,dz_over_two) do k = 2,NZ do j = 1,NY-1 do i = 1,NX-1 value_dx = (sigmaxy_1(i+1,j,k) - sigmaxy_1(i,j,k)) / h & + (sigmaxy_2(i+1,j,k) - sigmaxy_2(i,j,k)) / h value_dy = (sigmayy_1(i,j+1,k) - sigmayy_1(i,j,k)) / h & + (sigmayy_2(i,j+1,k) - sigmayy_2(i,j,k)) / h & + (sigmayy_3(i,j+1,k) - sigmayy_3(i,j,k)) / h value_dz = (sigmayz_2(i,j,k) - sigmayz_2(i,j,k-1)) / h & + (sigmayz_3(i,j,k) - sigmayz_3(i,j,k-1)) / h d = dx_half_over_two(i) vy_1(i,j,k) = ( vy_1(i,j,k)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d) d = dy_half_over_two(j) vy_2(i,j,k) = ( vy_2(i,j,k)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d) d = dz_over_two(k) vy_3(i,j,k) = ( vy_3(i,j,k)*(ONE_OVER_DELTAT - d) + value_dz / rho ) / (ONE_OVER_DELTAT + d) enddo enddo enddo !$OMP END PARALLEL DO !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy,value_dz) SHARED(vz_1,vz_2, & !$OMP vz_3,sigmazz_1,sigmazz_2,sigmazz_3,sigmaxz_1,sigmaxz_3,sigmayz_2,sigmayz_3,dx_half_over_two,dy_over_two,dz_half_over_two) do k = 1,NZ-1 do j = 2,NY do i = 1,NX-1 value_dx = (sigmaxz_1(i+1,j,k) - sigmaxz_1(i,j,k)) / h & + (sigmaxz_3(i+1,j,k) - sigmaxz_3(i,j,k)) / h value_dy = (sigmayz_2(i,j,k) - sigmayz_2(i,j-1,k)) / h & + (sigmayz_3(i,j,k) - sigmayz_3(i,j-1,k)) / h value_dz = (sigmazz_1(i,j,k+1) - sigmazz_1(i,j,k)) / h & + (sigmazz_2(i,j,k+1) - sigmazz_2(i,j,k)) / h & + (sigmazz_3(i,j,k+1) - sigmazz_3(i,j,k)) / h d = dx_half_over_two(i) vz_1(i,j,k) = ( vz_1(i,j,k)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d) d = dy_over_two(j) vz_2(i,j,k) = ( vz_2(i,j,k)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d) d = dz_half_over_two(k) vz_3(i,j,k) = ( vz_3(i,j,k)*(ONE_OVER_DELTAT - d) + value_dz / rho ) / (ONE_OVER_DELTAT + d) enddo enddo enddo !$OMP END PARALLEL DO ! add the source (force vector located at a given grid point) a = pi*pi*f0*f0 t = dble(it-1)*DELTAT ! Gaussian ! source_term = factor * exp(-a*(t-t0)**2) ! first derivative of a Gaussian source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2) ! Ricker source time function (second derivative of a Gaussian) ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2) force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term force_z = 0.d0 ! add the source to one of the two components of the split field vx_1(ISOURCE,JSOURCE,KSOURCE) = vx_1(ISOURCE,JSOURCE,KSOURCE) + force_x * DELTAT / rho vy_1(ISOURCE,JSOURCE,KSOURCE) = vy_1(ISOURCE,JSOURCE,KSOURCE) + force_y * DELTAT / rho ! implement Dirichlet boundary conditions on the six edges of the grid !$OMP PARALLEL WORKSHARE ! xmin vx_1(1,:,:) = 0.d0 vy_1(1,:,:) = 0.d0 vz_1(1,:,:) = 0.d0 vx_2(1,:,:) = 0.d0 vy_2(1,:,:) = 0.d0 vz_2(1,:,:) = 0.d0 vx_3(1,:,:) = 0.d0 vy_3(1,:,:) = 0.d0 vz_3(1,:,:) = 0.d0 ! xmax vx_1(NX,:,:) = 0.d0 vy_1(NX,:,:) = 0.d0 vz_1(NX,:,:) = 0.d0 vx_2(NX,:,:) = 0.d0 vy_2(NX,:,:) = 0.d0 vz_2(NX,:,:) = 0.d0 vx_3(NX,:,:) = 0.d0 vy_3(NX,:,:) = 0.d0 vz_3(NX,:,:) = 0.d0 ! ymin vx_1(:,1,:) = 0.d0 vy_1(:,1,:) = 0.d0 vz_1(:,1,:) = 0.d0 vx_2(:,1,:) = 0.d0 vy_2(:,1,:) = 0.d0 vz_2(:,1,:) = 0.d0 vx_3(:,1,:) = 0.d0 vy_3(:,1,:) = 0.d0 vz_3(:,1,:) = 0.d0 ! ymax vx_1(:,NY,:) = 0.d0 vy_1(:,NY,:) = 0.d0 vz_1(:,NY,:) = 0.d0 vx_2(:,NY,:) = 0.d0 vy_2(:,NY,:) = 0.d0 vz_2(:,NY,:) = 0.d0 vx_3(:,NY,:) = 0.d0 vy_3(:,NY,:) = 0.d0 vz_3(:,NY,:) = 0.d0 ! zmin vx_1(:,:,1) = 0.d0 vy_1(:,:,1) = 0.d0 vz_1(:,:,1) = 0.d0 vx_2(:,:,1) = 0.d0 vy_2(:,:,1) = 0.d0 vz_2(:,:,1) = 0.d0 vx_3(:,:,1) = 0.d0 vy_3(:,:,1) = 0.d0 vz_3(:,:,1) = 0.d0 ! zmax vx_1(:,:,NZ) = 0.d0 vy_1(:,:,NZ) = 0.d0 vz_1(:,:,NZ) = 0.d0 vx_2(:,:,NZ) = 0.d0 vy_2(:,:,NZ) = 0.d0 vz_2(:,:,NZ) = 0.d0 vx_3(:,:,NZ) = 0.d0 vy_3(:,:,NZ) = 0.d0 vz_3(:,:,NZ) = 0.d0 !$OMP END PARALLEL WORKSHARE ! store seismograms do irec = 1,NREC sisvx(it,irec) = vx_1(ix_rec(irec),iy_rec(irec),iz_rec(irec)) + & vx_2(ix_rec(irec),iy_rec(irec),iz_rec(irec)) + vx_3(ix_rec(irec),iy_rec(irec),iz_rec(irec)) sisvy(it,irec) = vy_1(ix_rec(irec),iy_rec(irec),iz_rec(irec)) + & vy_2(ix_rec(irec),iy_rec(irec),iz_rec(irec)) + vy_3(ix_rec(irec),iy_rec(irec),iz_rec(irec)) enddo ! compute total energy in the medium (without the PML layers) total_energy_kinetic = ZERO total_energy_potential = ZERO !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,sigmaxx_total,sigmayy_total, & !$OMP sigmazz_total,sigmaxy_total,sigmaxz_total,sigmayz_total,epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz) & !$OMP SHARED(vx_1,vx_2,vx_3,vy_1,vy_2,vy_3,vz_1,vz_2,vz_3,sigmaxx_1,sigmaxx_2, & !$OMP sigmaxx_3,sigmayy_1,sigmayy_2,sigmayy_3,sigmazz_1,sigmazz_2,sigmazz_3, & !$OMP sigmaxy_1,sigmaxy_2,sigmaxz_1,sigmaxz_3,sigmayz_2,sigmayz_3) REDUCTION(+:total_energy_kinetic,total_energy_potential) do k = NPOINTS_PML+1, NZ-NPOINTS_PML do j = NPOINTS_PML+1, NY-NPOINTS_PML do i = NPOINTS_PML+1, NX-NPOINTS_PML ! compute kinetic energy first, defined as 1/2 rho ||v||^2 ! in principle we should use rho_half_x_half_y instead of rho for vy ! in order to interpolate density at the right location in the staggered grid cell ! but in a homogeneous medium we can safely ignore it total_energy_kinetic = total_energy_kinetic + 0.5d0 * rho*( & (vx_1(i,j,k) + vx_2(i,j,k) + vx_3(i,j,k))**2 + & (vy_1(i,j,k) + vy_2(i,j,k) + vy_3(i,j,k))**2 + & (vz_1(i,j,k) + vz_2(i,j,k) + vz_3(i,j,k))**2) ! add potential energy, defined as 1/2 epsilon_ij sigma_ij ! in principle we should interpolate the medium parameters at the right location ! in the staggered grid cell but in a homogeneous medium we can safely ignore it ! compute total field from split components sigmaxx_total = sigmaxx_1(i,j,k) + sigmaxx_2(i,j,k) + sigmaxx_3(i,j,k) sigmayy_total = sigmayy_1(i,j,k) + sigmayy_2(i,j,k) + sigmayy_3(i,j,k) sigmazz_total = sigmazz_1(i,j,k) + sigmazz_2(i,j,k) + sigmazz_3(i,j,k) sigmaxy_total = sigmaxy_1(i,j,k) + sigmaxy_2(i,j,k) sigmaxz_total = sigmaxz_1(i,j,k) + sigmaxz_3(i,j,k) sigmayz_total = sigmayz_2(i,j,k) + sigmayz_3(i,j,k) epsilon_xx = (2.d0*(lambda + mu) * sigmaxx_total - lambda * sigmayy_total -lambda*sigmazz_total) / & (2.d0 * mu * (3.d0*lambda + 2.d0*mu)) epsilon_yy = (2.d0*(lambda + mu) * sigmayy_total - lambda * sigmaxx_total -lambda*sigmazz_total) / & (2.d0 * mu * (3.d0*lambda + 2.d0*mu)) epsilon_zz = (2.d0*(lambda + mu) * sigmazz_total - lambda * sigmaxx_total -lambda*sigmayy_total) / & (2.d0 * mu * (3.d0*lambda + 2.d0*mu)) epsilon_xy = sigmaxy_total / (2.d0 * mu) epsilon_xz = sigmaxz_total / (2.d0 * mu) epsilon_yz = sigmayz_total / (2.d0 * mu) total_energy_potential = total_energy_potential + & 0.5d0 * (epsilon_xx * sigmaxx_total + epsilon_yy * sigmayy_total + & epsilon_yy * sigmayy_total+ 2.d0 * epsilon_xy * sigmaxy_total + & 2.d0*epsilon_xz * sigmaxz_total+2.d0*epsilon_yz * sigmayz_total) enddo enddo enddo !$OMP END PARALLEL DO total_energy(it) = total_energy_kinetic + total_energy_potential ! output information if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then Vsolidnorm = maxval(sqrt((vx_1 + vx_2 + vx_3)**2 + (vy_1 + vy_2 + vy_3)**2+(vz_1 + vz_2 + vz_3)**2)) print *,'Time step # ',it,' out of ',NSTEP print *,'Time: ',sngl((it-1)*DELTAT),' seconds' print *,'Max norm velocity vector V (m/s) = ',Vsolidnorm print *,'Total energy = ',total_energy(it) ! check stability of the code, exit if unstable if (Vsolidnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up' iplane=1 ! count elapsed wall-clock time call date_and_time(datein,timein,zone,time_values) ! time_values(3): day of the month ! time_values(5): hour of the day ! time_values(6): minutes of the hour ! time_values(7): seconds of the minute ! time_values(8): milliseconds of the second ! this fails if we cross the end of the month time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + & 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0 ! elapsed time since beginning of the simulation tCPU = time_end - time_start int_tCPU = int(tCPU) ihours = int_tCPU / 3600 iminutes = (int_tCPU - 3600*ihours) / 60 iseconds = int_tCPU - 3600*ihours - 60*iminutes write(*,*) 'Elapsed time in seconds = ',tCPU write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it) write(*,*) ! write time stamp file to give information about progression of simulation write(outputname,"('timestamp',i6.6)") it open(unit=IOUT,file=outputname,status='unknown') write(IOUT,*) 'Time step # ',it write(IOUT,*) 'Time: ',sngl((it-1)*DELTAT),' seconds' write(IOUT,*) 'Max norm velocity vector V (m/s) = ',Vsolidnorm write(IOUT,*) 'Total energy = ',total_energy(it) write(IOUT,*) 'Elapsed time in seconds = ',tCPU write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it) close(IOUT) ! save seismograms print *,'saving seismograms' print * call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) ! here we represent the cut plane that is in the middle of the model along the Z direction, in NZ/2 call create_color_image(vx_1(:,:,NZ/2) + vx_2(:,:,NZ/2) + vx_3(:,:,NZ/2),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,.true.,.true.,.true.,.true.,1) call create_color_image(vy_1(:,:,NZ/2) + vy_2(:,:,NZ/2) +vy_3(:,:,NZ/2),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,.true.,.true.,.true.,.true.,2) endif enddo ! end of time loop ! save seismograms call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT) ! save total energy open(unit=20,file='energy.dat',status='unknown') do it = 1,NSTEP write(20,*) sngl(dble(it-1)*DELTAT),total_energy(it) enddo close(20) ! create script for Gnuplot for total energy open(unit=20,file='plot_energy',status='unknown') write(20,*) '# set term x11' write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Total energy"' write(20,*) write(20,*) 'set output "collino3D_total_energy_semilog.eps"' write(20,*) 'set logscale y' write(20,*) 'plot "energy.dat" t ''Total energy'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) ! create script for Gnuplot open(unit=20,file='plotgnu',status='unknown') write(20,*) 'set term x11' write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22' write(20,*) write(20,*) 'set xlabel "Time (s)"' write(20,*) 'set ylabel "Amplitude (m / s)"' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"' write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"' write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vz_receiver_001.eps"' write(20,*) 'plot "Vz_file_001.dat" t ''Vz C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"' write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"' write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) write(20,*) 'set output "v_sigma_Vz_receiver_002.eps"' write(20,*) 'plot "Vz_file_002.dat" t ''Vz C-PML'' w l lc 1' write(20,*) 'pause -1 "Hit any key..."' write(20,*) close(20) print * print *,'End of the simulation' print * end program seismic_PML_Collino_3D_iso !---- !---- save the seismograms in ASCII text format !---- subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT) implicit none integer nt,nrec double precision DELTAT double precision sisvx(nt,nrec) double precision sisvy(nt,nrec) integer irec,it character(len=100) file_name ! X component do irec=1,nrec write(file_name,"('Vx_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec)) enddo close(11) enddo ! Y component do irec=1,nrec write(file_name,"('Vy_file_',i3.3,'.dat')") irec open(unit=11,file=file_name,status='unknown') do it=1,nt write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec)) enddo close(11) enddo end subroutine write_seismograms !---- !---- routine to create a color image of a given vector component !---- the image is created in PNM format and then converted to GIF !---- subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, & NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number) implicit none ! non linear display to enhance small amplitudes for graphics double precision, parameter :: POWER_DISPLAY = 0.30d0 ! amplitude threshold above which we draw the color point double precision, parameter :: cutvect = 0.01d0 ! use black or white background for points that are below the threshold logical, parameter :: WHITE_BACKGROUND = .true. ! size of cross and square in pixels drawn to represent the source and the receivers integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3 integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX double precision, dimension(NX,NY) :: image_data_2D integer, dimension(nrec) :: ix_rec,iy_rec integer :: ix,iy,irec character(len=100) :: file_name,system_command integer :: R, G, B double precision :: normalized_value,max_amplitude ! open image file and create system command to convert image to more convenient format ! use the "convert" command from ImageMagick http://www.imagemagick.org if (field_number == 1) then write(file_name,"('image',i6.6,'_Vx.pnm')") it write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it else if (field_number == 2) then write(file_name,"('image',i6.6,'_Vy.pnm')") it write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it endif open(unit=27, file=file_name, status='unknown') write(27,"('P3')") ! write image in PNM P3 format write(27,*) NX,NY ! write image size write(27,*) '255' ! maximum value of each pixel color ! compute maximum amplitude max_amplitude = maxval(abs(image_data_2D)) ! image starts in upper-left corner in PNM format do iy=NY,1,-1 do ix=1,NX ! define data as vector component normalized to [-1:1] and rounded to nearest integer ! keeping in mind that amplitude can be negative normalized_value = image_data_2D(ix,iy) / max_amplitude ! suppress values that are outside [-1:+1] to avoid small edge effects if (normalized_value < -1.d0) normalized_value = -1.d0 if (normalized_value > 1.d0) normalized_value = 1.d0 ! draw an orange cross to represent the source if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. & iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. & (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. & iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then R = 255 G = 157 B = 0 ! display two-pixel-thick black frame around the image else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then R = 0 G = 0 B = 0 ! display edges of the PML layers else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. & (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. & (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. & (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then R = 255 G = 150 B = 0 ! suppress all the values that are below the threshold else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then ! use a black or white background for points that are below the threshold if (WHITE_BACKGROUND) then R = 255 G = 255 B = 255 else R = 0 G = 0 B = 0 endif ! represent regular image points using red if value is positive, blue if negative else if (normalized_value >= 0.d0) then R = nint(255.d0*normalized_value**POWER_DISPLAY) G = 0 B = 0 else R = 0 G = 0 B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY) endif ! draw a green square to represent the receivers do irec = 1,nrec if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. & (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. & iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then ! use dark green color R = 30 G = 180 B = 60 endif enddo ! write color pixel write(27,"(i3,' ',i3,' ',i3)") R,G,B enddo enddo ! close file close(27) ! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler) ! call system(system_command) end subroutine create_color_image