[ { "path": ".gitignore", "content": "# 2D\n\nxseismic_CPML_2D_isotropic_second_order\nxseismic_CPML_2D_isotropic_fourth_order\nxseismic_CPML_2D_anisotropic\n\nxseismic_PML_Collino_2D_isotropic\nxseismic_PML_Collino_2D_anisotropic_fourth\n\nxseismic_ADEPML_2D_elastic_RK4_eighth_order\nxseismic_ADEPML_2D_viscoelastic_RK4_eighth_order\n\n# 3D\n\nxseismic_CPML_3D_isotropic_MPI_OpenMP\nxseismic_CPML_2D_poroelastic_fourth_order\nxseismic_CPML_3D_viscoelastic_MPI\nxseismic_PML_Collino_3D_isotropic_OpenMP\n\n" }, { "path": "AUTHORS", "content": "Main historical authors: Dimitri Komatitsch, CNRS / University of Marseille, France\n and Roland Martin, CNRS / University of Toulouse, France,\n but several other people have contributed since then, see the comments at the beginning of each of the Fortran source files.\n" }, { "path": "LICENSE", "content": " GNU GENERAL PUBLIC LICENSE\n Version 3, 29 June 2007\n\n Copyright (C) 2007 Free Software Foundation, Inc. \n Everyone is permitted to copy and distribute verbatim copies\n of this license document, but changing it is not allowed.\n\n Preamble\n\n The GNU General Public License is a free, copyleft license for\nsoftware and other kinds of works.\n\n The licenses for most software and other practical works are designed\nto take away your freedom to share and change the works. By contrast,\nthe GNU General Public License is intended to guarantee your freedom to\nshare and change all versions of a program--to make sure it remains free\nsoftware for all its users. We, the Free Software Foundation, use the\nGNU General Public License for most of our software; it applies also to\nany other work released this way by its authors. You can apply it to\nyour programs, too.\n\n When we speak of free software, we are referring to freedom, not\nprice. Our General Public Licenses are designed to make sure that you\nhave the freedom to distribute copies of free software (and charge for\nthem if you wish), that you receive source code or can get it if you\nwant it, that you can change the software or use pieces of it in new\nfree programs, and that you know you can do these things.\n\n To protect your rights, we need to prevent others from denying you\nthese rights or asking you to surrender the rights. Therefore, you have\ncertain responsibilities if you distribute copies of the software, or if\nyou modify it: responsibilities to respect the freedom of others.\n\n For example, if you distribute copies of such a program, whether\ngratis or for a fee, you must pass on to the recipients the same\nfreedoms that you received. You must make sure that they, too, receive\nor can get the source code. And you must show them these terms so they\nknow their rights.\n\n Developers that use the GNU GPL protect your rights with two steps:\n(1) assert copyright on the software, and (2) offer you this License\ngiving you legal permission to copy, distribute and/or modify it.\n\n For the developers' and authors' protection, the GPL clearly explains\nthat there is no warranty for this free software. For both users' and\nauthors' sake, the GPL requires that modified versions be marked as\nchanged, so that their problems will not be attributed erroneously to\nauthors of previous versions.\n\n Some devices are designed to deny users access to install or run\nmodified versions of the software inside them, although the manufacturer\ncan do so. This is fundamentally incompatible with the aim of\nprotecting users' freedom to change the software. The systematic\npattern of such abuse occurs in the area of products for individuals to\nuse, which is precisely where it is most unacceptable. Therefore, we\nhave designed this version of the GPL to prohibit the practice for those\nproducts. If such problems arise substantially in other domains, we\nstand ready to extend this provision to those domains in future versions\nof the GPL, as needed to protect the freedom of users.\n\n Finally, every program is threatened constantly by software patents.\nStates should not allow patents to restrict development and use of\nsoftware on general-purpose computers, but in those that do, we wish to\navoid the special danger that patents applied to a free program could\nmake it effectively proprietary. To prevent this, the GPL assures that\npatents cannot be used to render the program non-free.\n\n The precise terms and conditions for copying, distribution and\nmodification follow.\n\n TERMS AND CONDITIONS\n\n 0. Definitions.\n\n \"This License\" refers to version 3 of the GNU General Public License.\n\n \"Copyright\" also means copyright-like laws that apply to other kinds of\nworks, such as semiconductor masks.\n\n \"The Program\" refers to any copyrightable work licensed under this\nLicense. Each licensee is addressed as \"you\". \"Licensees\" and\n\"recipients\" may be individuals or organizations.\n\n To \"modify\" a work means to copy from or adapt all or part of the work\nin a fashion requiring copyright permission, other than the making of an\nexact copy. The resulting work is called a \"modified version\" of the\nearlier work or a work \"based on\" the earlier work.\n\n A \"covered work\" means either the unmodified Program or a work based\non the Program.\n\n To \"propagate\" a work means to do anything with it that, without\npermission, would make you directly or secondarily liable for\ninfringement under applicable copyright law, except executing it on a\ncomputer or modifying a private copy. Propagation includes copying,\ndistribution (with or without modification), making available to the\npublic, and in some countries other activities as well.\n\n To \"convey\" a work means any kind of propagation that enables other\nparties to make or receive copies. Mere interaction with a user through\na computer network, with no transfer of a copy, is not conveying.\n\n An interactive user interface displays \"Appropriate Legal Notices\"\nto the extent that it includes a convenient and prominently visible\nfeature that (1) displays an appropriate copyright notice, and (2)\ntells the user that there is no warranty for the work (except to the\nextent that warranties are provided), that licensees may convey the\nwork under this License, and how to view a copy of this License. If\nthe interface presents a list of user commands or options, such as a\nmenu, a prominent item in the list meets this criterion.\n\n 1. Source Code.\n\n The \"source code\" for a work means the preferred form of the work\nfor making modifications to it. \"Object code\" means any non-source\nform of a work.\n\n A \"Standard Interface\" means an interface that either is an official\nstandard defined by a recognized standards body, or, in the case of\ninterfaces specified for a particular programming language, one that\nis widely used among developers working in that language.\n\n The \"System Libraries\" of an executable work include anything, other\nthan the work as a whole, that (a) is included in the normal form of\npackaging a Major Component, but which is not part of that Major\nComponent, and (b) serves only to enable use of the work with that\nMajor Component, or to implement a Standard Interface for which an\nimplementation is available to the public in source code form. A\n\"Major Component\", in this context, means a major essential component\n(kernel, window system, and so on) of the specific operating system\n(if any) on which the executable work runs, or a compiler used to\nproduce the work, or an object code interpreter used to run it.\n\n The \"Corresponding Source\" for a work in object code form means all\nthe source code needed to generate, install, and (for an executable\nwork) run the object code and to modify the work, including scripts to\ncontrol those activities. However, it does not include the work's\nSystem Libraries, or general-purpose tools or generally available free\nprograms which are used unmodified in performing those activities but\nwhich are not part of the work. For example, Corresponding Source\nincludes interface definition files associated with source files for\nthe work, and the source code for shared libraries and dynamically\nlinked subprograms that the work is specifically designed to require,\nsuch as by intimate data communication or control flow between those\nsubprograms and other parts of the work.\n\n The Corresponding Source need not include anything that users\ncan regenerate automatically from other parts of the Corresponding\nSource.\n\n The Corresponding Source for a work in source code form is that\nsame work.\n\n 2. Basic Permissions.\n\n All rights granted under this License are granted for the term of\ncopyright on the Program, and are irrevocable provided the stated\nconditions are met. This License explicitly affirms your unlimited\npermission to run the unmodified Program. The output from running a\ncovered work is covered by this License only if the output, given its\ncontent, constitutes a covered work. This License acknowledges your\nrights of fair use or other equivalent, as provided by copyright law.\n\n You may make, run and propagate covered works that you do not\nconvey, without conditions so long as your license otherwise remains\nin force. You may convey covered works to others for the sole purpose\nof having them make modifications exclusively for you, or provide you\nwith facilities for running those works, provided that you comply with\nthe terms of this License in conveying all material for which you do\nnot control copyright. Those thus making or running the covered works\nfor you must do so exclusively on your behalf, under your direction\nand control, on terms that prohibit them from making any copies of\nyour copyrighted material outside their relationship with you.\n\n Conveying under any other circumstances is permitted solely under\nthe conditions stated below. Sublicensing is not allowed; section 10\nmakes it unnecessary.\n\n 3. Protecting Users' Legal Rights From Anti-Circumvention Law.\n\n No covered work shall be deemed part of an effective technological\nmeasure under any applicable law fulfilling obligations under article\n11 of the WIPO copyright treaty adopted on 20 December 1996, or\nsimilar laws prohibiting or restricting circumvention of such\nmeasures.\n\n When you convey a covered work, you waive any legal power to forbid\ncircumvention of technological measures to the extent such circumvention\nis effected by exercising rights under this License with respect to\nthe covered work, and you disclaim any intention to limit operation or\nmodification of the work as a means of enforcing, against the work's\nusers, your or third parties' legal rights to forbid circumvention of\ntechnological measures.\n\n 4. Conveying Verbatim Copies.\n\n You may convey verbatim copies of the Program's source code as you\nreceive it, in any medium, provided that you conspicuously and\nappropriately publish on each copy an appropriate copyright notice;\nkeep intact all notices stating that this License and any\nnon-permissive terms added in accord with section 7 apply to the code;\nkeep intact all notices of the absence of any warranty; and give all\nrecipients a copy of this License along with the Program.\n\n You may charge any price or no price for each copy that you convey,\nand you may offer support or warranty protection for a fee.\n\n 5. Conveying Modified Source Versions.\n\n You may convey a work based on the Program, or the modifications to\nproduce it from the Program, in the form of source code under the\nterms of section 4, provided that you also meet all of these conditions:\n\n a) The work must carry prominent notices stating that you modified\n it, and giving a relevant date.\n\n b) The work must carry prominent notices stating that it is\n released under this License and any conditions added under section\n 7. This requirement modifies the requirement in section 4 to\n \"keep intact all notices\".\n\n c) You must license the entire work, as a whole, under this\n License to anyone who comes into possession of a copy. This\n License will therefore apply, along with any applicable section 7\n additional terms, to the whole of the work, and all its parts,\n regardless of how they are packaged. This License gives no\n permission to license the work in any other way, but it does not\n invalidate such permission if you have separately received it.\n\n d) If the work has interactive user interfaces, each must display\n Appropriate Legal Notices; however, if the Program has interactive\n interfaces that do not display Appropriate Legal Notices, your\n work need not make them do so.\n\n A compilation of a covered work with other separate and independent\nworks, which are not by their nature extensions of the covered work,\nand which are not combined with it such as to form a larger program,\nin or on a volume of a storage or distribution medium, is called an\n\"aggregate\" if the compilation and its resulting copyright are not\nused to limit the access or legal rights of the compilation's users\nbeyond what the individual works permit. Inclusion of a covered work\nin an aggregate does not cause this License to apply to the other\nparts of the aggregate.\n\n 6. Conveying Non-Source Forms.\n\n You may convey a covered work in object code form under the terms\nof sections 4 and 5, provided that you also convey the\nmachine-readable Corresponding Source under the terms of this License,\nin one of these ways:\n\n a) Convey the object code in, or embodied in, a physical product\n (including a physical distribution medium), accompanied by the\n Corresponding Source fixed on a durable physical medium\n customarily used for software interchange.\n\n b) Convey the object code in, or embodied in, a physical product\n (including a physical distribution medium), accompanied by a\n written offer, valid for at least three years and valid for as\n long as you offer spare parts or customer support for that product\n model, to give anyone who possesses the object code either (1) a\n copy of the Corresponding Source for all the software in the\n product that is covered by this License, on a durable physical\n medium customarily used for software interchange, for a price no\n more than your reasonable cost of physically performing this\n conveying of source, or (2) access to copy the\n Corresponding Source from a network server at no charge.\n\n c) Convey individual copies of the object code with a copy of the\n written offer to provide the Corresponding Source. This\n alternative is allowed only occasionally and noncommercially, and\n only if you received the object code with such an offer, in accord\n with subsection 6b.\n\n d) Convey the object code by offering access from a designated\n place (gratis or for a charge), and offer equivalent access to the\n Corresponding Source in the same way through the same place at no\n further charge. You need not require recipients to copy the\n Corresponding Source along with the object code. If the place to\n copy the object code is a network server, the Corresponding Source\n may be on a different server (operated by you or a third party)\n that supports equivalent copying facilities, provided you maintain\n clear directions next to the object code saying where to find the\n Corresponding Source. Regardless of what server hosts the\n Corresponding Source, you remain obligated to ensure that it is\n available for as long as needed to satisfy these requirements.\n\n e) Convey the object code using peer-to-peer transmission, provided\n you inform other peers where the object code and Corresponding\n Source of the work are being offered to the general public at no\n charge under subsection 6d.\n\n A separable portion of the object code, whose source code is excluded\nfrom the Corresponding Source as a System Library, need not be\nincluded in conveying the object code work.\n\n A \"User Product\" is either (1) a \"consumer product\", which means any\ntangible personal property which is normally used for personal, family,\nor household purposes, or (2) anything designed or sold for incorporation\ninto a dwelling. In determining whether a product is a consumer product,\ndoubtful cases shall be resolved in favor of coverage. For a particular\nproduct received by a particular user, \"normally used\" refers to a\ntypical or common use of that class of product, regardless of the status\nof the particular user or of the way in which the particular user\nactually uses, or expects or is expected to use, the product. A product\nis a consumer product regardless of whether the product has substantial\ncommercial, industrial or non-consumer uses, unless such uses represent\nthe only significant mode of use of the product.\n\n \"Installation Information\" for a User Product means any methods,\nprocedures, authorization keys, or other information required to install\nand execute modified versions of a covered work in that User Product from\na modified version of its Corresponding Source. The information must\nsuffice to ensure that the continued functioning of the modified object\ncode is in no case prevented or interfered with solely because\nmodification has been made.\n\n If you convey an object code work under this section in, or with, or\nspecifically for use in, a User Product, and the conveying occurs as\npart of a transaction in which the right of possession and use of the\nUser Product is transferred to the recipient in perpetuity or for a\nfixed term (regardless of how the transaction is characterized), the\nCorresponding Source conveyed under this section must be accompanied\nby the Installation Information. But this requirement does not apply\nif neither you nor any third party retains the ability to install\nmodified object code on the User Product (for example, the work has\nbeen installed in ROM).\n\n The requirement to provide Installation Information does not include a\nrequirement to continue to provide support service, warranty, or updates\nfor a work that has been modified or installed by the recipient, or for\nthe User Product in which it has been modified or installed. Access to a\nnetwork may be denied when the modification itself materially and\nadversely affects the operation of the network or violates the rules and\nprotocols for communication across the network.\n\n Corresponding Source conveyed, and Installation Information provided,\nin accord with this section must be in a format that is publicly\ndocumented (and with an implementation available to the public in\nsource code form), and must require no special password or key for\nunpacking, reading or copying.\n\n 7. Additional Terms.\n\n \"Additional permissions\" are terms that supplement the terms of this\nLicense by making exceptions from one or more of its conditions.\nAdditional permissions that are applicable to the entire Program shall\nbe treated as though they were included in this License, to the extent\nthat they are valid under applicable law. If additional permissions\napply only to part of the Program, that part may be used separately\nunder those permissions, but the entire Program remains governed by\nthis License without regard to the additional permissions.\n\n When you convey a copy of a covered work, you may at your option\nremove any additional permissions from that copy, or from any part of\nit. (Additional permissions may be written to require their own\nremoval in certain cases when you modify the work.) You may place\nadditional permissions on material, added by you to a covered work,\nfor which you have or can give appropriate copyright permission.\n\n Notwithstanding any other provision of this License, for material you\nadd to a covered work, you may (if authorized by the copyright holders of\nthat material) supplement the terms of this License with terms:\n\n a) Disclaiming warranty or limiting liability differently from the\n terms of sections 15 and 16 of this License; or\n\n b) Requiring preservation of specified reasonable legal notices or\n author attributions in that material or in the Appropriate Legal\n Notices displayed by works containing it; or\n\n c) Prohibiting misrepresentation of the origin of that material, or\n requiring that modified versions of such material be marked in\n reasonable ways as different from the original version; or\n\n d) Limiting the use for publicity purposes of names of licensors or\n authors of the material; or\n\n e) Declining to grant rights under trademark law for use of some\n trade names, trademarks, or service marks; or\n\n f) Requiring indemnification of licensors and authors of that\n material by anyone who conveys the material (or modified versions of\n it) with contractual assumptions of liability to the recipient, for\n any liability that these contractual assumptions directly impose on\n those licensors and authors.\n\n All other non-permissive additional terms are considered \"further\nrestrictions\" within the meaning of section 10. If the Program as you\nreceived it, or any part of it, contains a notice stating that it is\ngoverned by this License along with a term that is a further\nrestriction, you may remove that term. If a license document contains\na further restriction but permits relicensing or conveying under this\nLicense, you may add to a covered work material governed by the terms\nof that license document, provided that the further restriction does\nnot survive such relicensing or conveying.\n\n If you add terms to a covered work in accord with this section, you\nmust place, in the relevant source files, a statement of the\nadditional terms that apply to those files, or a notice indicating\nwhere to find the applicable terms.\n\n Additional terms, permissive or non-permissive, may be stated in the\nform of a separately written license, or stated as exceptions;\nthe above requirements apply either way.\n\n 8. Termination.\n\n You may not propagate or modify a covered work except as expressly\nprovided under this License. Any attempt otherwise to propagate or\nmodify it is void, and will automatically terminate your rights under\nthis License (including any patent licenses granted under the third\nparagraph of section 11).\n\n However, if you cease all violation of this License, then your\nlicense from a particular copyright holder is reinstated (a)\nprovisionally, unless and until the copyright holder explicitly and\nfinally terminates your license, and (b) permanently, if the copyright\nholder fails to notify you of the violation by some reasonable means\nprior to 60 days after the cessation.\n\n Moreover, your license from a particular copyright holder is\nreinstated permanently if the copyright holder notifies you of the\nviolation by some reasonable means, this is the first time you have\nreceived notice of violation of this License (for any work) from that\ncopyright holder, and you cure the violation prior to 30 days after\nyour receipt of the notice.\n\n Termination of your rights under this section does not terminate the\nlicenses of parties who have received copies or rights from you under\nthis License. If your rights have been terminated and not permanently\nreinstated, you do not qualify to receive new licenses for the same\nmaterial under section 10.\n\n 9. Acceptance Not Required for Having Copies.\n\n You are not required to accept this License in order to receive or\nrun a copy of the Program. Ancillary propagation of a covered work\noccurring solely as a consequence of using peer-to-peer transmission\nto receive a copy likewise does not require acceptance. However,\nnothing other than this License grants you permission to propagate or\nmodify any covered work. These actions infringe copyright if you do\nnot accept this License. Therefore, by modifying or propagating a\ncovered work, you indicate your acceptance of this License to do so.\n\n 10. Automatic Licensing of Downstream Recipients.\n\n Each time you convey a covered work, the recipient automatically\nreceives a license from the original licensors, to run, modify and\npropagate that work, subject to this License. You are not responsible\nfor enforcing compliance by third parties with this License.\n\n An \"entity transaction\" is a transaction transferring control of an\norganization, or substantially all assets of one, or subdividing an\norganization, or merging organizations. If propagation of a covered\nwork results from an entity transaction, each party to that\ntransaction who receives a copy of the work also receives whatever\nlicenses to the work the party's predecessor in interest had or could\ngive under the previous paragraph, plus a right to possession of the\nCorresponding Source of the work from the predecessor in interest, if\nthe predecessor has it or can get it with reasonable efforts.\n\n You may not impose any further restrictions on the exercise of the\nrights granted or affirmed under this License. For example, you may\nnot impose a license fee, royalty, or other charge for exercise of\nrights granted under this License, and you may not initiate litigation\n(including a cross-claim or counterclaim in a lawsuit) alleging that\nany patent claim is infringed by making, using, selling, offering for\nsale, or importing the Program or any portion of it.\n\n 11. Patents.\n\n A \"contributor\" is a copyright holder who authorizes use under this\nLicense of the Program or a work on which the Program is based. The\nwork thus licensed is called the contributor's \"contributor version\".\n\n A contributor's \"essential patent claims\" are all patent claims\nowned or controlled by the contributor, whether already acquired or\nhereafter acquired, that would be infringed by some manner, permitted\nby this License, of making, using, or selling its contributor version,\nbut do not include claims that would be infringed only as a\nconsequence of further modification of the contributor version. For\npurposes of this definition, \"control\" includes the right to grant\npatent sublicenses in a manner consistent with the requirements of\nthis License.\n\n Each contributor grants you a non-exclusive, worldwide, royalty-free\npatent license under the contributor's essential patent claims, to\nmake, use, sell, offer for sale, import and otherwise run, modify and\npropagate the contents of its contributor version.\n\n In the following three paragraphs, a \"patent license\" is any express\nagreement or commitment, however denominated, not to enforce a patent\n(such as an express permission to practice a patent or covenant not to\nsue for patent infringement). To \"grant\" such a patent license to a\nparty means to make such an agreement or commitment not to enforce a\npatent against the party.\n\n If you convey a covered work, knowingly relying on a patent license,\nand the Corresponding Source of the work is not available for anyone\nto copy, free of charge and under the terms of this License, through a\npublicly available network server or other readily accessible means,\nthen you must either (1) cause the Corresponding Source to be so\navailable, or (2) arrange to deprive yourself of the benefit of the\npatent license for this particular work, or (3) arrange, in a manner\nconsistent with the requirements of this License, to extend the patent\nlicense to downstream recipients. \"Knowingly relying\" means you have\nactual knowledge that, but for the patent license, your conveying the\ncovered work in a country, or your recipient's use of the covered work\nin a country, would infringe one or more identifiable patents in that\ncountry that you have reason to believe are valid.\n\n If, pursuant to or in connection with a single transaction or\narrangement, you convey, or propagate by procuring conveyance of, a\ncovered work, and grant a patent license to some of the parties\nreceiving the covered work authorizing them to use, propagate, modify\nor convey a specific copy of the covered work, then the patent license\nyou grant is automatically extended to all recipients of the covered\nwork and works based on it.\n\n A patent license is \"discriminatory\" if it does not include within\nthe scope of its coverage, prohibits the exercise of, or is\nconditioned on the non-exercise of one or more of the rights that are\nspecifically granted under this License. You may not convey a covered\nwork if you are a party to an arrangement with a third party that is\nin the business of distributing software, under which you make payment\nto the third party based on the extent of your activity of conveying\nthe work, and under which the third party grants, to any of the\nparties who would receive the covered work from you, a discriminatory\npatent license (a) in connection with copies of the covered work\nconveyed by you (or copies made from those copies), or (b) primarily\nfor and in connection with specific products or compilations that\ncontain the covered work, unless you entered into that arrangement,\nor that patent license was granted, prior to 28 March 2007.\n\n Nothing in this License shall be construed as excluding or limiting\nany implied license or other defenses to infringement that may\notherwise be available to you under applicable patent law.\n\n 12. No Surrender of Others' Freedom.\n\n If conditions are imposed on you (whether by court order, agreement or\notherwise) that contradict the conditions of this License, they do not\nexcuse you from the conditions of this License. If you cannot convey a\ncovered work so as to satisfy simultaneously your obligations under this\nLicense and any other pertinent obligations, then as a consequence you may\nnot convey it at all. For example, if you agree to terms that obligate you\nto collect a royalty for further conveying from those to whom you convey\nthe Program, the only way you could satisfy both those terms and this\nLicense would be to refrain entirely from conveying the Program.\n\n 13. Use with the GNU Affero General Public License.\n\n Notwithstanding any other provision of this License, you have\npermission to link or combine any covered work with a work licensed\nunder version 3 of the GNU Affero General Public License into a single\ncombined work, and to convey the resulting work. The terms of this\nLicense will continue to apply to the part which is the covered work,\nbut the special requirements of the GNU Affero General Public License,\nsection 13, concerning interaction through a network will apply to the\ncombination as such.\n\n 14. Revised Versions of this License.\n\n The Free Software Foundation may publish revised and/or new versions of\nthe GNU General Public License from time to time. Such new versions will\nbe similar in spirit to the present version, but may differ in detail to\naddress new problems or concerns.\n\n Each version is given a distinguishing version number. If the\nProgram specifies that a certain numbered version of the GNU General\nPublic License \"or any later version\" applies to it, you have the\noption of following the terms and conditions either of that numbered\nversion or of any later version published by the Free Software\nFoundation. If the Program does not specify a version number of the\nGNU General Public License, you may choose any version ever published\nby the Free Software Foundation.\n\n If the Program specifies that a proxy can decide which future\nversions of the GNU General Public License can be used, that proxy's\npublic statement of acceptance of a version permanently authorizes you\nto choose that version for the Program.\n\n Later license versions may give you additional or different\npermissions. However, no additional obligations are imposed on any\nauthor or copyright holder as a result of your choosing to follow a\nlater version.\n\n 15. Disclaimer of Warranty.\n\n THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY\nAPPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT\nHOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY\nOF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,\nTHE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR\nPURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM\nIS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF\nALL NECESSARY SERVICING, REPAIR OR CORRECTION.\n\n 16. Limitation of Liability.\n\n IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\nWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS\nTHE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY\nGENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE\nUSE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF\nDATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD\nPARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),\nEVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF\nSUCH DAMAGES.\n\n 17. Interpretation of Sections 15 and 16.\n\n If the disclaimer of warranty and limitation of liability provided\nabove cannot be given local legal effect according to their terms,\nreviewing courts shall apply local law that most closely approximates\nan absolute waiver of all civil liability in connection with the\nProgram, unless a warranty or assumption of liability accompanies a\ncopy of the Program in return for a fee.\n\n END OF TERMS AND CONDITIONS\n\n How to Apply These Terms to Your New Programs\n\n If you develop a new program, and you want it to be of the greatest\npossible use to the public, the best way to achieve this is to make it\nfree software which everyone can redistribute and change under these terms.\n\n To do so, attach the following notices to the program. It is safest\nto attach them to the start of each source file to most effectively\nstate the exclusion of warranty; and each file should have at least\nthe \"copyright\" line and a pointer to where the full notice is found.\n\n \n Copyright (C) \n\n This program is free software: you can redistribute it and/or modify\n it under the terms of the GNU General Public License as published by\n the Free Software Foundation, either version 3 of the License, or\n (at your option) any later version.\n\n This program is distributed in the hope that it will be useful,\n but WITHOUT ANY WARRANTY; without even the implied warranty of\n MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n GNU General Public License for more details.\n\n You should have received a copy of the GNU General Public License\n along with this program. If not, see .\n\nAlso add information on how to contact you by electronic and paper mail.\n\n If the program does terminal interaction, make it output a short\nnotice like this when it starts in an interactive mode:\n\n Copyright (C) \n This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.\n This is free software, and you are welcome to redistribute it\n under certain conditions; type `show c' for details.\n\nThe hypothetical commands `show w' and `show c' should show the appropriate\nparts of the General Public License. Of course, your program's commands\nmight be different; for a GUI interface, you would use an \"about box\".\n\n You should also get your employer (if you work as a programmer) or school,\nif any, to sign a \"copyright disclaimer\" for the program, if necessary.\nFor more information on this, and how to apply and follow the GNU GPL, see\n.\n\n The GNU General Public License does not permit incorporating your program\ninto proprietary programs. If your program is a subroutine library, you\nmay consider it more useful to permit linking proprietary applications with\nthe library. If this is what you want to do, use the GNU Lesser General\nPublic License instead of this License. But first, please read\n.\n" }, { "path": "Makefile", "content": "#\n# Makefile for SEISMIC_CPML Version 1.2, April 2015.\n# Dimitri Komatitsch, CNRS, France\n#\nSHELL=/bin/sh\n\nO = obj\n\n# the MEDIUM_MEMORY flag is for large 3D runs, which need more than 2 GB of memory\n\n# Portland\n#F90 = pgf90\n#MPIF90 = mpif90\n#FLAGS = -fast -Mnobounds -Minline -Mneginfo -Mdclchk -Knoieee -Minform=warn -fastsse -tp amd64e -Msmart\n#MEDIUM_MEMORY = -mcmodel=medium\n#OPEN_MP = -mp\n\n# Intel (leave option -ftz, which can be *critical* for performance)\n#F90 = ifort\n#MPIF90 = mpif90\n#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\n#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\n#MEDIUM_MEMORY = -mcmodel=medium\n#OPEN_MP = -openmp -openmp-report1\n\n# IBM xlf\n#F90 = xlf_r\n#MPIF90 = mpxlf_r\n#FLAGS = -O3 -qfree=f90 -qhalt=w -qsave\n#MEDIUM_MEMORY = -q64\n#OPEN_MP = -qsmp=omp\n\n# GNU gfortran\nF90 = gfortran\nMPIF90 = mpif90\nFLAGS = -std=gnu -fimplicit-none -frange-check -O3 -fmax-errors=10 -pedantic -pedantic-errors -Waliasing -Wampersand -Wcharacter-truncation -Wline-truncation -Wsurprising -Wno-tabs -Wunderflow\nMEDIUM_MEMORY = -mcmodel=medium\n#OPEN_MP = -fopenmp\n\ndefault: 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\n\nall: default\n\nclean:\n\t/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\n\nseismic_CPML_2D_velocity_and_stress_second_order_viscoelastic:\n\t$(F90) $(FLAGS) -o xseismic_CPML_2D_velocity_and_stress_second_order_viscoelastic seismic_CPML_2D_velocity_and_stress_second_order_viscoelastic.f90\n\nseismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic:\n\t$(F90) $(FLAGS) -o xseismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic.f90\n\nseismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic:\n\t$(F90) $(FLAGS) -o xseismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic seismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic.f90\n\nseismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic:\n\t$(F90) $(FLAGS) -o xseismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic seismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic.f90\n\nseismic_ADEPML_2D_elastic_RK4_eighth_order:\n\t$(F90) $(FLAGS) -o xseismic_ADEPML_2D_elastic_RK4_eighth_order seismic_ADEPML_2D_elastic_RK4_eighth_order.f90\n\nseismic_ADEPML_2D_viscoelastic_RK4_eighth_order:\n\t$(F90) $(FLAGS) -o xseismic_ADEPML_2D_viscoelastic_RK4_eighth_order seismic_ADEPML_2D_viscoelastic_RK4_eighth_order.f90\n\nseismic_CPML_2D_poroelastic_fourth_order:\n\t$(F90) $(FLAGS) -o xseismic_CPML_2D_poroelastic_fourth_order seismic_CPML_2D_poroelastic_fourth_order.f90\n\nseismic_CPML_2D_pressure_second_order:\n\t$(F90) $(FLAGS) -o xseismic_CPML_2D_pressure_second_order seismic_CPML_2D_pressure_second_order.f90\n\nseismic_CPML_2D_isotropic_second_order:\n\t$(F90) $(FLAGS) -o xseismic_CPML_2D_isotropic_second_order seismic_CPML_2D_isotropic_second_order.f90\n\nseismic_CPML_2D_isotropic_fourth_order:\n\t$(F90) $(FLAGS) -o xseismic_CPML_2D_isotropic_fourth_order seismic_CPML_2D_isotropic_fourth_order.f90\n\nseismic_CPML_2D_anisotropic:\n\t$(F90) $(FLAGS) -o xseismic_CPML_2D_anisotropic seismic_CPML_2D_anisotropic.f90\n\nseismic_PML_Collino_2D_isotropic:\n\t$(F90) $(FLAGS) -o xseismic_PML_Collino_2D_isotropic seismic_PML_Collino_2D_isotropic.f90\n\nseismic_PML_Collino_2D_anisotropic_fourth:\n\t$(F90) $(FLAGS) -o xseismic_PML_Collino_2D_anisotropic_fourth seismic_PML_Collino_2D_anisotropic_fourth.f90\n\nseismic_PML_Collino_3D_isotropic_OpenMP:\n\t$(F90) $(FLAGS) $(MEDIUM_MEMORY) $(OPEN_MP) -o xseismic_PML_Collino_3D_isotropic_OpenMP seismic_PML_Collino_3D_isotropic_OpenMP.f90\n\nseismic_CPML_3D_isotropic_MPI_OpenMP:\n\t$(MPIF90) $(FLAGS) $(MEDIUM_MEMORY) $(OPEN_MP) -o xseismic_CPML_3D_isotropic_MPI_OpenMP seismic_CPML_3D_isotropic_MPI_OpenMP.f90\n\nseismic_CPML_3D_viscoelastic_MPI:\n\t$(MPIF90) $(FLAGS) $(MEDIUM_MEMORY) $(OPEN_MP) -o xseismic_CPML_3D_viscoelastic_MPI seismic_CPML_3D_viscoelastic_MPI.f90\n\n" }, { "path": "README", "content": "seismic_cpml\n============\n\nSEISMIC_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.\n\nSee README_seismic_cpml.html in this directory for more details.\n\n" }, { "path": "README_seismic_cpml.html", "content": "\n\n\n\t\n\tThe SEISMIC_CPML software package\n\t\n\t\n\t\n\t\n\n\n

Home page of Dimitri\nKomatitsch

\n

\n

\n

 

\n

SEISMIC_CPML\nis a set of fourteen\nopen-source\nFortran90 programs under the GNU GPL version 3\nlicense to solve\nthe two-dimensional or three-dimensional isotropic or anisotropic\nacoustic, elastic, viscoelastic or poroelastic wave equation using a\nfinite-difference method with Convolutional or Auxiliary Perfectly\nMatched Layer (C-PML or ADE-PML) conditions, developed by Dimitri\nKomatitsch and Roland Martin from CNRS, France. Contributions by\nother authors have recently been added. \n

\n

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

\n

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

\n

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

\n

Dimitri Komatitsch and\nRoland Martin, An\nunsplit convolutional Perfectly Matched Layer improved at grazing\nincidence for the seismic wave equation,\nGeophysics, vol.\n72(5), p SM155-SM167, doi: 10.1190/1.2757586 (2007). Preprint\nBibTeX

\n

It was originally developed\nfor Maxwell's equations by Roden and Gedney (2000) (see reference\nbelow).

\n

An extension to\nviscoelastic media is developed in:

\n

Roland Martin and\nDimitri Komatitsch, An\nunsplit convolutional perfectly matched layer technique improved at\ngrazing incidence for the viscoelastic wave equation, Geophysical\nJournal International,\nvol. 179(1), p. 333-344, doi:\n10.1111/j.1365-246X.2009.04278.x (2009).\nPreprint\nBibTeX

\n

and the viscoelastic\nparameters of the Zener body model used to fit a constant-Q model are\ncomputed based upon:

\n

Émilie\nBlanc, Dimitri Komatitsch, Emmanuel Chaljub, Bruno\nLombard\nand Zhinan Xie,\nHighly-accurate stability-preserving optimization of the Zener\nviscoelastic model, with application to wave propagation in the\npresence of strong attenuation, Geophysical\nJournal International, vol.\n205(1), p. 427-439, doi:\n10.1093/gji/ggw024 (2016).\nPreprint\nBibTeX

\n


\n
\n\n

\n

An extension to poroelastic\nmedia is developed in:

\n

Roland Martin, Dimitri\nKomatitsch and Abdelaâziz Ezziani,\nAn\nunsplit convolutional Perfectly Matched Layer improved at grazing\nincidence for seismic wave propagation in poroelastic media,\nGeophysics, vol.\n73(4), p T51-T61, doi: 10.1190/1.2939484 (2008). Preprint\nBibTeX

\n

and a variational\nformulation is developed in:

\n

Roland Martin, Dimitri\nKomatitsch and\nStephen D. Gedney,\nA variational formulation of a stabilized unsplit convolutional\nperfectly matched layer for the isotropic or anisotropic seismic wave\nequation, Computer\nModeling in Engineering and Sciences,\nvol. 37(3), p. 274-304 (2008). Preprint\nBibTeX

\n

An extension to\nhigher-order time schemes, called ADE-PML (Auxiliary Differential\nEquation - PML) is developed in:

\n

Roland\nMartin, Dimitri Komatitsch, Stephen D. Gedney and Émilien Bruthiaux,\nA high-order time and space formulation of the unsplit perfectly\nmatched layer for the seismic wave equation using Auxiliary\nDifferential Equations (ADE-PML), Computer\nModeling in Engineering and Sciences,\nvol. 56(1), p. 17-42 (2010). Preprint\nBibTeX

\n

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

\n

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

\n

This software is governed\nby the GNU GPL\nversion 3\nlicense.

\n

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

\n

@ARTICLE{BlKoChLoXi16,\n
\ntitle = {Highly accurate stability-preserving optimization of\nthe {Z}ener viscoelastic model, with application to wave propagation\nin the presence of strong attenuation},
\nauthor = {\\'Emilie\nBlanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard\nand Zhinan Xie},
\njournal = {Geophysical Journal\nInternational},
\nyear = {2016},
\nnumber = {1},
\npages =\n{427-439},
\nvolume = {205},
\ndoi = {10.1093/gji/ggw024}} \n

\n

@ARTICLE{MaKo09,
\nauthor\n= {Roland Martin and Dimitri Komatitsch},
\ntitle = {An unsplit\nconvolutional perfectly matched layer technique improved at grazing\nincidence for the viscoelastic wave equation},
\njournal =\n{Geophysical Journal International},
\nyear = {2009},
\nvolume\n= {179},
\nnumber = {1},
\npages = {333-344},
\ndoi =\n{10.1111/j.1365-246X.2009.04278.x}}
\n
\n@ARTICLE{MaKoEz08,
\nauthor\n= {Roland Martin and Dimitri Komatitsch and Abdelaaziz\nEzziani},
\ntitle = {An unsplit convolutional perfectly matched\nlayer improved at grazing incidence for seismic wave equation in\nporoelastic media},
\njournal = {Geophysics},
\nyear =\n{2008},
\nvolume = {73},
\npages = {T51-T61},
\nnumber =\n{4},
\ndoi = {10.1190/1.2939484}}
\n
\n@ARTICLE{MaKoGe08,
\nauthor\n= {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},
\ntitle\n= {A variational formulation of a stabilized unsplit convolutional\nperfectly matched layer for the isotropic or anisotropic seismic wave\nequation},
\njournal = {Computer Modeling in Engineering and\nSciences},
\nyear = {2008},
\nvolume = {37},
\npages =\n{274-304},
\nnumber = {3}}

\n

@ARTICLE{MaKoGeBr10,
\nauthor\n= {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney and\nEmilien Bruthiaux},
\ntitle = {A high-order time and space\nformulation of the unsplit perfectly matched layer for the seismic\nwave equation using {Auxiliary Differential Equations\n(ADE-PML)}},
\njournal = {Computer Modeling in Engineering and\nSciences},
\nyear = {2010},
\nvolume = {56},
\npages =\n{17-42},
\nnumber = {1}}

\n

@ARTICLE{KoMa07,
\nauthor\n= {Dimitri Komatitsch and Roland Martin},
\ntitle = {An unsplit\nconvolutional {P}erfectly {M}atched {L}ayer improved at grazing\nincidence for the seismic wave equation},
\njournal =\n{Geophysics},
\nyear = {2007},
\nvolume = {72},
\nnumber =\n{5},
\npages = {SM155-SM167},
\ndoi = {10.1190/1.2757586}}

\n


\n
\n\n

\n

Roden\nand Gedney's original article for Maxwell's equations\nis:
\n
\n
\n@ARTICLE{RoGe00,
\nauthor\n= {J. A. Roden and S. D. Gedney},
\ntitle = {Convolution {PML}\n({CPML}): {A}n Efficient {FDTD} Implementation of the {CFS}-{PML} for\nArbitrary Media},
\njournal = {Microwave and Optical Technology\nLetters},
\nyear = {2000},
\nvolume = {27},
\nnumber =\n{5},
\npages = {334-339},
\ndoi =\n{10.1002/1098-2760(20001205)27:5<334::AID-MOP14>3.0.CO;2-A}}
\n
\n
\nThe\npackage is composed of the following fourteen\nprograms:

\n


\n
\n\n

\n

seismic_CPML_2D_pressure_second_order.f90:\n2D C-PML program for an acoustic medium\nusing a second-order finite-difference spatial operator for\nthe pressure equation written as a second-order system in time.

\n

seismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic.f90:\n2D C-PML program for a viscoacoustic\nmedium using a second-order finite-difference spatial operator for\nthe velocity and pressure equation written as a split first-order\nsystem in time.

\n

seismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic.f90:\n2D C-PML program for a\nviscoacoustic\nmedium using a fourth-order\nfinite-difference spatial operator for\nthe velocity and pressure equation written as a split first-order\nsystem in time.

\n

seismic_CPML_2D_isotropic_second_order.f90:\n2D C-PML program for an elastic isotropic medium using a second-order\nfinite-difference spatial operator.

\n

seismic_CPML_2D_isotropic_fourth_order.f90:\n2D C-PML program for an elastic isotropic medium using a fourth-order\nfinite-difference spatial operator.

\n

seismic_CPML_2D_anisotropic.f90:\n2D C-PML program for an elastic anisotropic medium using a\nsecond-order finite-difference spatial operator. More precisely we\nimplement a “Modified PML / M-PML” based on Meza-Fajardo and\nPapageorgiou, Bulletin\nof the Seismological Society of America,\nvol. 98(4), p. 1811-1836 (2008). Strictly speaking the layers are not\nperfectly matched any more from a mathematical point of view, but the\ncode works well in practice.

\n

seismic_CPML_2D_poroelastic_fourth_order.f90:\n2D C-PML program for a poroelastic medium using a fourth-order\nfinite-difference spatial operator.

\n

seismic_ADEPML_2D_elastic_RK4_eighth_order.f90:\n2D ADE-PML program for an isotropic elastic medium using an\neighth-order finite-difference spatial operator and fourth-order\nRunge-Kutta implicit, semi implicit or explicit time scheme.

\n

seismic_ADEPML_2D_viscoelastic_RK4_eighth_order.f90:\n2D ADE-PML program for an isotropic viscoelastic medium using an\neighth-order finite-difference spatial operator and fourth-order\nRunge-Kutta implicit, semi implicit or explicit time scheme.

\n

seismic_PML_Collino_2D_isotropic.f90:\n2D classical split PML program for an isotropic medium using a\nsecond-order finite-difference spatial operator, for comparison.

\n

seismic_PML_Collino_2D_anisotropic_fourth.f90:\n2D classical split PML program for an anisotropic medium using a\nfourth-order finite-difference spatial operator, for comparison.

\n

seismic_CPML_3D_isotropic_MPI_OpenMP.f90:\n3D C-PML program for an isotropic medium using a second-order\nfinite-difference spatial operator. Parallel implementation based on\nboth MPI and OpenMP.

\n

seismic_PML_Collino_3D_isotropic_OpenMP.f90:\n3D classical split PML program for an isotropic medium using a\nsecond-order finite-difference spatial operator, for comparison.\nParallel implementation based on OpenMP.

\n

seismic_CPML_3D_viscoelastic_MPI.f90:\n3D C-PML program for a viscoelastic medium using a fourth-order\nfinite-difference spatial operator. Parallel implementation based on\nMPI.

\n

Makefile:\na standard Makefile. You can type “make all” to compile all the\ncodes.

\n

For\nmore details about the classical PML, see for instance Wikipedia\nabout PML.

\n

For\nmore details about finite differences in the time domain (FDTD), see\nfor instance Wikipedia\nabout FDTD.

\n

Home\npage of Dimitri Komatitsch

\n\n" }, { "path": "analytical_solution_viscoacoustic_Carcione_version1.f90", "content": "\n program analytical_solution\n\n!! DK DK to compare to our finite-difference codes from SEISMIC_CPML or SOUNDVIEW,\n!! 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,\n!! DK DK while the convention used by Carcione in his 1988 paper is to use a source of amplitude 4 * PI * cp^2\n\n! this program implements the analytical solution for a viscoacoustic medium\n! from Carcione et al., Wave propagation simulation in a linear viscoacoustic medium,\n! Geophysical Journal, vol. 93, p. 393-407 (1988)\n\n!! DK DK Dimitri Komatitsch, CNRS Marseille, France, April 2017\n!! DK DK adapted from a program written for the viscoelastic case by Jose' M. Carcione.\n\n implicit none\n\n! compute the non-viscoacoustic case as a reference if needed, i.e. turn attenuation off\n logical, parameter :: TURN_ATTENUATION_OFF = .false. ! .true.\n\n!! DK DK Dimitri Komatitsch, CNRS Marseille, France, October 2015:\n!! DK DK by default I turned off the fix for attenuation causality (using the unrelaxed velocities\n!! DK DK as reference instead of the relaxed ones) because it is not useful any more,\n!! DK DK this modification was not consistent with the calculations of the tau values\n!! DK DK made by Carcione et al. 1988 and by Carcione 1993.\n!! Comment from Quentin Brissaud, March 2018:\n!! This flag will tell the code that the input velocities are the relaxed one (omega -> zero frequency)\n!! instead of the unrelaxed ones (by default omega -> + infinity)\n logical, parameter :: FIX_ATTENUATION_CAUSALITY = .true.\n\n integer, parameter :: iratio = 64\n\n integer, parameter :: nfreq = 524288\n integer, parameter :: nt = iratio * nfreq\n\n double precision, parameter :: freqmax = 1000.d0 ! 225.d0\n!! DK DK to print the velocity if we want to display the curve of how velocity varies with frequency\n!! DK DK for instance to compute the unrelaxed velocity in the Zener model\n! double precision, parameter :: freqmax = 20000.d0\n\n double precision, parameter :: freqseuil = 0.00005d0\n\n double precision, parameter :: pi = 3.141592653589793d0\n\n! for the solution in time domain\n integer it\n real wsave(4*nt+15)\n complex c(nt)\n\n!! DK DK for my slow inverse Discrete Fourier Transform using a double loop\n complex :: input(nt), i_imaginary_constant\n integer :: j,m\n\n! density of the medium\n double precision, parameter :: rho = 2000.d0\n\n! definition position recepteur Carcione\n double precision x1,x2\n\n! Definition source Dimitri\n double precision, parameter :: f0 = 35.d0\n double precision, parameter :: t0 = 1.2d0 / f0\n\n! Definition source Carcione\n! double precision f0,t0,eta,epsil\n! parameter(f0 = 50.d0)\n! parameter(t0 = 0.06d0)\n! parameter(epsil = 1.d0)\n! parameter(eta = 0.5d0)\n\n! number of Zener standard linear solids in parallel\n! integer, parameter :: L_mech = 5\n integer, parameter :: L_mech = 3\n\n! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform\n! DK DK at some point, for verification, using a double loop. I keep it just in case.\n! DK DK For large number of points it is extremely slow because of the double loop.\n! DK DK Thus there is no reason to turn this flag on.\n logical, parameter :: USE_SLOW_FOURIER_TRANSFORM = .false.\n\n! attenuation constants from Carcione 1988 GJI vol 95 p 604\n double precision, dimension(L_mech) :: tau_epsilon_nu1, tau_sigma_nu1\n\n! this value comes from page 397 of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium,\n! Geophysical Journal, vol. 93, p. 393-407 (1988)\n double precision, parameter :: vp = 2000.d0\n double precision, parameter :: M_relaxed = rho*vp**2\n\n integer :: ifreq,i_mech,iposition\n double precision :: deltafreq,freq,omega,omega0,deltat,time,a,sum_of_coefficients\n double complex :: comparg,sum_to_compute\n\n! Fourier transform of the Ricker wavelet source\n double complex fomega(0:nfreq)\n\n! real and imaginary parts\n double precision ra(0:nfreq),rb(0:nfreq)\n\n! spectral amplitude\n double precision ampli(0:nfreq)\n\n! analytical solution for the single scalar component (pressure)\n double complex phi1(-nfreq:nfreq)\n\n! external functions\n double complex, external :: u1\n\n! modules elastiques\n double complex :: MC, V1\n\n! ********** end of variable declarations ************\n\n!! DK DK July 2018: values computed to fit Q = 65 for the example I designed for the \"SOUNDVIEW\" finite-difference code\n tau_epsilon_nu1 = (/ 2.408158185805540d-002, 4.699608990946073d-003, 9.567997872679109d-004/)\n tau_sigma_nu1 = (/ 2.256014638685252d-002, 4.508471279793884d-003, 8.937876403997143d-004/)\n\n! position of the receiver\n do iposition = 1,3\n\n if (iposition == 1) then\n x1 = +200.\n x2 = +200.\n else if (iposition == 2) then\n x1 = +500.\n x2 = +500.\n else\n!!!!!!!! x1 = +800.\n!!!!!!!! x2 = +800.\n!! DK DK modified to fall exactly on a grid point\n x1 = +801.\n x2 = +801.\n endif\n\n print *,'Pressure source located at the origin (0,0)'\n print *,'Receiver located in (x,z) = ',x1,x2\n\n if (TURN_ATTENUATION_OFF) then\n print *,'BEWARE: computing the acoustic reference solution (i.e., without attenuation) instead of the viscoacoustic solution'\n else\n print *,'Computing the viscoacoustic solution'\n endif\n\n! step in frequency\n deltafreq = freqmax / dble(nfreq)\n\n! define parameters for the Ricker source\n omega0 = 2.d0 * pi * f0\n a = pi**2 * f0**2\n\n deltat = 1.d0 / (freqmax*dble(iratio))\n print *,'deltat = ',deltat\n\n! define the spectrum of the source\n do ifreq=0,nfreq\n freq = deltafreq * dble(ifreq)\n omega = 2.d0 * pi * freq\n\n! typo in equation (B10) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium,\n! Geophysical Journal, vol. 93, p. 393-407 (1988), the exponential is of -i omega t0,\n! fixed here by adding the minus sign\n comparg = dcmplx(0.d0,-omega*t0)\n\n! definir le spectre du Ricker de Carcione avec cos()\n! equation (B10) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium,\n! Geophysical Journal, vol. 93, p. 393-407 (1988)\n! fomega(ifreq) = pi * dsqrt(pi/eta) * (1.d0/omega0) * cdexp(comparg) * ( dexp(- (pi*pi/eta) * (epsil/2 - omega/omega0)**2) &\n! + dexp(- (pi*pi/eta) * (epsil/2 + omega/omega0)**2) )\n\n! definir le spectre d'un Ricker classique (centre en t0)\n fomega(ifreq) = dsqrt(pi) * cdexp(comparg) * omega**2 * dexp(-omega**2/(4.d0*a)) / (2.d0 * dsqrt(a**3))\n\n!! DK DK to compare to our finite-difference codes from SEISMIC_CPML or SOUNDVIEW,\n!! 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,\n!! DK DK while the convention used by Carcione in his 1988 paper is to use a source of amplitude 4 * PI * cp^2\n fomega(ifreq) = fomega(ifreq) / (4.d0 * PI * vp**2)\n\n ra(ifreq) = dreal(fomega(ifreq))\n rb(ifreq) = dimag(fomega(ifreq))\n! prendre le module de l'amplitude spectrale\n ampli(ifreq) = dsqrt(ra(ifreq)**2 + rb(ifreq)**2)\n enddo\n\n! sauvegarde du spectre d'amplitude de la source en Hz au format Gnuplot\n open(unit=10,file='spectrum_of_the_source_used.gnu',status='unknown')\n do ifreq = 0,nfreq\n freq = deltafreq * dble(ifreq)\n write(10,*) sngl(freq),sngl(ampli(ifreq))\n enddo\n close(10)\n\n! ************** calcul solution analytique ****************\n\n! d'apres Carcione GJI vol 95 p 611 (1988)\n do ifreq=0,nfreq\n freq = deltafreq * dble(ifreq)\n omega = 2.d0 * pi * freq\n\n! critere ad-hoc pour eviter singularite en zero\n if (freq < freqseuil) omega = 2.d0 * pi * freqseuil\n\n! equation (16) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium,\n! Geophysical Journal, vol. 93, p. 393-407 (1988)\n sum_to_compute = dcmplx(0.d0,0.d0)\n do i_mech = 1,L_mech\n sum_to_compute = sum_to_compute + dcmplx(1.d0,omega*tau_epsilon_nu1(i_mech)) / dcmplx(1.d0,omega*tau_sigma_nu1(i_mech))\n enddo\n!! DK DK Quentin Brissaud in March 2018 added the 1/L factor here (it is missing in Carcione's older papers)\n MC = M_relaxed * (1.d0 + (1./L_mech)*(-L_mech + sum_to_compute))\n\n! use more standard infinite frequency (unrelaxed) reference,\n! in which waves slow down when attenuation is turned on,\n! or use far less standard zero frequency (relaxed) reference,\n! in which waves speed up when attenuation is turned on\n if (FIX_ATTENUATION_CAUSALITY) then\n sum_of_coefficients = 0.d0\n do i_mech = 1,L_mech\n sum_of_coefficients = sum_of_coefficients + tau_epsilon_nu1(i_mech) / tau_sigma_nu1(i_mech)\n enddo\n!! DK DK Quentin Brissaud in March 2018 added the 1/L factor here (it is missing in Carcione's older papers)\n MC = MC / (1.d0 + (1./L_mech)*(-L_mech + sum_of_coefficients))\n endif\n\n! equation (18) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium,\n! Geophysical Journal, vol. 93, p. 393-407 (1988)\n V1 = cdsqrt(MC / rho)\n\n! compute the non-viscoacoustic case as a reference if needed, i.e. turn attenuation off\n if (TURN_ATTENUATION_OFF) V1 = cdsqrt(dcmplx(M_relaxed,0.d0) / rho)\n\n! calcul de la solution analytique en frequence\n phi1(ifreq) = u1(omega,V1,x1,x2) * fomega(ifreq)\n\n enddo\n\n! take the conjugate value for negative frequencies\n do ifreq=-nfreq,-1\n phi1(ifreq) = dconjg(phi1(-ifreq))\n enddo\n\n! save the result in the frequency domain\n! open(unit=11,file='cmplx_phi',status='unknown')\n! do ifreq=-nfreq,nfreq\n! freq = deltafreq * dble(ifreq)\n! write(11,*) sngl(freq),sngl(dreal(phi1(ifreq))),sngl(dimag(phi1(ifreq)))\n! enddo\n! close(11)\n\n! ***************************************************************************\n! Calculation of the time domain solution (using routine \"cfftb\" from Netlib)\n! ***************************************************************************\n\n! ****************\n! Compute pressure\n! ****************\n\n! initialize FFT arrays\n call cffti(nt,wsave)\n\n! clear array of Fourier coefficients\n do it = 1,nt\n c(it) = cmplx(0.,0.)\n enddo\n\n! use the Fourier values for pressure\n c(1) = cmplx(phi1(0))\n do ifreq=1,nfreq-2\n c(ifreq+1) = cmplx(phi1(ifreq))\n c(nt+1-ifreq) = conjg(cmplx(phi1(ifreq)))\n enddo\n\n! perform the inverse FFT for pressure\n if (.not. USE_SLOW_FOURIER_TRANSFORM) then\n call cfftb(nt,c,wsave)\n else\n! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform here\n! DK DK at some point, for verification, using a double loop. I keep it just in case.\n! DK DK For large number of points it is extremely slow because of the double loop.\n input(:) = c(:)\n! imaginary constant \"i\"\n i_imaginary_constant = (0.,1.)\n do it = 1,nt\n if (mod(it,1000) == 0) print *,'FFT inverse it = ',it,' out of ',nt\n j = it\n c(j) = cmplx(0.,0.)\n do m = 1,nt\n c(j) = c(j) + input(m) * exp(2.d0 * PI * i_imaginary_constant * dble((m-1) * (j-1)) / nt)\n enddo\n enddo\n endif\n\n! in the inverse Discrete Fourier transform one needs to divide by N, the number of samples (number of time steps here)\n c(:) = c(:) / nt\n\n! value of a time step\n deltat = 1.d0 / (freqmax*dble(iratio))\n\n! to get the amplitude right, we need to divide by the time step\n c(:) = c(:) / deltat\n\n! save time result inverse FFT for pressure\n\n if (iposition == 1) then\n if (TURN_ATTENUATION_OFF) then\n open(unit=11,file='pressure_time_analytical_solution_acoustic_200.dat',status='unknown')\n else\n open(unit=11,file='pressure_time_analytical_solution_viscoacoustic_200.dat',status='unknown')\n endif\n else if (iposition == 2) then\n if (TURN_ATTENUATION_OFF) then\n open(unit=11,file='pressure_time_analytical_solution_acoustic_500.dat',status='unknown')\n else\n open(unit=11,file='pressure_time_analytical_solution_viscoacoustic_500.dat',status='unknown')\n endif\n else\n if (TURN_ATTENUATION_OFF) then\n open(unit=11,file='pressure_time_analytical_solution_acoustic_800.dat',status='unknown')\n else\n open(unit=11,file='pressure_time_analytical_solution_viscoacoustic_800.dat',status='unknown')\n endif\n endif\n\n do it=1,nt\n! DK DK Dec 2011: subtract t0 to be consistent with the SPECFEM2D code\n time = dble(it-1)*deltat - t0\n! the seismograms are very long due to the very large number of FFT points used,\n! thus keeping the useful part of the signal only (the first six seconds of the seismogram)\n if (time >= 0.d0 .and. time <= 6.d0) write(11,*) sngl(time),real(c(it))\n enddo\n close(11)\n\n print *,'Maximum positive amplitude of the time-domain solution = ',maxval(real(c(:)))\n print *\n\n enddo ! of loop on the three positions of the receiver\n\n end\n\n! -----------\n\n double complex function u1(omega,v1,x1,x2)\n\n implicit none\n\n double precision omega\n double complex v1\n\n double complex G1\n external G1\n\n double precision x1,x2,r\n\n! source-receiver distance\n r = dsqrt(x1**2 + x2**2)\n\n! equation (B8a) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium,\n! Geophysical Journal, vol. 93, p. 393-407 (1988)\n u1 = G1(r,omega,v1)\n\n end\n\n! -----------\n\n double complex function G1(r,omega,v1)\n\n implicit none\n\n double precision r,omega\n double complex v1\n\n double complex hankel0\n external hankel0\n\n double precision pi\n parameter (pi = 3.141592653589793d0)\n\n! equation (B8a) of Carcione et al., Wave propagation simulation in a linear viscoacoustic medium,\n! Geophysical Journal, vol. 93, p. 393-407 (1988)\n G1 = hankel0(omega*r/v1) * dcmplx(0.d0,-pi)\n\n end\n\n! -----------\n\n double complex function hankel0(z)\n\n implicit none\n\n double complex z\n\n! on utilise la routine NAG appelee S17DLE (simple precision)\n\n integer ifail,nz\n complex result\n\n ifail = -1\n call S17DLE(2,0.0,cmplx(z),1,'U',result,nz,ifail)\n if (ifail /= 0) stop 'S17DLE failed in hankel0'\n if (nz > 0) print *,nz,' termes mis a zero par underflow'\n\n hankel0 = dcmplx(result)\n\n end\n\n! ***************** routine de FFT pour signal en temps ****************\n\n! FFT routine taken from Netlib\n\n subroutine CFFTB (N,C,WSAVE)\n DIMENSION C(1) ,WSAVE(1)\n if (N == 1) return\n IW1 = N+N+1\n IW2 = IW1+N+N\n CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))\n END\n\n subroutine CFFTB1 (N,C,CH,WA,IFAC)\n DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1)\n NF = IFAC(2)\n NA = 0\n L1 = 1\n IW = 1\n DO 116 K1=1,NF\n IP = IFAC(K1+2)\n L2 = IP*L1\n IDO = N/L2\n IDOT = IDO+IDO\n IDL1 = IDOT*L1\n if (IP /= 4) goto 103\n IX2 = IW+IDOT\n IX3 = IX2+IDOT\n if (NA /= 0) goto 101\n CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))\n goto 102\n 101 CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))\n 102 NA = 1-NA\n goto 115\n 103 if (IP /= 2) goto 106\n if (NA /= 0) goto 104\n CALL PASSB2 (IDOT,L1,C,CH,WA(IW))\n goto 105\n 104 CALL PASSB2 (IDOT,L1,CH,C,WA(IW))\n 105 NA = 1-NA\n goto 115\n 106 if (IP /= 3) goto 109\n IX2 = IW+IDOT\n if (NA /= 0) goto 107\n CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2))\n goto 108\n 107 CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2))\n 108 NA = 1-NA\n goto 115\n 109 if (IP /= 5) goto 112\n IX2 = IW+IDOT\n IX3 = IX2+IDOT\n IX4 = IX3+IDOT\n if (NA /= 0) goto 110\n CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))\n goto 111\n 110 CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))\n 111 NA = 1-NA\n goto 115\n 112 if (NA /= 0) goto 113\n CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))\n goto 114\n 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))\n 114 if (NAC /= 0) NA = 1-NA\n 115 L1 = L2\n IW = IW+(IP-1)*IDOT\n 116 continue\n if (NA == 0) return\n N2 = N+N\n DO 117 I=1,N2\n C(I) = CH(I)\n 117 continue\n END\n\n subroutine PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)\n DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1), &\n C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), &\n CH2(IDL1,IP)\n IDOT = IDO/2\n NT = IP*IDL1\n IPP2 = IP+2\n IPPH = (IP+1)/2\n IDP = IP*IDO\n\n if (IDO < L1) goto 106\n DO 103 J=2,IPPH\n JC = IPP2-J\n DO 102 K=1,L1\n DO 101 I=1,IDO\n CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)\n CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)\n 101 continue\n 102 continue\n 103 continue\n DO 105 K=1,L1\n DO 104 I=1,IDO\n CH(I,K,1) = CC(I,1,K)\n 104 continue\n 105 continue\n goto 112\n 106 DO 109 J=2,IPPH\n JC = IPP2-J\n DO 108 I=1,IDO\n DO 107 K=1,L1\n CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)\n CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)\n 107 continue\n 108 continue\n 109 continue\n DO 111 I=1,IDO\n DO 110 K=1,L1\n CH(I,K,1) = CC(I,1,K)\n 110 continue\n 111 continue\n 112 IDL = 2-IDO\n INC = 0\n DO 116 L=2,IPPH\n LC = IPP2-L\n IDL = IDL+IDO\n DO 113 IK=1,IDL1\n C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)\n C2(IK,LC) = WA(IDL)*CH2(IK,IP)\n 113 continue\n IDLJ = IDL\n INC = INC+IDO\n DO 115 J=3,IPPH\n JC = IPP2-J\n IDLJ = IDLJ+INC\n if (IDLJ > IDP) IDLJ = IDLJ-IDP\n WAR = WA(IDLJ-1)\n WAI = WA(IDLJ)\n DO 114 IK=1,IDL1\n C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)\n C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)\n 114 continue\n 115 continue\n 116 continue\n DO 118 J=2,IPPH\n DO 117 IK=1,IDL1\n CH2(IK,1) = CH2(IK,1)+CH2(IK,J)\n 117 continue\n 118 continue\n DO 120 J=2,IPPH\n JC = IPP2-J\n DO 119 IK=2,IDL1,2\n CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)\n CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)\n CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)\n CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)\n 119 continue\n 120 continue\n NAC = 1\n if (IDO == 2) return\n NAC = 0\n DO 121 IK=1,IDL1\n C2(IK,1) = CH2(IK,1)\n 121 continue\n DO 123 J=2,IP\n DO 122 K=1,L1\n C1(1,K,J) = CH(1,K,J)\n C1(2,K,J) = CH(2,K,J)\n 122 continue\n 123 continue\n if (IDOT > L1) goto 127\n IDIJ = 0\n DO 126 J=2,IP\n IDIJ = IDIJ+2\n DO 125 I=4,IDO,2\n IDIJ = IDIJ+2\n DO 124 K=1,L1\n C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)\n C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)\n 124 continue\n 125 continue\n 126 continue\n return\n 127 IDJ = 2-IDO\n DO 130 J=2,IP\n IDJ = IDJ+IDO\n DO 129 K=1,L1\n IDIJ = IDJ\n DO 128 I=4,IDO,2\n IDIJ = IDIJ+2\n C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)\n C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)\n 128 continue\n 129 continue\n 130 continue\n END\n\n subroutine PASSB2 (IDO,L1,CC,CH,WA1)\n DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2), &\n WA1(1)\n if (IDO > 2) goto 102\n DO 101 K=1,L1\n CH(1,K,1) = CC(1,1,K)+CC(1,2,K)\n CH(1,K,2) = CC(1,1,K)-CC(1,2,K)\n CH(2,K,1) = CC(2,1,K)+CC(2,2,K)\n CH(2,K,2) = CC(2,1,K)-CC(2,2,K)\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)\n TR2 = CC(I-1,1,K)-CC(I-1,2,K)\n CH(I,K,1) = CC(I,1,K)+CC(I,2,K)\n TI2 = CC(I,1,K)-CC(I,2,K)\n CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2\n CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2\n 103 continue\n 104 continue\n END\n\n subroutine PASSB3 (IDO,L1,CC,CH,WA1,WA2)\n DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3), &\n WA1(1) ,WA2(1)\n DATA TAUR,TAUI /-.5,.866025403784439/\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TR2 = CC(1,2,K)+CC(1,3,K)\n CR2 = CC(1,1,K)+TAUR*TR2\n CH(1,K,1) = CC(1,1,K)+TR2\n TI2 = CC(2,2,K)+CC(2,3,K)\n CI2 = CC(2,1,K)+TAUR*TI2\n CH(2,K,1) = CC(2,1,K)+TI2\n CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))\n CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))\n CH(1,K,2) = CR2-CI3\n CH(1,K,3) = CR2+CI3\n CH(2,K,2) = CI2+CR3\n CH(2,K,3) = CI2-CR3\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TR2 = CC(I-1,2,K)+CC(I-1,3,K)\n CR2 = CC(I-1,1,K)+TAUR*TR2\n CH(I-1,K,1) = CC(I-1,1,K)+TR2\n TI2 = CC(I,2,K)+CC(I,3,K)\n CI2 = CC(I,1,K)+TAUR*TI2\n CH(I,K,1) = CC(I,1,K)+TI2\n CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))\n CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))\n DR2 = CR2-CI3\n DR3 = CR2+CI3\n DI2 = CI2+CR3\n DI3 = CI2-CR3\n CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2\n CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2\n CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3\n CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3\n 103 continue\n 104 continue\n END\n\n subroutine PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3)\n DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4), &\n WA1(1) ,WA2(1) ,WA3(1)\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TI1 = CC(2,1,K)-CC(2,3,K)\n TI2 = CC(2,1,K)+CC(2,3,K)\n TR4 = CC(2,4,K)-CC(2,2,K)\n TI3 = CC(2,2,K)+CC(2,4,K)\n TR1 = CC(1,1,K)-CC(1,3,K)\n TR2 = CC(1,1,K)+CC(1,3,K)\n TI4 = CC(1,2,K)-CC(1,4,K)\n TR3 = CC(1,2,K)+CC(1,4,K)\n CH(1,K,1) = TR2+TR3\n CH(1,K,3) = TR2-TR3\n CH(2,K,1) = TI2+TI3\n CH(2,K,3) = TI2-TI3\n CH(1,K,2) = TR1+TR4\n CH(1,K,4) = TR1-TR4\n CH(2,K,2) = TI1+TI4\n CH(2,K,4) = TI1-TI4\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TI1 = CC(I,1,K)-CC(I,3,K)\n TI2 = CC(I,1,K)+CC(I,3,K)\n TI3 = CC(I,2,K)+CC(I,4,K)\n TR4 = CC(I,4,K)-CC(I,2,K)\n TR1 = CC(I-1,1,K)-CC(I-1,3,K)\n TR2 = CC(I-1,1,K)+CC(I-1,3,K)\n TI4 = CC(I-1,2,K)-CC(I-1,4,K)\n TR3 = CC(I-1,2,K)+CC(I-1,4,K)\n CH(I-1,K,1) = TR2+TR3\n CR3 = TR2-TR3\n CH(I,K,1) = TI2+TI3\n CI3 = TI2-TI3\n CR2 = TR1+TR4\n CR4 = TR1-TR4\n CI2 = TI1+TI4\n CI4 = TI1-TI4\n CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2\n CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2\n CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3\n CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3\n CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4\n CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4\n 103 continue\n 104 continue\n END\n\n subroutine PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)\n DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5), &\n WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)\n DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, &\n -.809016994374947,.587785252292473/\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TI5 = CC(2,2,K)-CC(2,5,K)\n TI2 = CC(2,2,K)+CC(2,5,K)\n TI4 = CC(2,3,K)-CC(2,4,K)\n TI3 = CC(2,3,K)+CC(2,4,K)\n TR5 = CC(1,2,K)-CC(1,5,K)\n TR2 = CC(1,2,K)+CC(1,5,K)\n TR4 = CC(1,3,K)-CC(1,4,K)\n TR3 = CC(1,3,K)+CC(1,4,K)\n CH(1,K,1) = CC(1,1,K)+TR2+TR3\n CH(2,K,1) = CC(2,1,K)+TI2+TI3\n CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3\n CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3\n CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3\n CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3\n CR5 = TI11*TR5+TI12*TR4\n CI5 = TI11*TI5+TI12*TI4\n CR4 = TI12*TR5-TI11*TR4\n CI4 = TI12*TI5-TI11*TI4\n CH(1,K,2) = CR2-CI5\n CH(1,K,5) = CR2+CI5\n CH(2,K,2) = CI2+CR5\n CH(2,K,3) = CI3+CR4\n CH(1,K,3) = CR3-CI4\n CH(1,K,4) = CR3+CI4\n CH(2,K,4) = CI3-CR4\n CH(2,K,5) = CI2-CR5\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TI5 = CC(I,2,K)-CC(I,5,K)\n TI2 = CC(I,2,K)+CC(I,5,K)\n TI4 = CC(I,3,K)-CC(I,4,K)\n TI3 = CC(I,3,K)+CC(I,4,K)\n TR5 = CC(I-1,2,K)-CC(I-1,5,K)\n TR2 = CC(I-1,2,K)+CC(I-1,5,K)\n TR4 = CC(I-1,3,K)-CC(I-1,4,K)\n TR3 = CC(I-1,3,K)+CC(I-1,4,K)\n CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3\n CH(I,K,1) = CC(I,1,K)+TI2+TI3\n CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3\n CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3\n CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3\n CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3\n CR5 = TI11*TR5+TI12*TR4\n CI5 = TI11*TI5+TI12*TI4\n CR4 = TI12*TR5-TI11*TR4\n CI4 = TI12*TI5-TI11*TI4\n DR3 = CR3-CI4\n DR4 = CR3+CI4\n DI3 = CI3+CR4\n DI4 = CI3-CR4\n DR5 = CR2+CI5\n DR2 = CR2-CI5\n DI5 = CI2-CR5\n DI2 = CI2+CR5\n CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2\n CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2\n CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3\n CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3\n CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4\n CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4\n CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5\n CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5\n 103 continue\n 104 continue\n END\n\n subroutine CFFTI (N,WSAVE)\n DIMENSION WSAVE(1)\n if (N == 1) return\n IW1 = N+N+1\n IW2 = IW1+N+N\n CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2))\n END\n\n subroutine CFFTI1 (N,WA,IFAC)\n DIMENSION WA(1) ,IFAC(1) ,NTRYH(4)\n DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/\n NL = N\n NF = 0\n J = 0\n 101 J = J+1\n if (J-4) 102,102,103\n 102 NTRY = NTRYH(J)\n goto 104\n 103 NTRY = NTRY+2\n 104 NQ = NL/NTRY\n NR = NL-NTRY*NQ\n if (NR) 101,105,101\n 105 NF = NF+1\n IFAC(NF+2) = NTRY\n NL = NQ\n if (NTRY /= 2) goto 107\n if (NF == 1) goto 107\n DO 106 I=2,NF\n IB = NF-I+2\n IFAC(IB+2) = IFAC(IB+1)\n 106 continue\n IFAC(3) = 2\n 107 if (NL /= 1) goto 104\n IFAC(1) = N\n IFAC(2) = NF\n TPI = 6.28318530717959\n ARGH = TPI/FLOAT(N)\n I = 2\n L1 = 1\n DO 110 K1=1,NF\n IP = IFAC(K1+2)\n LD = 0\n L2 = L1*IP\n IDO = N/L2\n IDOT = IDO+IDO+2\n IPM = IP-1\n DO 109 J=1,IPM\n I1 = I\n WA(I-1) = 1.\n WA(I) = 0.\n LD = LD+L1\n FI = 0.\n ARGLD = FLOAT(LD)*ARGH\n DO 108 II=4,IDOT,2\n I = I+2\n FI = FI+1.\n ARG = FI*ARGLD\n WA(I-1) = COS(ARG)\n WA(I) = SIN(ARG)\n 108 continue\n if (IP <= 5) goto 109\n WA(I1-1) = WA(I-1)\n WA(I1) = WA(I)\n 109 continue\n L1 = L2\n 110 continue\n END\n\n subroutine CFFTF (N,C,WSAVE)\n DIMENSION C(1) ,WSAVE(1)\n if (N == 1) return\n IW1 = N+N+1\n IW2 = IW1+N+N\n CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))\n END\n\n subroutine CFFTF1 (N,C,CH,WA,IFAC)\n DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1)\n NF = IFAC(2)\n NA = 0\n L1 = 1\n IW = 1\n DO 116 K1=1,NF\n IP = IFAC(K1+2)\n L2 = IP*L1\n IDO = N/L2\n IDOT = IDO+IDO\n IDL1 = IDOT*L1\n if (IP /= 4) goto 103\n IX2 = IW+IDOT\n IX3 = IX2+IDOT\n if (NA /= 0) goto 101\n CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))\n goto 102\n 101 CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))\n 102 NA = 1-NA\n goto 115\n 103 if (IP /= 2) goto 106\n if (NA /= 0) goto 104\n CALL PASSF2 (IDOT,L1,C,CH,WA(IW))\n goto 105\n 104 CALL PASSF2 (IDOT,L1,CH,C,WA(IW))\n 105 NA = 1-NA\n goto 115\n 106 if (IP /= 3) goto 109\n IX2 = IW+IDOT\n if (NA /= 0) goto 107\n CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))\n goto 108\n 107 CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))\n 108 NA = 1-NA\n goto 115\n 109 if (IP /= 5) goto 112\n IX2 = IW+IDOT\n IX3 = IX2+IDOT\n IX4 = IX3+IDOT\n if (NA /= 0) goto 110\n CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))\n goto 111\n 110 CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))\n 111 NA = 1-NA\n goto 115\n 112 if (NA /= 0) goto 113\n CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))\n goto 114\n 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))\n 114 if (NAC /= 0) NA = 1-NA\n 115 L1 = L2\n IW = IW+(IP-1)*IDOT\n 116 continue\n if (NA == 0) return\n N2 = N+N\n DO 117 I=1,N2\n C(I) = CH(I)\n 117 continue\n END\n\n subroutine PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)\n DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1), &\n C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), &\n CH2(IDL1,IP)\n IDOT = IDO/2\n NT = IP*IDL1\n IPP2 = IP+2\n IPPH = (IP+1)/2\n IDP = IP*IDO\n\n if (IDO < L1) goto 106\n DO 103 J=2,IPPH\n JC = IPP2-J\n DO 102 K=1,L1\n DO 101 I=1,IDO\n CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)\n CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)\n 101 continue\n 102 continue\n 103 continue\n DO 105 K=1,L1\n DO 104 I=1,IDO\n CH(I,K,1) = CC(I,1,K)\n 104 continue\n 105 continue\n goto 112\n 106 DO 109 J=2,IPPH\n JC = IPP2-J\n DO 108 I=1,IDO\n DO 107 K=1,L1\n CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)\n CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)\n 107 continue\n 108 continue\n 109 continue\n DO 111 I=1,IDO\n DO 110 K=1,L1\n CH(I,K,1) = CC(I,1,K)\n 110 continue\n 111 continue\n 112 IDL = 2-IDO\n INC = 0\n DO 116 L=2,IPPH\n LC = IPP2-L\n IDL = IDL+IDO\n DO 113 IK=1,IDL1\n C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)\n C2(IK,LC) = -WA(IDL)*CH2(IK,IP)\n 113 continue\n IDLJ = IDL\n INC = INC+IDO\n DO 115 J=3,IPPH\n JC = IPP2-J\n IDLJ = IDLJ+INC\n if (IDLJ > IDP) IDLJ = IDLJ-IDP\n WAR = WA(IDLJ-1)\n WAI = WA(IDLJ)\n DO 114 IK=1,IDL1\n C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)\n C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)\n 114 continue\n 115 continue\n 116 continue\n DO 118 J=2,IPPH\n DO 117 IK=1,IDL1\n CH2(IK,1) = CH2(IK,1)+CH2(IK,J)\n 117 continue\n 118 continue\n DO 120 J=2,IPPH\n JC = IPP2-J\n DO 119 IK=2,IDL1,2\n CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)\n CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)\n CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)\n CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)\n 119 continue\n 120 continue\n NAC = 1\n if (IDO == 2) return\n NAC = 0\n DO 121 IK=1,IDL1\n C2(IK,1) = CH2(IK,1)\n 121 continue\n DO 123 J=2,IP\n DO 122 K=1,L1\n C1(1,K,J) = CH(1,K,J)\n C1(2,K,J) = CH(2,K,J)\n 122 continue\n 123 continue\n if (IDOT > L1) goto 127\n IDIJ = 0\n DO 126 J=2,IP\n IDIJ = IDIJ+2\n DO 125 I=4,IDO,2\n IDIJ = IDIJ+2\n DO 124 K=1,L1\n C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)\n C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)\n 124 continue\n 125 continue\n 126 continue\n return\n 127 IDJ = 2-IDO\n DO 130 J=2,IP\n IDJ = IDJ+IDO\n DO 129 K=1,L1\n IDIJ = IDJ\n DO 128 I=4,IDO,2\n IDIJ = IDIJ+2\n C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)\n C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)\n 128 continue\n 129 continue\n 130 continue\n END\n\n subroutine PASSF2 (IDO,L1,CC,CH,WA1)\n DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2), &\n WA1(1)\n if (IDO > 2) goto 102\n DO 101 K=1,L1\n CH(1,K,1) = CC(1,1,K)+CC(1,2,K)\n CH(1,K,2) = CC(1,1,K)-CC(1,2,K)\n CH(2,K,1) = CC(2,1,K)+CC(2,2,K)\n CH(2,K,2) = CC(2,1,K)-CC(2,2,K)\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)\n TR2 = CC(I-1,1,K)-CC(I-1,2,K)\n CH(I,K,1) = CC(I,1,K)+CC(I,2,K)\n TI2 = CC(I,1,K)-CC(I,2,K)\n CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2\n CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2\n 103 continue\n 104 continue\n END\n\n subroutine PASSF3 (IDO,L1,CC,CH,WA1,WA2)\n DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3), &\n WA1(1) ,WA2(1)\n DATA TAUR,TAUI /-.5,-.866025403784439/\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TR2 = CC(1,2,K)+CC(1,3,K)\n CR2 = CC(1,1,K)+TAUR*TR2\n CH(1,K,1) = CC(1,1,K)+TR2\n TI2 = CC(2,2,K)+CC(2,3,K)\n CI2 = CC(2,1,K)+TAUR*TI2\n CH(2,K,1) = CC(2,1,K)+TI2\n CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))\n CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))\n CH(1,K,2) = CR2-CI3\n CH(1,K,3) = CR2+CI3\n CH(2,K,2) = CI2+CR3\n CH(2,K,3) = CI2-CR3\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TR2 = CC(I-1,2,K)+CC(I-1,3,K)\n CR2 = CC(I-1,1,K)+TAUR*TR2\n CH(I-1,K,1) = CC(I-1,1,K)+TR2\n TI2 = CC(I,2,K)+CC(I,3,K)\n CI2 = CC(I,1,K)+TAUR*TI2\n CH(I,K,1) = CC(I,1,K)+TI2\n CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))\n CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))\n DR2 = CR2-CI3\n DR3 = CR2+CI3\n DI2 = CI2+CR3\n DI3 = CI2-CR3\n CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2\n CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2\n CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3\n CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3\n 103 continue\n 104 continue\n END\n\n subroutine PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3)\n DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4), &\n WA1(1) ,WA2(1) ,WA3(1)\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TI1 = CC(2,1,K)-CC(2,3,K)\n TI2 = CC(2,1,K)+CC(2,3,K)\n TR4 = CC(2,2,K)-CC(2,4,K)\n TI3 = CC(2,2,K)+CC(2,4,K)\n TR1 = CC(1,1,K)-CC(1,3,K)\n TR2 = CC(1,1,K)+CC(1,3,K)\n TI4 = CC(1,4,K)-CC(1,2,K)\n TR3 = CC(1,2,K)+CC(1,4,K)\n CH(1,K,1) = TR2+TR3\n CH(1,K,3) = TR2-TR3\n CH(2,K,1) = TI2+TI3\n CH(2,K,3) = TI2-TI3\n CH(1,K,2) = TR1+TR4\n CH(1,K,4) = TR1-TR4\n CH(2,K,2) = TI1+TI4\n CH(2,K,4) = TI1-TI4\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TI1 = CC(I,1,K)-CC(I,3,K)\n TI2 = CC(I,1,K)+CC(I,3,K)\n TI3 = CC(I,2,K)+CC(I,4,K)\n TR4 = CC(I,2,K)-CC(I,4,K)\n TR1 = CC(I-1,1,K)-CC(I-1,3,K)\n TR2 = CC(I-1,1,K)+CC(I-1,3,K)\n TI4 = CC(I-1,4,K)-CC(I-1,2,K)\n TR3 = CC(I-1,2,K)+CC(I-1,4,K)\n CH(I-1,K,1) = TR2+TR3\n CR3 = TR2-TR3\n CH(I,K,1) = TI2+TI3\n CI3 = TI2-TI3\n CR2 = TR1+TR4\n CR4 = TR1-TR4\n CI2 = TI1+TI4\n CI4 = TI1-TI4\n CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2\n CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2\n CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3\n CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3\n CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4\n CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4\n 103 continue\n 104 continue\n END\n\n subroutine PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)\n DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5), &\n WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)\n DATA TR11,TI11,TR12,TI12 /.309016994374947,-.951056516295154, &\n -.809016994374947,-.587785252292473/\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TI5 = CC(2,2,K)-CC(2,5,K)\n TI2 = CC(2,2,K)+CC(2,5,K)\n TI4 = CC(2,3,K)-CC(2,4,K)\n TI3 = CC(2,3,K)+CC(2,4,K)\n TR5 = CC(1,2,K)-CC(1,5,K)\n TR2 = CC(1,2,K)+CC(1,5,K)\n TR4 = CC(1,3,K)-CC(1,4,K)\n TR3 = CC(1,3,K)+CC(1,4,K)\n CH(1,K,1) = CC(1,1,K)+TR2+TR3\n CH(2,K,1) = CC(2,1,K)+TI2+TI3\n CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3\n CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3\n CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3\n CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3\n CR5 = TI11*TR5+TI12*TR4\n CI5 = TI11*TI5+TI12*TI4\n CR4 = TI12*TR5-TI11*TR4\n CI4 = TI12*TI5-TI11*TI4\n CH(1,K,2) = CR2-CI5\n CH(1,K,5) = CR2+CI5\n CH(2,K,2) = CI2+CR5\n CH(2,K,3) = CI3+CR4\n CH(1,K,3) = CR3-CI4\n CH(1,K,4) = CR3+CI4\n CH(2,K,4) = CI3-CR4\n CH(2,K,5) = CI2-CR5\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TI5 = CC(I,2,K)-CC(I,5,K)\n TI2 = CC(I,2,K)+CC(I,5,K)\n TI4 = CC(I,3,K)-CC(I,4,K)\n TI3 = CC(I,3,K)+CC(I,4,K)\n TR5 = CC(I-1,2,K)-CC(I-1,5,K)\n TR2 = CC(I-1,2,K)+CC(I-1,5,K)\n TR4 = CC(I-1,3,K)-CC(I-1,4,K)\n TR3 = CC(I-1,3,K)+CC(I-1,4,K)\n CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3\n CH(I,K,1) = CC(I,1,K)+TI2+TI3\n CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3\n CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3\n CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3\n CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3\n CR5 = TI11*TR5+TI12*TR4\n CI5 = TI11*TI5+TI12*TI4\n CR4 = TI12*TR5-TI11*TR4\n CI4 = TI12*TI5-TI11*TI4\n DR3 = CR3-CI4\n DR4 = CR3+CI4\n DI3 = CI3+CR4\n DI4 = CI3-CR4\n DR5 = CR2+CI5\n DR2 = CR2-CI5\n DI5 = CI2-CR5\n DI2 = CI2+CR5\n CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2\n CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2\n CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3\n CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3\n CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4\n CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4\n CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5\n CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5\n 103 continue\n 104 continue\n END\n\n! DK DK march99 : routines sur le Cray (simple precision)\n\n subroutine ABZP01\n! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986.\n!\n! Terminates execution when a hard failure occurs.\n!\n! ******************** IMPLEMENTATION NOTE ********************\n! The following STOP statement may be replaced by a call to an\n! implementation-dependent routine to display a message and/or\n! to abort the program.\n! *************************************************************\n! .. Executable Statements ..\n STOP\n END\n\n subroutine DCYS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-785 (DEC 1989).\n!\n! Original name: CUNK2\n!\n! DCYS18 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE\n! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE\n! UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN)\n! WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR\n! -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT\n! HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC-\n! ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.\n! NZ=-1 MEANS AN OVERFLOW WILL OCCUR\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX AI, ARGD, ASUMD, BSUMD, C1, C2, CFN, CI, CK, &\n CONE, CR1, CR2, CRSC, CS, CSCL, CSGN, CSPN, &\n CZERO, DAI, PHID, RZ, S1, S2, ZB, ZETA1D, &\n ZETA2D, ZN, ZR\n REAL AARG, AIC, ANG, APHI, ASC, ASCLE, C2I, C2M, C2R, &\n CAR, CPN, FMR, FN, FNF, HPI, PI, RS1, SAR, SGN, &\n SPN, X, YY\n INTEGER I, IB, IC, IDUM, IFLAG, IFN, IL, IN, INU, IPARD, &\n IUF, J, K, KDFLG, KFLAG, KK, NAI, NDAI, NW\n! .. Local Arrays ..\n COMPLEX ARG(2), ASUM(2), BSUM(2), CIP(4), CSR(3), &\n CSS(3), CY(2), PHI(2), ZETA1(2), ZETA2(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEUS17, S17DGE, DGSS17, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, INT, LOG, &\n MAX, MOD, REAL, SIGN, SIN\n! .. Data statements ..\n DATA CZERO, CONE, CI, CR1, CR2/(0.0E0,0.0E0), &\n (1.0E0,0.0E0), (0.0E0,1.0E0), &\n (1.0E0,1.73205080756887729E0), &\n (-0.5E0,-8.66025403784438647E-01)/\n DATA HPI, PI, AIC/1.57079632679489662E+00, &\n 3.14159265358979324E+00, &\n 1.26551212348464539E+00/\n DATA CIP(1), CIP(2), CIP(3), CIP(4)/(1.0E0,0.0E0), &\n (0.0E0,-1.0E0), (-1.0E0,0.0E0), (0.0E0,1.0E0)/\n! .. Executable Statements ..\n!\n KDFLG = 1\n NZ = 0\n! ------------------------------------------------------------------\n! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN\n! THE UNDERFLOW LIMIT\n! ------------------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n X = REAL(Z)\n ZR = Z\n if (X < 0.0E0) ZR = -Z\n YY = AIMAG(ZR)\n ZN = -ZR*CI\n ZB = ZR\n INU = INT(FNU)\n FNF = FNU - INU\n ANG = -HPI*FNF\n CAR = COS(ANG)\n SAR = SIN(ANG)\n CPN = -HPI*CAR\n SPN = -HPI*SAR\n C2 = CMPLX(-SPN,CPN)\n KK = MOD(INU,4) + 1\n CS = CR1*C2*CIP(KK)\n if (YY <= 0.0E0) then\n ZN = CONJG(-ZN)\n ZB = CONJG(ZB)\n endif\n! ------------------------------------------------------------------\n! K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST\n! QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY\n! CONJUGATION SINCE THE K function IS REAL ON THE POSITIVE REAL AXIS\n! ------------------------------------------------------------------\n J = 2\n DO 40 I = 1, N\n! ---------------------------------------------------------------\n! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J\n! ---------------------------------------------------------------\n J = 3 - J\n FN = FNU + I - 1\n CALL DEUS17(ZN,FN,0,TOL,PHI(J),ARG(J),ZETA1(J),ZETA2(J),ASUM(J) &\n ,BSUM(J),ELIM)\n if (KODE == 1) then\n S1 = ZETA1(J) - ZETA2(J)\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = ZETA1(J) - CFN*(CFN/(ZB+ZETA2(J)))\n endif\n! ---------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ---------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (KDFLG == 1) KFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ---------------------------------------------------------\n! REFINE TEST AND SCALE\n! ---------------------------------------------------------\n APHI = ABS(PHI(J))\n AARG = ABS(ARG(J))\n RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC\n if (ABS(RS1) > ELIM) then\n goto 20\n ELSE\n if (KDFLG == 1) KFLAG = 1\n if (RS1 >= 0.0E0) then\n if (KDFLG == 1) KFLAG = 3\n endif\n endif\n endif\n! ------------------------------------------------------------\n! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR\n! EXPONENT EXTREMES\n! ------------------------------------------------------------\n C2 = ARG(J)*CR2\n IDUM = 1\n! S17DGE assumed not to fail, therefore IDUM set to one.\n CALL S17DGE('F',C2,'S',AI,NAI,IDUM)\n IDUM = 1\n CALL S17DGE('D',C2,'S',DAI,NDAI,IDUM)\n S2 = CS*PHI(J)*(AI*ASUM(J)+CR2*DAI*BSUM(J))\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(KFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (KFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) goto 20\n endif\n if (YY <= 0.0E0) S2 = CONJG(S2)\n CY(KDFLG) = S2\n Y(I) = S2*CSR(KFLAG)\n CS = -CI*CS\n if (KDFLG == 2) then\n goto 60\n ELSE\n KDFLG = 2\n goto 40\n endif\n endif\n 20 if (RS1 > 0.0E0) then\n goto 280\n! ------------------------------------------------------------\n! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW\n! ------------------------------------------------------------\n else if (X < 0.0E0) then\n goto 280\n ELSE\n KDFLG = 1\n Y(I) = CZERO\n CS = -CI*CS\n NZ = NZ + 1\n if (I /= 1) then\n if (Y(I-1) /= CZERO) then\n Y(I-1) = CZERO\n NZ = NZ + 1\n endif\n endif\n endif\n 40 continue\n I = N\n 60 RZ = CMPLX(2.0E0,0.0E0)/ZR\n CK = CMPLX(FN,0.0E0)*RZ\n IB = I + 1\n if (N >= IB) then\n! ---------------------------------------------------------------\n! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO\n! ZERO ON UNDERFLOW\n! ---------------------------------------------------------------\n FN = FNU + N - 1\n IPARD = 1\n if (MR /= 0) IPARD = 0\n CALL DEUS17(ZN,FN,IPARD,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD, &\n BSUMD,ELIM)\n if (KODE == 1) then\n S1 = ZETA1D - ZETA2D\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = ZETA1D - CFN*(CFN/(ZB+ZETA2D))\n endif\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (ABS(RS1) >= ALIM) then\n! ---------------------------------------------------------\n! REFINE ESTIMATE AND TEST\n! ---------------------------------------------------------\n APHI = ABS(PHID)\n AARG = ABS(ARGD)\n RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC\n if (ABS(RS1) >= ELIM) goto 100\n endif\n! ------------------------------------------------------------\n! SCALED FORWARD RECURRENCE FOR REMAINDER OF THE SEQUENCE\n! ------------------------------------------------------------\n S1 = CY(1)\n S2 = CY(2)\n C1 = CSR(KFLAG)\n ASCLE = BRY(KFLAG)\n DO 80 I = IB, N\n C2 = S2\n S2 = CK*S2 + S1\n S1 = C2\n CK = CK + RZ\n C2 = S2*C1\n Y(I) = C2\n if (KFLAG < 3) then\n C2R = REAL(C2)\n C2I = AIMAG(C2)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n KFLAG = KFLAG + 1\n ASCLE = BRY(KFLAG)\n S1 = S1*C1\n S2 = C2\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n C1 = CSR(KFLAG)\n endif\n endif\n 80 continue\n goto 140\n endif\n 100 if (RS1 > 0.0E0) then\n goto 280\n! ------------------------------------------------------------\n! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW\n! ------------------------------------------------------------\n else if (X < 0.0E0) then\n goto 280\n ELSE\n NZ = N\n DO 120 I = 1, N\n Y(I) = CZERO\n 120 continue\n return\n endif\n endif\n 140 if (MR == 0) then\n return\n ELSE\n! ---------------------------------------------------------------\n! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0\n! ---------------------------------------------------------------\n NZ = 0\n FMR = MR\n SGN = -SIGN(PI,FMR)\n! ---------------------------------------------------------------\n! CSPN AND CSGN ARE COEFF OF K AND I functionS RESP.\n! ---------------------------------------------------------------\n CSGN = CMPLX(0.0E0,SGN)\n if (YY <= 0.0E0) CSGN = CONJG(CSGN)\n IFN = INU + N - 1\n ANG = FNF*SGN\n CPN = COS(ANG)\n SPN = SIN(ANG)\n CSPN = CMPLX(CPN,SPN)\n if (MOD(IFN,2) == 1) CSPN = -CSPN\n! ---------------------------------------------------------------\n! CS=COEFF OF THE J function TO GET THE I function. I(FNU,Z) IS\n! COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE\n! FIRST QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE\n! COMPUTED BY CONJUGATION SINCE THE I function IS REAL ON THE\n! POSITIVE REAL AXIS\n! ---------------------------------------------------------------\n CS = CMPLX(CAR,-SAR)*CSGN\n IN = MOD(IFN,4) + 1\n C2 = CIP(IN)\n CS = CS*CONJG(C2)\n ASC = BRY(1)\n KK = N\n KDFLG = 1\n IB = IB - 1\n IC = IB - 1\n IUF = 0\n DO 220 K = 1, N\n! ------------------------------------------------------------\n! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K\n! function ABOVE\n! ------------------------------------------------------------\n FN = FNU + KK - 1\n if (N > 2) then\n if ((KK == N) .and. (IB < N)) then\n goto 160\n else if ((KK /= IB) .and. (KK /= IC)) then\n CALL DEUS17(ZN,FN,0,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD, &\n BSUMD,ELIM)\n goto 160\n endif\n endif\n PHID = PHI(J)\n ARGD = ARG(J)\n ZETA1D = ZETA1(J)\n ZETA2D = ZETA2(J)\n ASUMD = ASUM(J)\n BSUMD = BSUM(J)\n J = 3 - J\n 160 if (KODE == 1) then\n S1 = -ZETA1D + ZETA2D\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = -ZETA1D + CFN*(CFN/(ZB+ZETA2D))\n endif\n! ------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (KDFLG == 1) IFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ------------------------------------------------------\n! REFINE TEST AND SCALE\n! ------------------------------------------------------\n APHI = ABS(PHID)\n AARG = ABS(ARGD)\n RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC\n if (ABS(RS1) > ELIM) then\n goto 180\n ELSE\n if (KDFLG == 1) IFLAG = 1\n if (RS1 >= 0.0E0) then\n if (KDFLG == 1) IFLAG = 3\n endif\n endif\n endif\n IDUM = 1\n! S17DGE assumed not to fail, therefore IDUM set to one.\n CALL S17DGE('F',ARGD,'S',AI,NAI,IDUM)\n IDUM = 1\n CALL S17DGE('D',ARGD,'S',DAI,NDAI,IDUM)\n S2 = CS*PHID*(AI*ASUMD+DAI*BSUMD)\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(IFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (IFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0)\n endif\n goto 200\n endif\n 180 if (RS1 > 0.0E0) then\n goto 280\n ELSE\n S2 = CZERO\n endif\n 200 if (YY <= 0.0E0) S2 = CONJG(S2)\n CY(KDFLG) = S2\n C2 = S2\n S2 = S2*CSR(IFLAG)\n! ------------------------------------------------------------\n! ADD I AND K functionS, K SEQUENCE IN Y(I), I=1,N\n! ------------------------------------------------------------\n S1 = Y(KK)\n if (KODE /= 1) then\n CALL DGSS17(ZR,S1,S2,NW,ASC,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(KK) = S1*CSPN + S2\n KK = KK - 1\n CSPN = -CSPN\n CS = -CS*CI\n if (C2 == CZERO) then\n KDFLG = 1\n else if (KDFLG == 2) then\n goto 240\n ELSE\n KDFLG = 2\n endif\n 220 continue\n K = N\n 240 IL = N - K\n if (IL /= 0) then\n! ------------------------------------------------------------\n! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE\n! K functionS, SCALING THE I SEQUENCE DURING RECURRENCE TO\n! KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT\n! EXTREMES.\n! ------------------------------------------------------------\n S1 = CY(1)\n S2 = CY(2)\n CS = CSR(IFLAG)\n ASCLE = BRY(IFLAG)\n FN = INU + IL\n DO 260 I = 1, IL\n C2 = S2\n S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2\n S1 = C2\n FN = FN - 1.0E0\n C2 = S2*CS\n CK = C2\n C1 = Y(KK)\n if (KODE /= 1) then\n CALL DGSS17(ZR,C1,C2,NW,ASC,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(KK) = C1*CSPN + C2\n KK = KK - 1\n CSPN = -CSPN\n if (IFLAG < 3) then\n C2R = REAL(CK)\n C2I = AIMAG(CK)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*CS\n S2 = CK\n S1 = S1*CSS(IFLAG)\n S2 = S2*CSS(IFLAG)\n CS = CSR(IFLAG)\n endif\n endif\n 260 continue\n endif\n return\n endif\n 280 NZ = -1\n return\n END\n subroutine DCZS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-786 (DEC 1989).\n!\n! Original name: CUNK1\n!\n! DCZS18 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE\n! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE\n! UNIFORM ASYMPTOTIC EXPANSION.\n! MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.\n! NZ=-1 MEANS AN OVERFLOW WILL OCCUR\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CFN, CK, CONE, CRSC, CS, CSCL, CSGN, &\n CSPN, CZERO, PHID, RZ, S1, S2, SUMD, ZETA1D, &\n ZETA2D, ZR\n REAL ANG, APHI, ASC, ASCLE, C2I, C2M, C2R, CPN, FMR, &\n FN, FNF, PI, RS1, SGN, SPN, X\n INTEGER I, IB, IC, IFLAG, IFN, IL, INITD, INU, IPARD, &\n IUF, J, K, KDFLG, KFLAG, KK, M, NW\n! .. Local Arrays ..\n COMPLEX CSR(3), CSS(3), CWRK(16,3), CY(2), PHI(2), &\n SUM(2), ZETA1(2), ZETA2(2)\n REAL BRY(3)\n INTEGER INIT(2)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEWS17, DGSS17, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, LOG, MAX, MOD, &\n REAL, SIGN, SIN\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n DATA PI/3.14159265358979324E0/\n! .. Executable Statements ..\n!\n KDFLG = 1\n NZ = 0\n! ------------------------------------------------------------------\n! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN\n! THE UNDERFLOW LIMIT\n! ------------------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n X = REAL(Z)\n ZR = Z\n if (X < 0.0E0) ZR = -Z\n J = 2\n DO 40 I = 1, N\n! ---------------------------------------------------------------\n! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J\n! ---------------------------------------------------------------\n J = 3 - J\n FN = FNU + I - 1\n INIT(J) = 0\n CALL DEWS17(ZR,FN,2,0,TOL,INIT(J),PHI(J),ZETA1(J),ZETA2(J), &\n SUM(J),CWRK(1,J),ELIM)\n if (KODE == 1) then\n S1 = ZETA1(J) - ZETA2(J)\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = ZETA1(J) - CFN*(CFN/(ZR+ZETA2(J)))\n endif\n! ---------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ---------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (KDFLG == 1) KFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ---------------------------------------------------------\n! REFINE TEST AND SCALE\n! ---------------------------------------------------------\n APHI = ABS(PHI(J))\n RS1 = RS1 + LOG(APHI)\n if (ABS(RS1) > ELIM) then\n goto 20\n ELSE\n if (KDFLG == 1) KFLAG = 1\n if (RS1 >= 0.0E0) then\n if (KDFLG == 1) KFLAG = 3\n endif\n endif\n endif\n! ------------------------------------------------------------\n! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR\n! EXPONENT EXTREMES\n! ------------------------------------------------------------\n S2 = PHI(J)*SUM(J)\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(KFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (KFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) goto 20\n endif\n CY(KDFLG) = S2\n Y(I) = S2*CSR(KFLAG)\n if (KDFLG == 2) then\n goto 60\n ELSE\n KDFLG = 2\n goto 40\n endif\n endif\n 20 if (RS1 > 0.0E0) then\n goto 280\n! ------------------------------------------------------------\n! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW\n! ------------------------------------------------------------\n else if (X < 0.0E0) then\n goto 280\n ELSE\n KDFLG = 1\n Y(I) = CZERO\n NZ = NZ + 1\n if (I /= 1) then\n if (Y(I-1) /= CZERO) then\n Y(I-1) = CZERO\n NZ = NZ + 1\n endif\n endif\n endif\n 40 continue\n I = N\n 60 RZ = CMPLX(2.0E0,0.0E0)/ZR\n CK = CMPLX(FN,0.0E0)*RZ\n IB = I + 1\n if (N >= IB) then\n! ---------------------------------------------------------------\n! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO\n! ZERO ON UNDERFLOW\n! ---------------------------------------------------------------\n FN = FNU + N - 1\n IPARD = 1\n if (MR /= 0) IPARD = 0\n INITD = 0\n CALL DEWS17(ZR,FN,2,IPARD,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, &\n CWRK(1,3),ELIM)\n if (KODE == 1) then\n S1 = ZETA1D - ZETA2D\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = ZETA1D - CFN*(CFN/(ZR+ZETA2D))\n endif\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (ABS(RS1) >= ALIM) then\n! ---------------------------------------------------------\n! REFINE ESTIMATE AND TEST\n! ---------------------------------------------------------\n APHI = ABS(PHID)\n RS1 = RS1 + LOG(APHI)\n if (ABS(RS1) >= ELIM) goto 100\n endif\n! ------------------------------------------------------------\n! RECUR FORWARD FOR REMAINDER OF THE SEQUENCE\n! ------------------------------------------------------------\n S1 = CY(1)\n S2 = CY(2)\n C1 = CSR(KFLAG)\n ASCLE = BRY(KFLAG)\n DO 80 I = IB, N\n C2 = S2\n S2 = CK*S2 + S1\n S1 = C2\n CK = CK + RZ\n C2 = S2*C1\n Y(I) = C2\n if (KFLAG < 3) then\n C2R = REAL(C2)\n C2I = AIMAG(C2)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n KFLAG = KFLAG + 1\n ASCLE = BRY(KFLAG)\n S1 = S1*C1\n S2 = C2\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n C1 = CSR(KFLAG)\n endif\n endif\n 80 continue\n goto 140\n endif\n 100 if (RS1 > 0.0E0) then\n goto 280\n! ------------------------------------------------------------\n! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW\n! ------------------------------------------------------------\n else if (X < 0.0E0) then\n goto 280\n ELSE\n NZ = N\n DO 120 I = 1, N\n Y(I) = CZERO\n 120 continue\n return\n endif\n endif\n 140 if (MR == 0) then\n return\n ELSE\n! ---------------------------------------------------------------\n! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0\n! ---------------------------------------------------------------\n NZ = 0\n FMR = MR\n SGN = -SIGN(PI,FMR)\n! ---------------------------------------------------------------\n! CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP.\n! ---------------------------------------------------------------\n CSGN = CMPLX(0.0E0,SGN)\n INU = INT(FNU)\n FNF = FNU - INU\n IFN = INU + N - 1\n ANG = FNF*SGN\n CPN = COS(ANG)\n SPN = SIN(ANG)\n CSPN = CMPLX(CPN,SPN)\n if (MOD(IFN,2) == 1) CSPN = -CSPN\n ASC = BRY(1)\n KK = N\n IUF = 0\n KDFLG = 1\n IB = IB - 1\n IC = IB - 1\n DO 220 K = 1, N\n FN = FNU + KK - 1\n! ------------------------------------------------------------\n! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K\n! function ABOVE\n! ------------------------------------------------------------\n M = 3\n if (N > 2) then\n if ((KK == N) .and. (IB < N)) then\n goto 160\n else if ((KK /= IB) .and. (KK /= IC)) then\n INITD = 0\n goto 160\n endif\n endif\n INITD = INIT(J)\n PHID = PHI(J)\n ZETA1D = ZETA1(J)\n ZETA2D = ZETA2(J)\n SUMD = SUM(J)\n M = J\n J = 3 - J\n 160 CALL DEWS17(ZR,FN,1,0,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, &\n CWRK(1,M),ELIM)\n if (KODE == 1) then\n S1 = -ZETA1D + ZETA2D\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = -ZETA1D + CFN*(CFN/(ZR+ZETA2D))\n endif\n! ------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (KDFLG == 1) IFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ------------------------------------------------------\n! REFINE TEST AND SCALE\n! ------------------------------------------------------\n APHI = ABS(PHID)\n RS1 = RS1 + LOG(APHI)\n if (ABS(RS1) > ELIM) then\n goto 180\n ELSE\n if (KDFLG == 1) IFLAG = 1\n if (RS1 >= 0.0E0) then\n if (KDFLG == 1) IFLAG = 3\n endif\n endif\n endif\n S2 = CSGN*PHID*SUMD\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(IFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (IFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0)\n endif\n goto 200\n endif\n 180 if (RS1 > 0.0E0) then\n goto 280\n ELSE\n S2 = CZERO\n endif\n 200 CY(KDFLG) = S2\n C2 = S2\n S2 = S2*CSR(IFLAG)\n! ------------------------------------------------------------\n! ADD I AND K functionS, K SEQUENCE IN Y(I), I=1,N\n! ------------------------------------------------------------\n S1 = Y(KK)\n if (KODE /= 1) then\n CALL DGSS17(ZR,S1,S2,NW,ASC,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(KK) = S1*CSPN + S2\n KK = KK - 1\n CSPN = -CSPN\n if (C2 == CZERO) then\n KDFLG = 1\n else if (KDFLG == 2) then\n goto 240\n ELSE\n KDFLG = 2\n endif\n 220 continue\n K = N\n 240 IL = N - K\n if (IL /= 0) then\n! ------------------------------------------------------------\n! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE\n! K functionS, SCALING THE I SEQUENCE DURING RECURRENCE TO\n! KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT\n! EXTREMES.\n! ------------------------------------------------------------\n S1 = CY(1)\n S2 = CY(2)\n CS = CSR(IFLAG)\n ASCLE = BRY(IFLAG)\n FN = INU + IL\n DO 260 I = 1, IL\n C2 = S2\n S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2\n S1 = C2\n FN = FN - 1.0E0\n C2 = S2*CS\n CK = C2\n C1 = Y(KK)\n if (KODE /= 1) then\n CALL DGSS17(ZR,C1,C2,NW,ASC,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(KK) = C1*CSPN + C2\n KK = KK - 1\n CSPN = -CSPN\n if (IFLAG < 3) then\n C2R = REAL(CK)\n C2I = AIMAG(CK)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*CS\n S2 = CK\n S1 = S1*CSS(IFLAG)\n S2 = S2*CSS(IFLAG)\n CS = CSR(IFLAG)\n endif\n endif\n 260 continue\n endif\n return\n endif\n 280 NZ = -1\n return\n END\n subroutine DERS17(Z,FNU,N,CY,TOL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-761 (DEC 1989).\n!\n! Original name: CRATI\n!\n! DERS17 COMPUTES RATIOS OF I BESSEL functionS BY BACKWARD\n! RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD\n! RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B,\n! MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973,\n! BESSEL functionS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER,\n! BY D. J. SOOKNE.\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL FNU, TOL\n INTEGER N\n! .. Array Arguments ..\n COMPLEX CY(N)\n! .. Local Scalars ..\n COMPLEX CDFNU, CONE, CZERO, P1, P2, PT, RZ, T1\n REAL AK, AMAGZ, AP1, AP2, ARG, AZ, DFNU, FDNU, FLAM, &\n FNUP, RAP1, RHO, TEST, TEST1\n INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, INT, MAX, MIN, REAL, SQRT\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n AZ = ABS(Z)\n INU = INT(FNU)\n IDNU = INU + N - 1\n FDNU = IDNU\n MAGZ = INT(AZ)\n AMAGZ = MAGZ + 1\n FNUP = MAX(AMAGZ,FDNU)\n ID = IDNU - MAGZ - 1\n ITIME = 1\n K = 1\n RZ = (CONE+CONE)/Z\n T1 = CMPLX(FNUP,0.0E0)*RZ\n P2 = -T1\n P1 = CONE\n T1 = T1 + RZ\n if (ID > 0) ID = 0\n AP2 = ABS(P2)\n AP1 = ABS(P1)\n! ------------------------------------------------------------------\n! THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNX\n! GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT\n! P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR\n! PREMATURELY.\n! ------------------------------------------------------------------\n ARG = (AP2+AP2)/(AP1*TOL)\n TEST1 = SQRT(ARG)\n TEST = TEST1\n RAP1 = 1.0E0/AP1\n P1 = P1*CMPLX(RAP1,0.0E0)\n P2 = P2*CMPLX(RAP1,0.0E0)\n AP2 = AP2*RAP1\n 20 continue\n K = K + 1\n AP1 = AP2\n PT = P2\n P2 = P1 - T1*P2\n P1 = PT\n T1 = T1 + RZ\n AP2 = ABS(P2)\n if (AP1 <= TEST) then\n goto 20\n else if (ITIME /= 2) then\n AK = ABS(T1)*0.5E0\n FLAM = AK + SQRT(AK*AK-1.0E0)\n RHO = MIN(AP2/AP1,FLAM)\n TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0E0))\n ITIME = 2\n goto 20\n endif\n KK = K + 1 - ID\n AK = KK\n DFNU = FNU + N - 1\n CDFNU = CMPLX(DFNU,0.0E0)\n T1 = CMPLX(AK,0.0E0)\n P1 = CMPLX(1.0E0/AP2,0.0E0)\n P2 = CZERO\n DO 40 I = 1, KK\n PT = P1\n P1 = RZ*(CDFNU+T1)*P1 + P2\n P2 = PT\n T1 = T1 - CONE\n 40 continue\n if (REAL(P1) == 0.0E0 .and. AIMAG(P1) == 0.0E0) P1 = CMPLX(TOL, &\n TOL)\n CY(N) = P2/P1\n if (N /= 1) then\n K = N - 1\n AK = K\n T1 = CMPLX(AK,0.0E0)\n CDFNU = CMPLX(FNU,0.0E0)*RZ\n DO 60 I = 2, N\n PT = CDFNU + T1*RZ + CY(K+1)\n if (REAL(PT) == 0.0E0 .and. AIMAG(PT) == 0.0E0) &\n PT = CMPLX(TOL,TOL)\n CY(K) = CONE/PT\n T1 = T1 - CONE\n K = K - 1\n 60 continue\n endif\n return\n END\n subroutine DESS17(ZR,FNU,KODE,N,Y,NZ,CW,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-762 (DEC 1989).\n!\n! Original name: CWRSK\n!\n! DESS17 COMPUTES THE I BESSEL function FOR RE(Z) >= 0.0 BY\n! NORMALIZING THE I function RATIOS FROM DERS17 BY THE WRONSKIAN\n!\n! .. Scalar Arguments ..\n COMPLEX ZR\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX CW(2), Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CINU, CSCL, CT, RCT, ST\n REAL ACT, ACW, ASCLE, S1, S2, YY\n INTEGER I, NW\n! .. External functions ..\n REAL X02AME\n EXTERNAL X02AME\n! .. External subroutines ..\n EXTERNAL DERS17, DGXS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, SIN\n! .. Executable Statements ..\n! ------------------------------------------------------------------\n! I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS\n! Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM DERS17 NORMALIZED BY THE\n! WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM DGXS17.\n! ------------------------------------------------------------------\n NZ = 0\n CALL DGXS17(ZR,FNU,KODE,2,CW,NW,TOL,ELIM,ALIM)\n if (NW /= 0) then\n NZ = -1\n if (NW == (-2)) NZ = -2\n if (NW == (-3)) NZ = -3\n ELSE\n CALL DERS17(ZR,FNU,N,Y,TOL)\n! ---------------------------------------------------------------\n! RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z),\n! R(FNU+J-1,Z)=Y(J), J=1,...,N\n! ---------------------------------------------------------------\n CINU = CMPLX(1.0E0,0.0E0)\n if (KODE /= 1) then\n YY = AIMAG(ZR)\n S1 = COS(YY)\n S2 = SIN(YY)\n CINU = CMPLX(S1,S2)\n endif\n! ---------------------------------------------------------------\n! ON LOW EXPONENT MACHINES THE K functionS CAN BE CLOSE TO BOTH\n! THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE\n! SCALED TO PREVENT OVER OR UNDERFLOW. DEVS17 HAS DETERMINED THAT\n! THE RESULT IS ON SCALE.\n! ---------------------------------------------------------------\n ACW = ABS(CW(2))\n ASCLE = (1.0E+3*X02AME())/TOL\n CSCL = CMPLX(1.0E0,0.0E0)\n if (ACW > ASCLE) then\n ASCLE = 1.0E0/ASCLE\n if (ACW >= ASCLE) CSCL = CMPLX(TOL,0.0E0)\n ELSE\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n endif\n C1 = CW(1)*CSCL\n C2 = CW(2)*CSCL\n ST = Y(1)\n! ---------------------------------------------------------------\n! CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0E0/CABS(CT) PREVENTS\n! UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT)\n! ---------------------------------------------------------------\n CT = ZR*(C2+ST*C1)\n ACT = ABS(CT)\n RCT = CMPLX(1.0E0/ACT,0.0E0)\n CT = CONJG(CT)*RCT\n CINU = CINU*RCT*CT\n Y(1) = CINU*CSCL\n if (N /= 1) then\n DO 20 I = 2, N\n CINU = ST*CINU\n ST = Y(I)\n Y(I) = CINU*CSCL\n 20 continue\n endif\n endif\n return\n END\n subroutine DETS17(Z,FNU,KODE,N,Y,NZ,NLAST,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-763 (DEC 1989).\n!\n! Original name: CUNI2\n!\n! DETS17 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF\n! UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I\n! OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO.\n!\n! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC\n! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.\n! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER\n! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL.\n! Y(I)=CZERO FOR I=NLAST+1,N\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, TOL\n INTEGER KODE, N, NLAST, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX AI, ARG, ASUM, BSUM, C1, C2, CFN, CI, CID, CONE, &\n CRSC, CSCL, CZERO, DAI, PHI, RZ, S1, S2, ZB, &\n ZETA1, ZETA2, ZN\n REAL AARG, AIC, ANG, APHI, ASCLE, AY, C2I, C2M, C2R, &\n CAR, FN, HPI, RS1, SAR, YY\n INTEGER I, IDUM, IFLAG, IN, INU, J, K, NAI, ND, NDAI, &\n NN, NUF, NW\n! .. Local Arrays ..\n COMPLEX CIP(4), CSR(3), CSS(3), CY(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEUS17, DEVS17, S17DGE, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, INT, LOG, &\n MAX, MIN, MOD, REAL, SIN\n! .. Data statements ..\n DATA CZERO, CONE, CI/(0.0E0,0.0E0), (1.0E0,0.0E0), &\n (0.0E0,1.0E0)/\n DATA CIP(1), CIP(2), CIP(3), CIP(4)/(1.0E0,0.0E0), &\n (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0)/\n DATA HPI, AIC/1.57079632679489662E+00, &\n 1.265512123484645396E+00/\n! .. Executable Statements ..\n!\n NZ = 0\n ND = N\n NLAST = 0\n! ------------------------------------------------------------------\n! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-\n! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,\n! EXP(ALIM)=EXP(ELIM)*TOL\n! ------------------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n YY = AIMAG(Z)\n! ------------------------------------------------------------------\n! ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI\n! ------------------------------------------------------------------\n ZN = -Z*CI\n ZB = Z\n CID = -CI\n INU = INT(FNU)\n ANG = HPI*(FNU-INU)\n CAR = COS(ANG)\n SAR = SIN(ANG)\n C2 = CMPLX(CAR,SAR)\n IN = INU + N - 1\n IN = MOD(IN,4)\n C2 = C2*CIP(IN+1)\n if (YY <= 0.0E0) then\n ZN = CONJG(-ZN)\n ZB = CONJG(ZB)\n CID = -CID\n C2 = CONJG(C2)\n endif\n! ------------------------------------------------------------------\n! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER\n! ------------------------------------------------------------------\n FN = MAX(FNU,1.0E0)\n CALL DEUS17(ZN,FN,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM)\n if (KODE == 1) then\n S1 = -ZETA1 + ZETA2\n ELSE\n CFN = CMPLX(FNU,0.0E0)\n S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2))\n endif\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n 20 continue\n NN = MIN(2,ND)\n DO 40 I = 1, NN\n FN = FNU + ND - I\n CALL DEUS17(ZN,FN,0,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM)\n if (KODE == 1) then\n S1 = -ZETA1 + ZETA2\n ELSE\n CFN = CMPLX(FN,0.0E0)\n AY = ABS(YY)\n S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + CMPLX(0.0E0,AY)\n endif\n! ------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) > ELIM) then\n goto 60\n ELSE\n if (I == 1) IFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ------------------------------------------------------\n! REFINE TEST AND SCALE\n! ------------------------------------------------------\n! ------------------------------------------------------\n APHI = ABS(PHI)\n AARG = ABS(ARG)\n RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC\n if (ABS(RS1) > ELIM) then\n goto 60\n ELSE\n if (I == 1) IFLAG = 1\n if (RS1 >= 0.0E0) then\n if (I == 1) IFLAG = 3\n endif\n endif\n endif\n! ---------------------------------------------------------\n! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR\n! EXPONENT EXTREMES\n! ---------------------------------------------------------\n IDUM = 1\n! S17DGE assumed not to fail, therefore IDUM set to one.\n CALL S17DGE('F',ARG,'S',AI,NAI,IDUM)\n IDUM = 1\n CALL S17DGE('D',ARG,'S',DAI,NDAI,IDUM)\n S2 = PHI*(AI*ASUM+DAI*BSUM)\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(IFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (IFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) goto 60\n endif\n if (YY <= 0.0E0) S2 = CONJG(S2)\n J = ND - I + 1\n S2 = S2*C2\n CY(I) = S2\n Y(J) = S2*CSR(IFLAG)\n C2 = C2*CID\n endif\n 40 continue\n goto 80\n 60 if (RS1 > 0.0E0) then\n goto 160\n ELSE\n! ------------------------------------------------------------\n! SET UNDERFLOW AND UPDATE PARAMETERS\n! ------------------------------------------------------------\n Y(ND) = CZERO\n NZ = NZ + 1\n ND = ND - 1\n if (ND == 0) then\n return\n ELSE\n CALL DEVS17(Z,FNU,KODE,1,ND,Y,NUF,TOL,ELIM,ALIM)\n if (NUF < 0) then\n goto 160\n ELSE\n ND = ND - NUF\n NZ = NZ + NUF\n if (ND == 0) then\n return\n ELSE\n FN = FNU + ND - 1\n if (FN < FNUL) then\n goto 120\n ELSE\n! FN = AIMAG(CID)\n! J = NUF + 1\n! K = MOD(J,4) + 1\n! S1 = CIP(K)\n! if (FN < 0.0E0) S1 = CONJG(S1)\n! C2 = C2*S1\n! The above 6 lines were replaced by the 5 below\n! to fix a bug discovered during implementation\n! on a Multics machine, whereby some results\n! were returned wrongly scaled by sqrt(-1.0). MWP.\n C2 = CMPLX(CAR,SAR)\n IN = INU + ND - 1\n IN = MOD(IN,4) + 1\n C2 = C2*CIP(IN)\n if (YY <= 0.0E0) C2 = CONJG(C2)\n goto 20\n endif\n endif\n endif\n endif\n endif\n 80 if (ND > 2) then\n RZ = CMPLX(2.0E0,0.0E0)/Z\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n S1 = CY(1)\n S2 = CY(2)\n C1 = CSR(IFLAG)\n ASCLE = BRY(IFLAG)\n K = ND - 2\n FN = K\n DO 100 I = 3, ND\n C2 = S2\n S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2\n S1 = C2\n C2 = S2*C1\n Y(K) = C2\n K = K - 1\n FN = FN - 1.0E0\n if (IFLAG < 3) then\n C2R = REAL(C2)\n C2I = AIMAG(C2)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*C1\n S2 = C2\n S1 = S1*CSS(IFLAG)\n S2 = S2*CSS(IFLAG)\n C1 = CSR(IFLAG)\n endif\n endif\n 100 continue\n endif\n return\n 120 NLAST = ND\n return\n else if (RS1 <= 0.0E0) then\n NZ = N\n DO 140 I = 1, N\n Y(I) = CZERO\n 140 continue\n return\n endif\n 160 NZ = -1\n return\n END\n subroutine DEUS17(Z,FNU,IPMTR,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM, &\n ELIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-764 (DEC 1989).\n!\n! Original name: CUNHJ\n!\n! REFERENCES\n! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ AND I.A.\n! STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9.\n!\n! ASYMPTOTICS AND SPECIAL functionS BY F.W.J. OLVER, ACADEMIC\n! PRESS, N.Y., 1974, PAGE 420\n!\n! ABSTRACT\n! DEUS17 COMPUTES PARAMETERS FOR BESSEL functionS C(FNU,Z) =\n! J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU\n! BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION\n!\n! C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) )\n!\n! FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS\n! AN AIRY function AND DAIRY IS ITS DERIVATIVE.\n!\n! (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2,\n!\n! ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING\n! PURPOSES IN AIRY functionS FROM S17DGE OR S17DHE.\n!\n! MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND\n! MUST BE SPECIFIED. IPMTR=0 returnS ALL PARAMETERS. IPMTR=\n! 1 COMPUTES ALL EXCEPT ASUM AND BSUM.\n!\n! .. Scalar Arguments ..\n COMPLEX ARG, ASUM, BSUM, PHI, Z, ZETA1, ZETA2\n REAL ELIM, FNU, TOL\n INTEGER IPMTR\n! .. Local Scalars ..\n COMPLEX CFNU, CONE, CZERO, PRZTH, PTFN, RFN13, RTZTA, &\n RZTH, SUMA, SUMB, T2, TFN, W, W2, ZA, ZB, ZC, &\n ZETA, ZTH\n REAL ANG, ASUMI, ASUMR, ATOL, AW2, AZTH, BSUMI, &\n BSUMR, BTOL, EX1, EX2, FN13, FN23, HPI, PI, PP, &\n RFNU, RFNU2, TEST, THPI, TSTI, TSTR, WI, WR, &\n ZCI, ZCR, ZETAI, ZETAR, ZTHI, ZTHR\n INTEGER IAS, IBS, IS, J, JR, JU, K, KMAX, KP1, KS, L, &\n L1, L2, LR, LRP1, M\n! .. Local Arrays ..\n COMPLEX CR(14), DR(14), P(30), UP(14)\n REAL ALFA(180), AP(30), AR(14), BETA(210), BR(14), &\n C(105), GAMA(30)\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, ATAN, CMPLX, COS, EXP, LOG, REAL, &\n SIN, SQRT\n! .. Data statements ..\n DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), &\n AR(8), AR(9), AR(10), AR(11), AR(12), AR(13), &\n AR(14)/1.00000000000000000E+00, &\n 1.04166666666666667E-01, &\n 8.35503472222222222E-02, &\n 1.28226574556327160E-01, &\n 2.91849026464140464E-01, &\n 8.81627267443757652E-01, &\n 3.32140828186276754E+00, &\n 1.49957629868625547E+01, &\n 7.89230130115865181E+01, &\n 4.74451538868264323E+02, &\n 3.20749009089066193E+03, &\n 2.40865496408740049E+04, &\n 1.98923119169509794E+05, &\n 1.79190200777534383E+06/\n DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), &\n BR(8), BR(9), BR(10), BR(11), BR(12), BR(13), &\n BR(14)/1.00000000000000000E+00, &\n -1.45833333333333333E-01, &\n -9.87413194444444444E-02, &\n -1.43312053915895062E-01, &\n -3.17227202678413548E-01, &\n -9.42429147957120249E-01, &\n -3.51120304082635426E+00, &\n -1.57272636203680451E+01, &\n -8.22814390971859444E+01, &\n -4.92355370523670524E+02, &\n -3.31621856854797251E+03, &\n -2.48276742452085896E+04, &\n -2.04526587315129788E+05, &\n -1.83844491706820990E+06/\n DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), &\n C(9), C(10), C(11), C(12), C(13), C(14), C(15), &\n C(16)/1.00000000000000000E+00, &\n -2.08333333333333333E-01, &\n 1.25000000000000000E-01, &\n 3.34201388888888889E-01, &\n -4.01041666666666667E-01, &\n 7.03125000000000000E-02, &\n -1.02581259645061728E+00, &\n 1.84646267361111111E+00, &\n -8.91210937500000000E-01, &\n 7.32421875000000000E-02, &\n 4.66958442342624743E+00, &\n -1.12070026162229938E+01, &\n 8.78912353515625000E+00, &\n -2.36408691406250000E+00, &\n 1.12152099609375000E-01, &\n -2.82120725582002449E+01/\n DATA C(17), C(18), C(19), C(20), C(21), C(22), C(23), &\n C(24)/8.46362176746007346E+01, &\n -9.18182415432400174E+01, &\n 4.25349987453884549E+01, &\n -7.36879435947963170E+00, &\n 2.27108001708984375E-01, &\n 2.12570130039217123E+02, &\n -7.65252468141181642E+02, &\n 1.05999045252799988E+03/\n DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), &\n C(32), C(33), C(34), C(35), C(36), C(37), C(38), &\n C(39), C(40)/-6.99579627376132541E+02, &\n 2.18190511744211590E+02, &\n -2.64914304869515555E+01, &\n 5.72501420974731445E-01, &\n -1.91945766231840700E+03, &\n 8.06172218173730938E+03, &\n -1.35865500064341374E+04, &\n 1.16553933368645332E+04, &\n -5.30564697861340311E+03, &\n 1.20090291321635246E+03, &\n -1.08090919788394656E+02, &\n 1.72772750258445740E+00, &\n 2.02042913309661486E+04, &\n -9.69805983886375135E+04, &\n 1.92547001232531532E+05, &\n -2.03400177280415534E+05/\n DATA C(41), C(42), C(43), C(44), C(45), C(46), C(47), &\n C(48)/1.22200464983017460E+05, &\n -4.11926549688975513E+04, &\n 7.10951430248936372E+03, &\n -4.93915304773088012E+02, &\n 6.07404200127348304E+00, &\n -2.42919187900551333E+05, &\n 1.31176361466297720E+06, &\n -2.99801591853810675E+06/\n DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), &\n C(56), C(57), C(58), C(59), C(60), C(61), C(62), &\n C(63), C(64)/3.76327129765640400E+06, &\n -2.81356322658653411E+06, &\n 1.26836527332162478E+06, &\n -3.31645172484563578E+05, &\n 4.52187689813627263E+04, &\n -2.49983048181120962E+03, &\n 2.43805296995560639E+01, &\n 3.28446985307203782E+06, &\n -1.97068191184322269E+07, &\n 5.09526024926646422E+07, &\n -7.41051482115326577E+07, &\n 6.63445122747290267E+07, &\n -3.75671766607633513E+07, &\n 1.32887671664218183E+07, &\n -2.78561812808645469E+06, &\n 3.08186404612662398E+05/\n DATA C(65), C(66), C(67), C(68), C(69), C(70), C(71), &\n C(72)/-1.38860897537170405E+04, &\n 1.10017140269246738E+02, &\n -4.93292536645099620E+07, &\n 3.25573074185765749E+08, &\n -9.39462359681578403E+08, &\n 1.55359689957058006E+09, &\n -1.62108055210833708E+09, &\n 1.10684281682301447E+09/\n DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), &\n C(80), C(81), C(82), C(83), C(84), C(85), C(86), &\n C(87), C(88)/-4.95889784275030309E+08, &\n 1.42062907797533095E+08, &\n -2.44740627257387285E+07, &\n 2.24376817792244943E+06, &\n -8.40054336030240853E+04, &\n 5.51335896122020586E+02, &\n 8.14789096118312115E+08, &\n -5.86648149205184723E+09, &\n 1.86882075092958249E+10, &\n -3.46320433881587779E+10, &\n 4.12801855797539740E+10, &\n -3.30265997498007231E+10, &\n 1.79542137311556001E+10, &\n -6.56329379261928433E+09, &\n 1.55927986487925751E+09, &\n -2.25105661889415278E+08/\n DATA C(89), C(90), C(91), C(92), C(93), C(94), C(95), &\n C(96)/1.73951075539781645E+07, &\n -5.49842327572288687E+05, &\n 3.03809051092238427E+03, &\n -1.46792612476956167E+10, &\n 1.14498237732025810E+11, &\n -3.99096175224466498E+11, &\n 8.19218669548577329E+11, &\n -1.09837515608122331E+12/\n DATA C(97), C(98), C(99), C(100), C(101), C(102), &\n C(103), C(104), C(105)/1.00815810686538209E+12, &\n -6.45364869245376503E+11, &\n 2.87900649906150589E+11, &\n -8.78670721780232657E+10, &\n 1.76347306068349694E+10, &\n -2.16716498322379509E+09, &\n 1.43157876718888981E+08, &\n -3.87183344257261262E+06, &\n 1.82577554742931747E+04/\n DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), &\n ALFA(6), ALFA(7), ALFA(8), ALFA(9), ALFA(10), &\n ALFA(11), ALFA(12), ALFA(13), &\n ALFA(14)/-4.44444444444444444E-03, &\n -9.22077922077922078E-04, &\n -8.84892884892884893E-05, &\n 1.65927687832449737E-04, &\n 2.46691372741792910E-04, &\n 2.65995589346254780E-04, &\n 2.61824297061500945E-04, &\n 2.48730437344655609E-04, &\n 2.32721040083232098E-04, &\n 2.16362485712365082E-04, &\n 2.00738858762752355E-04, &\n 1.86267636637545172E-04, &\n 1.73060775917876493E-04, &\n 1.61091705929015752E-04/\n DATA ALFA(15), ALFA(16), ALFA(17), ALFA(18), &\n ALFA(19), ALFA(20), ALFA(21), &\n ALFA(22)/1.50274774160908134E-04, &\n 1.40503497391269794E-04, &\n 1.31668816545922806E-04, &\n 1.23667445598253261E-04, &\n 1.16405271474737902E-04, &\n 1.09798298372713369E-04, &\n 1.03772410422992823E-04, &\n 9.82626078369363448E-05/\n DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), &\n ALFA(27), ALFA(28), ALFA(29), ALFA(30), &\n ALFA(31), ALFA(32), ALFA(33), ALFA(34), &\n ALFA(35), ALFA(36)/9.32120517249503256E-05, &\n 8.85710852478711718E-05, &\n 8.42963105715700223E-05, &\n 8.03497548407791151E-05, &\n 7.66981345359207388E-05, &\n 7.33122157481777809E-05, &\n 7.01662625163141333E-05, &\n 6.72375633790160292E-05, &\n 6.93735541354588974E-04, &\n 2.32241745182921654E-04, &\n -1.41986273556691197E-05, &\n -1.16444931672048640E-04, &\n -1.50803558053048762E-04, &\n -1.55121924918096223E-04/\n DATA ALFA(37), ALFA(38), ALFA(39), ALFA(40), &\n ALFA(41), ALFA(42), ALFA(43), &\n ALFA(44)/-1.46809756646465549E-04, &\n -1.33815503867491367E-04, &\n -1.19744975684254051E-04, &\n -1.06184319207974020E-04, &\n -9.37699549891194492E-05, &\n -8.26923045588193274E-05, &\n -7.29374348155221211E-05, &\n -6.44042357721016283E-05/\n DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), &\n ALFA(49), ALFA(50), ALFA(51), ALFA(52), &\n ALFA(53), ALFA(54), ALFA(55), ALFA(56), &\n ALFA(57), ALFA(58)/-5.69611566009369048E-05, &\n -5.04731044303561628E-05, &\n -4.48134868008882786E-05, &\n -3.98688727717598864E-05, &\n -3.55400532972042498E-05, &\n -3.17414256609022480E-05, &\n -2.83996793904174811E-05, &\n -2.54522720634870566E-05, &\n -2.28459297164724555E-05, &\n -2.05352753106480604E-05, &\n -1.84816217627666085E-05, &\n -1.66519330021393806E-05, &\n -1.50179412980119482E-05, &\n -1.35554031379040526E-05/\n DATA ALFA(59), ALFA(60), ALFA(61), ALFA(62), &\n ALFA(63), ALFA(64), ALFA(65), &\n ALFA(66)/-1.22434746473858131E-05, &\n -1.10641884811308169E-05, &\n -3.54211971457743841E-04, &\n -1.56161263945159416E-04, &\n 3.04465503594936410E-05, &\n 1.30198655773242693E-04, &\n 1.67471106699712269E-04, &\n 1.70222587683592569E-04/\n DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), &\n ALFA(71), ALFA(72), ALFA(73), ALFA(74), &\n ALFA(75), ALFA(76), ALFA(77), ALFA(78), &\n ALFA(79), ALFA(80)/1.56501427608594704E-04, &\n 1.36339170977445120E-04, &\n 1.14886692029825128E-04, &\n 9.45869093034688111E-05, &\n 7.64498419250898258E-05, &\n 6.07570334965197354E-05, &\n 4.74394299290508799E-05, &\n 3.62757512005344297E-05, &\n 2.69939714979224901E-05, &\n 1.93210938247939253E-05, &\n 1.30056674793963203E-05, &\n 7.82620866744496661E-06, &\n 3.59257485819351583E-06, &\n 1.44040049814251817E-07/\n DATA ALFA(81), ALFA(82), ALFA(83), ALFA(84), &\n ALFA(85), ALFA(86), ALFA(87), &\n ALFA(88)/-2.65396769697939116E-06, &\n -4.91346867098485910E-06, &\n -6.72739296091248287E-06, &\n -8.17269379678657923E-06, &\n -9.31304715093561232E-06, &\n -1.02011418798016441E-05, &\n -1.08805962510592880E-05, &\n -1.13875481509603555E-05/\n DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), &\n ALFA(93), ALFA(94), ALFA(95), ALFA(96), &\n ALFA(97), ALFA(98), ALFA(99), ALFA(100), &\n ALFA(101), ALFA(102)/-1.17519675674556414E-05, &\n -1.19987364870944141E-05, &\n 3.78194199201772914E-04, &\n 2.02471952761816167E-04, &\n -6.37938506318862408E-05, &\n -2.38598230603005903E-04, &\n -3.10916256027361568E-04, &\n -3.13680115247576316E-04, &\n -2.78950273791323387E-04, &\n -2.28564082619141374E-04, &\n -1.75245280340846749E-04, &\n -1.25544063060690348E-04, &\n -8.22982872820208365E-05, &\n -4.62860730588116458E-05/\n DATA ALFA(103), ALFA(104), ALFA(105), ALFA(106), &\n ALFA(107), ALFA(108), ALFA(109), &\n ALFA(110)/-1.72334302366962267E-05, &\n 5.60690482304602267E-06, &\n 2.31395443148286800E-05, &\n 3.62642745856793957E-05, &\n 4.58006124490188752E-05, &\n 5.24595294959114050E-05, &\n 5.68396208545815266E-05, &\n 5.94349820393104052E-05/\n DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), &\n ALFA(115), ALFA(116), ALFA(117), ALFA(118), &\n ALFA(119), ALFA(120), ALFA(121), &\n ALFA(122)/6.06478527578421742E-05, &\n 6.08023907788436497E-05, &\n 6.01577894539460388E-05, &\n 5.89199657344698500E-05, &\n 5.72515823777593053E-05, &\n 5.52804375585852577E-05, &\n 5.31063773802880170E-05, &\n 5.08069302012325706E-05, &\n 4.84418647620094842E-05, &\n 4.60568581607475370E-05, &\n -6.91141397288294174E-04, &\n -4.29976633058871912E-04/\n DATA ALFA(123), ALFA(124), ALFA(125), ALFA(126), &\n ALFA(127), ALFA(128), ALFA(129), &\n ALFA(130)/1.83067735980039018E-04, &\n 6.60088147542014144E-04, &\n 8.75964969951185931E-04, &\n 8.77335235958235514E-04, &\n 7.49369585378990637E-04, &\n 5.63832329756980918E-04, &\n 3.68059319971443156E-04, &\n 1.88464535514455599E-04/\n DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), &\n ALFA(135), ALFA(136), ALFA(137), ALFA(138), &\n ALFA(139), ALFA(140), ALFA(141), &\n ALFA(142)/3.70663057664904149E-05, &\n -8.28520220232137023E-05, &\n -1.72751952869172998E-04, &\n -2.36314873605872983E-04, &\n -2.77966150694906658E-04, &\n -3.02079514155456919E-04, &\n -3.12594712643820127E-04, &\n -3.12872558758067163E-04, &\n -3.05678038466324377E-04, &\n -2.93226470614557331E-04, &\n -2.77255655582934777E-04, &\n -2.59103928467031709E-04/\n DATA ALFA(143), ALFA(144), ALFA(145), ALFA(146), &\n ALFA(147), ALFA(148), ALFA(149), &\n ALFA(150)/-2.39784014396480342E-04, &\n -2.20048260045422848E-04, &\n -2.00443911094971498E-04, &\n -1.81358692210970687E-04, &\n -1.63057674478657464E-04, &\n -1.45712672175205844E-04, &\n -1.29425421983924587E-04, &\n -1.14245691942445952E-04/\n DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), &\n ALFA(155), ALFA(156), ALFA(157), ALFA(158), &\n ALFA(159), ALFA(160), ALFA(161), &\n ALFA(162)/1.92821964248775885E-03, &\n 1.35592576302022234E-03, &\n -7.17858090421302995E-04, &\n -2.58084802575270346E-03, &\n -3.49271130826168475E-03, &\n -3.46986299340960628E-03, &\n -2.82285233351310182E-03, &\n -1.88103076404891354E-03, &\n -8.89531718383947600E-04, &\n 3.87912102631035228E-06, &\n 7.28688540119691412E-04, &\n 1.26566373053457758E-03/\n DATA ALFA(163), ALFA(164), ALFA(165), ALFA(166), &\n ALFA(167), ALFA(168), ALFA(169), &\n ALFA(170)/1.62518158372674427E-03, &\n 1.83203153216373172E-03, &\n 1.91588388990527909E-03, &\n 1.90588846755546138E-03, &\n 1.82798982421825727E-03, &\n 1.70389506421121530E-03, &\n 1.55097127171097686E-03, &\n 1.38261421852276159E-03/\n DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), &\n ALFA(175), ALFA(176), ALFA(177), ALFA(178), &\n ALFA(179), ALFA(180)/1.20881424230064774E-03, &\n 1.03676532638344962E-03, &\n 8.71437918068619115E-04, &\n 7.16080155297701002E-04, &\n 5.72637002558129372E-04, &\n 4.42089819465802277E-04, &\n 3.24724948503090564E-04, &\n 2.20342042730246599E-04, &\n 1.28412898401353882E-04, &\n 4.82005924552095464E-05/\n DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), &\n BETA(6), BETA(7), BETA(8), BETA(9), BETA(10), &\n BETA(11), BETA(12), BETA(13), &\n BETA(14)/1.79988721413553309E-02, &\n 5.59964911064388073E-03, &\n 2.88501402231132779E-03, &\n 1.80096606761053941E-03, &\n 1.24753110589199202E-03, &\n 9.22878876572938311E-04, &\n 7.14430421727287357E-04, &\n 5.71787281789704872E-04, &\n 4.69431007606481533E-04, &\n 3.93232835462916638E-04, &\n 3.34818889318297664E-04, &\n 2.88952148495751517E-04, &\n 2.52211615549573284E-04, &\n 2.22280580798883327E-04/\n DATA BETA(15), BETA(16), BETA(17), BETA(18), &\n BETA(19), BETA(20), BETA(21), &\n BETA(22)/1.97541838033062524E-04, &\n 1.76836855019718004E-04, &\n 1.59316899661821081E-04, &\n 1.44347930197333986E-04, &\n 1.31448068119965379E-04, &\n 1.20245444949302884E-04, &\n 1.10449144504599392E-04, &\n 1.01828770740567258E-04/\n DATA BETA(23), BETA(24), BETA(25), BETA(26), &\n BETA(27), BETA(28), BETA(29), BETA(30), &\n BETA(31), BETA(32), BETA(33), BETA(34), &\n BETA(35), BETA(36)/9.41998224204237509E-05, &\n 8.74130545753834437E-05, &\n 8.13466262162801467E-05, &\n 7.59002269646219339E-05, &\n 7.09906300634153481E-05, &\n 6.65482874842468183E-05, &\n 6.25146958969275078E-05, &\n 5.88403394426251749E-05, &\n -1.49282953213429172E-03, &\n -8.78204709546389328E-04, &\n -5.02916549572034614E-04, &\n -2.94822138512746025E-04, &\n -1.75463996970782828E-04, &\n -1.04008550460816434E-04/\n DATA BETA(37), BETA(38), BETA(39), BETA(40), &\n BETA(41), BETA(42), BETA(43), &\n BETA(44)/-5.96141953046457895E-05, &\n -3.12038929076098340E-05, &\n -1.26089735980230047E-05, &\n -2.42892608575730389E-07, &\n 8.05996165414273571E-06, &\n 1.36507009262147391E-05, &\n 1.73964125472926261E-05, &\n 1.98672978842133780E-05/\n DATA BETA(45), BETA(46), BETA(47), BETA(48), &\n BETA(49), BETA(50), BETA(51), BETA(52), &\n BETA(53), BETA(54), BETA(55), BETA(56), &\n BETA(57), BETA(58)/2.14463263790822639E-05, &\n 2.23954659232456514E-05, &\n 2.28967783814712629E-05, &\n 2.30785389811177817E-05, &\n 2.30321976080909144E-05, &\n 2.28236073720348722E-05, &\n 2.25005881105292418E-05, &\n 2.20981015361991429E-05, &\n 2.16418427448103905E-05, &\n 2.11507649256220843E-05, &\n 2.06388749782170737E-05, &\n 2.01165241997081666E-05, &\n 1.95913450141179244E-05, &\n 1.90689367910436740E-05/\n DATA BETA(59), BETA(60), BETA(61), BETA(62), &\n BETA(63), BETA(64), BETA(65), &\n BETA(66)/1.85533719641636667E-05, &\n 1.80475722259674218E-05, &\n 5.52213076721292790E-04, &\n 4.47932581552384646E-04, &\n 2.79520653992020589E-04, &\n 1.52468156198446602E-04, &\n 6.93271105657043598E-05, &\n 1.76258683069991397E-05/\n DATA BETA(67), BETA(68), BETA(69), BETA(70), &\n BETA(71), BETA(72), BETA(73), BETA(74), &\n BETA(75), BETA(76), BETA(77), BETA(78), &\n BETA(79), BETA(80)/-1.35744996343269136E-05, &\n -3.17972413350427135E-05, &\n -4.18861861696693365E-05, &\n -4.69004889379141029E-05, &\n -4.87665447413787352E-05, &\n -4.87010031186735069E-05, &\n -4.74755620890086638E-05, &\n -4.55813058138628452E-05, &\n -4.33309644511266036E-05, &\n -4.09230193157750364E-05, &\n -3.84822638603221274E-05, &\n -3.60857167535410501E-05, &\n -3.37793306123367417E-05, &\n -3.15888560772109621E-05/\n DATA BETA(81), BETA(82), BETA(83), BETA(84), &\n BETA(85), BETA(86), BETA(87), &\n BETA(88)/-2.95269561750807315E-05, &\n -2.75978914828335759E-05, &\n -2.58006174666883713E-05, &\n -2.41308356761280200E-05, &\n -2.25823509518346033E-05, &\n -2.11479656768912971E-05, &\n -1.98200638885294927E-05, &\n -1.85909870801065077E-05/\n DATA BETA(89), BETA(90), BETA(91), BETA(92), &\n BETA(93), BETA(94), BETA(95), BETA(96), &\n BETA(97), BETA(98), BETA(99), BETA(100), &\n BETA(101), BETA(102)/-1.74532699844210224E-05, &\n -1.63997823854497997E-05, &\n -4.74617796559959808E-04, &\n -4.77864567147321487E-04, &\n -3.20390228067037603E-04, &\n -1.61105016119962282E-04, &\n -4.25778101285435204E-05, &\n 3.44571294294967503E-05, &\n 7.97092684075674924E-05, &\n 1.03138236708272200E-04, &\n 1.12466775262204158E-04, &\n 1.13103642108481389E-04, &\n 1.08651634848774268E-04, &\n 1.01437951597661973E-04/\n DATA BETA(103), BETA(104), BETA(105), BETA(106), &\n BETA(107), BETA(108), BETA(109), &\n BETA(110)/9.29298396593363896E-05, &\n 8.40293133016089978E-05, &\n 7.52727991349134062E-05, &\n 6.69632521975730872E-05, &\n 5.92564547323194704E-05, &\n 5.22169308826975567E-05, &\n 4.58539485165360646E-05, &\n 4.01445513891486808E-05/\n DATA BETA(111), BETA(112), BETA(113), BETA(114), &\n BETA(115), BETA(116), BETA(117), BETA(118), &\n BETA(119), BETA(120), BETA(121), &\n BETA(122)/3.50481730031328081E-05, &\n 3.05157995034346659E-05, &\n 2.64956119950516039E-05, &\n 2.29363633690998152E-05, &\n 1.97893056664021636E-05, &\n 1.70091984636412623E-05, &\n 1.45547428261524004E-05, &\n 1.23886640995878413E-05, &\n 1.04775876076583236E-05, &\n 8.79179954978479373E-06, &\n 7.36465810572578444E-04, &\n 8.72790805146193976E-04/\n DATA BETA(123), BETA(124), BETA(125), BETA(126), &\n BETA(127), BETA(128), BETA(129), &\n BETA(130)/6.22614862573135066E-04, &\n 2.85998154194304147E-04, &\n 3.84737672879366102E-06, &\n -1.87906003636971558E-04, &\n -2.97603646594554535E-04, &\n -3.45998126832656348E-04, &\n -3.53382470916037712E-04, &\n -3.35715635775048757E-04/\n DATA BETA(131), BETA(132), BETA(133), BETA(134), &\n BETA(135), BETA(136), BETA(137), BETA(138), &\n BETA(139), BETA(140), BETA(141), &\n BETA(142)/-3.04321124789039809E-04, &\n -2.66722723047612821E-04, &\n -2.27654214122819527E-04, &\n -1.89922611854562356E-04, &\n -1.55058918599093870E-04, &\n -1.23778240761873630E-04, &\n -9.62926147717644187E-05, &\n -7.25178327714425337E-05, &\n -5.22070028895633801E-05, &\n -3.50347750511900522E-05, &\n -2.06489761035551757E-05, &\n -8.70106096849767054E-06/\n DATA BETA(143), BETA(144), BETA(145), BETA(146), &\n BETA(147), BETA(148), BETA(149), &\n BETA(150)/1.13698686675100290E-06, &\n 9.16426474122778849E-06, &\n 1.56477785428872620E-05, &\n 2.08223629482466847E-05, &\n 2.48923381004595156E-05, &\n 2.80340509574146325E-05, &\n 3.03987774629861915E-05, &\n 3.21156731406700616E-05/\n DATA BETA(151), BETA(152), BETA(153), BETA(154), &\n BETA(155), BETA(156), BETA(157), BETA(158), &\n BETA(159), BETA(160), BETA(161), &\n BETA(162)/-1.80182191963885708E-03, &\n -2.43402962938042533E-03, &\n -1.83422663549856802E-03, &\n -7.62204596354009765E-04, &\n 2.39079475256927218E-04, &\n 9.49266117176881141E-04, &\n 1.34467449701540359E-03, &\n 1.48457495259449178E-03, &\n 1.44732339830617591E-03, &\n 1.30268261285657186E-03, &\n 1.10351597375642682E-03, &\n 8.86047440419791759E-04/\n DATA BETA(163), BETA(164), BETA(165), BETA(166), &\n BETA(167), BETA(168), BETA(169), &\n BETA(170)/6.73073208165665473E-04, &\n 4.77603872856582378E-04, &\n 3.05991926358789362E-04, &\n 1.60315694594721630E-04, &\n 4.00749555270613286E-05, &\n -5.66607461635251611E-05, &\n -1.32506186772982638E-04, &\n -1.90296187989614057E-04/\n DATA BETA(171), BETA(172), BETA(173), BETA(174), &\n BETA(175), BETA(176), BETA(177), BETA(178), &\n BETA(179), BETA(180), BETA(181), &\n BETA(182)/-2.32811450376937408E-04, &\n -2.62628811464668841E-04, &\n -2.82050469867598672E-04, &\n -2.93081563192861167E-04, &\n -2.97435962176316616E-04, &\n -2.96557334239348078E-04, &\n -2.91647363312090861E-04, &\n -2.83696203837734166E-04, &\n -2.73512317095673346E-04, &\n -2.61750155806768580E-04, &\n 6.38585891212050914E-03, &\n 9.62374215806377941E-03/\n DATA BETA(183), BETA(184), BETA(185), BETA(186), &\n BETA(187), BETA(188), BETA(189), &\n BETA(190)/7.61878061207001043E-03, &\n 2.83219055545628054E-03, &\n -2.09841352012720090E-03, &\n -5.73826764216626498E-03, &\n -7.70804244495414620E-03, &\n -8.21011692264844401E-03, &\n -7.65824520346905413E-03, &\n -6.47209729391045177E-03/\n DATA BETA(191), BETA(192), BETA(193), BETA(194), &\n BETA(195), BETA(196), BETA(197), BETA(198), &\n BETA(199), BETA(200), BETA(201), &\n BETA(202)/-4.99132412004966473E-03, &\n -3.45612289713133280E-03, &\n -2.01785580014170775E-03, &\n -7.59430686781961401E-04, &\n 2.84173631523859138E-04, &\n 1.10891667586337403E-03, &\n 1.72901493872728771E-03, &\n 2.16812590802684701E-03, &\n 2.45357710494539735E-03, &\n 2.61281821058334862E-03, &\n 2.67141039656276912E-03, &\n 2.65203073395980430E-03/\n DATA BETA(203), BETA(204), BETA(205), BETA(206), &\n BETA(207), BETA(208), BETA(209), &\n BETA(210)/2.57411652877287315E-03, &\n 2.45389126236094427E-03, &\n 2.30460058071795494E-03, &\n 2.13684837686712662E-03, &\n 1.95896528478870911E-03, &\n 1.77737008679454412E-03, &\n 1.59690280765839059E-03, &\n 1.42111975664438546E-03/\n DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), &\n GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), &\n GAMA(11), GAMA(12), GAMA(13), &\n GAMA(14)/6.29960524947436582E-01, &\n 2.51984209978974633E-01, &\n 1.54790300415655846E-01, &\n 1.10713062416159013E-01, &\n 8.57309395527394825E-02, &\n 6.97161316958684292E-02, &\n 5.86085671893713576E-02, &\n 5.04698873536310685E-02, &\n 4.42600580689154809E-02, &\n 3.93720661543509966E-02, &\n 3.54283195924455368E-02, &\n 3.21818857502098231E-02, &\n 2.94646240791157679E-02, &\n 2.71581677112934479E-02/\n DATA GAMA(15), GAMA(16), GAMA(17), GAMA(18), &\n GAMA(19), GAMA(20), GAMA(21), &\n GAMA(22)/2.51768272973861779E-02, &\n 2.34570755306078891E-02, &\n 2.19508390134907203E-02, &\n 2.06210828235646240E-02, &\n 1.94388240897880846E-02, &\n 1.83810633800683158E-02, &\n 1.74293213231963172E-02, &\n 1.65685837786612353E-02/\n DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), &\n GAMA(27), GAMA(28), GAMA(29), &\n GAMA(30)/1.57865285987918445E-02, &\n 1.50729501494095594E-02, &\n 1.44193250839954639E-02, &\n 1.38184805735341786E-02, &\n 1.32643378994276568E-02, &\n 1.27517121970498651E-02, &\n 1.22761545318762767E-02, &\n 1.18338262398482403E-02/\n DATA EX1, EX2, HPI, PI, THPI/3.33333333333333333E-01, &\n 6.66666666666666667E-01, &\n 1.57079632679489662E+00, &\n 3.14159265358979324E+00, &\n 4.71238898038468986E+00/\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n RFNU = 1.0E0/FNU\n TSTR = REAL(Z)\n TSTI = AIMAG(Z)\n TEST = FNU*EXP(-ELIM)\n if (ABS(TSTR) < TEST) TSTR = 0.0E0\n if (ABS(TSTI) < TEST) TSTI = 0.0E0\n if (TSTR == 0.0E0 .and. TSTI == 0.0E0) then\n ZETA1 = CMPLX(ELIM+ELIM+FNU,0.0E0)\n ZETA2 = CMPLX(FNU,0.0E0)\n PHI = CONE\n ARG = CONE\n return\n endif\n ZB = CMPLX(TSTR,TSTI)*CMPLX(RFNU,0.0E0)\n RFNU2 = RFNU*RFNU\n! ------------------------------------------------------------------\n! COMPUTE IN THE FOURTH QUADRANT\n! ------------------------------------------------------------------\n FN13 = FNU**EX1\n FN23 = FN13*FN13\n RFN13 = CMPLX(1.0E0/FN13,0.0E0)\n W2 = CONE - ZB*ZB\n AW2 = ABS(W2)\n if (AW2 > 0.25E0) then\n! ---------------------------------------------------------------\n! CABS(W2)>0.25E0\n! ---------------------------------------------------------------\n W = SQRT(W2)\n WR = REAL(W)\n WI = AIMAG(W)\n if (WR < 0.0E0) WR = 0.0E0\n if (WI < 0.0E0) WI = 0.0E0\n W = CMPLX(WR,WI)\n ZA = (CONE+W)/ZB\n ZC = LOG(ZA)\n ZCR = REAL(ZC)\n ZCI = AIMAG(ZC)\n if (ZCI < 0.0E0) ZCI = 0.0E0\n if (ZCI > HPI) ZCI = HPI\n if (ZCR < 0.0E0) ZCR = 0.0E0\n ZC = CMPLX(ZCR,ZCI)\n ZTH = (ZC-W)*CMPLX(1.5E0,0.0E0)\n CFNU = CMPLX(FNU,0.0E0)\n ZETA1 = ZC*CFNU\n ZETA2 = W*CFNU\n AZTH = ABS(ZTH)\n ZTHR = REAL(ZTH)\n ZTHI = AIMAG(ZTH)\n ANG = THPI\n if (ZTHR < 0.0E0 .or. ZTHI >= 0.0E0) then\n ANG = HPI\n if (ZTHR /= 0.0E0) then\n ANG = ATAN(ZTHI/ZTHR)\n if (ZTHR < 0.0E0) ANG = ANG + PI\n endif\n endif\n PP = AZTH**EX2\n ANG = ANG*EX2\n ZETAR = PP*COS(ANG)\n ZETAI = PP*SIN(ANG)\n if (ZETAI < 0.0E0) ZETAI = 0.0E0\n ZETA = CMPLX(ZETAR,ZETAI)\n ARG = ZETA*CMPLX(FN23,0.0E0)\n RTZTA = ZTH/ZETA\n ZA = RTZTA/W\n PHI = SQRT(ZA+ZA)*RFN13\n if (IPMTR /= 1) then\n TFN = CMPLX(RFNU,0.0E0)/W\n RZTH = CMPLX(RFNU,0.0E0)/ZTH\n ZC = RZTH*CMPLX(AR(2),0.0E0)\n T2 = CONE/W2\n UP(2) = (T2*CMPLX(C(2),0.0E0)+CMPLX(C(3),0.0E0))*TFN\n BSUM = UP(2) + ZC\n ASUM = CZERO\n if (RFNU >= TOL) then\n PRZTH = RZTH\n PTFN = TFN\n UP(1) = CONE\n PP = 1.0E0\n BSUMR = REAL(BSUM)\n BSUMI = AIMAG(BSUM)\n BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI))\n KS = 0\n KP1 = 2\n L = 3\n IAS = 0\n IBS = 0\n DO 100 LR = 2, 12, 2\n LRP1 = LR + 1\n! ------------------------------------------------------\n! COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE\n! TERMS IN NEXT SUMA AND SUMB\n! ------------------------------------------------------\n DO 40 K = LR, LRP1\n KS = KS + 1\n KP1 = KP1 + 1\n L = L + 1\n ZA = CMPLX(C(L),0.0E0)\n DO 20 J = 2, KP1\n L = L + 1\n ZA = ZA*T2 + CMPLX(C(L),0.0E0)\n 20 continue\n PTFN = PTFN*TFN\n UP(KP1) = PTFN*ZA\n CR(KS) = PRZTH*CMPLX(BR(KS+1),0.0E0)\n PRZTH = PRZTH*RZTH\n DR(KS) = PRZTH*CMPLX(AR(KS+2),0.0E0)\n 40 continue\n PP = PP*RFNU2\n if (IAS /= 1) then\n SUMA = UP(LRP1)\n JU = LRP1\n DO 60 JR = 1, LR\n JU = JU - 1\n SUMA = SUMA + CR(JR)*UP(JU)\n 60 continue\n ASUM = ASUM + SUMA\n ASUMR = REAL(ASUM)\n ASUMI = AIMAG(ASUM)\n TEST = ABS(ASUMR) + ABS(ASUMI)\n if (PP < TOL .and. TEST < TOL) IAS = 1\n endif\n if (IBS /= 1) then\n SUMB = UP(LR+2) + UP(LRP1)*ZC\n JU = LRP1\n DO 80 JR = 1, LR\n JU = JU - 1\n SUMB = SUMB + DR(JR)*UP(JU)\n 80 continue\n BSUM = BSUM + SUMB\n BSUMR = REAL(BSUM)\n BSUMI = AIMAG(BSUM)\n TEST = ABS(BSUMR) + ABS(BSUMI)\n if (PP < BTOL .and. TEST < TOL) IBS = 1\n endif\n if (IAS == 1 .and. IBS == 1) goto 120\n 100 continue\n endif\n 120 ASUM = ASUM + CONE\n BSUM = -BSUM*RFN13/RTZTA\n endif\n ELSE\n! ---------------------------------------------------------------\n! POWER SERIES FOR CABS(W2) <= 0.25E0\n! ---------------------------------------------------------------\n K = 1\n P(1) = CONE\n SUMA = CMPLX(GAMA(1),0.0E0)\n AP(1) = 1.0E0\n if (AW2 >= TOL) then\n DO 140 K = 2, 30\n P(K) = P(K-1)*W2\n SUMA = SUMA + P(K)*CMPLX(GAMA(K),0.0E0)\n AP(K) = AP(K-1)*AW2\n if (AP(K) < TOL) goto 160\n 140 continue\n K = 30\n endif\n 160 KMAX = K\n ZETA = W2*SUMA\n ARG = ZETA*CMPLX(FN23,0.0E0)\n ZA = SQRT(SUMA)\n ZETA2 = SQRT(W2)*CMPLX(FNU,0.0E0)\n ZETA1 = ZETA2*(CONE+ZETA*ZA*CMPLX(EX2,0.0E0))\n ZA = ZA + ZA\n PHI = SQRT(ZA)*RFN13\n if (IPMTR /= 1) then\n! ------------------------------------------------------------\n! SUM SERIES FOR ASUM AND BSUM\n! ------------------------------------------------------------\n SUMB = CZERO\n DO 180 K = 1, KMAX\n SUMB = SUMB + P(K)*CMPLX(BETA(K),0.0E0)\n 180 continue\n ASUM = CZERO\n BSUM = SUMB\n L1 = 0\n L2 = 30\n BTOL = TOL*ABS(BSUM)\n ATOL = TOL\n PP = 1.0E0\n IAS = 0\n IBS = 0\n if (RFNU2 >= TOL) then\n DO 280 IS = 2, 7\n ATOL = ATOL/RFNU2\n PP = PP*RFNU2\n if (IAS /= 1) then\n SUMA = CZERO\n DO 200 K = 1, KMAX\n M = L1 + K\n SUMA = SUMA + P(K)*CMPLX(ALFA(M),0.0E0)\n if (AP(K) < ATOL) goto 220\n 200 continue\n 220 ASUM = ASUM + SUMA*CMPLX(PP,0.0E0)\n if (PP < TOL) IAS = 1\n endif\n if (IBS /= 1) then\n SUMB = CZERO\n DO 240 K = 1, KMAX\n M = L2 + K\n SUMB = SUMB + P(K)*CMPLX(BETA(M),0.0E0)\n if (AP(K) < ATOL) goto 260\n 240 continue\n 260 BSUM = BSUM + SUMB*CMPLX(PP,0.0E0)\n if (PP < BTOL) IBS = 1\n endif\n if (IAS == 1 .and. IBS == 1) then\n goto 300\n ELSE\n L1 = L1 + 30\n L2 = L2 + 30\n endif\n 280 continue\n endif\n 300 ASUM = ASUM + CONE\n PP = RFNU*REAL(RFN13)\n BSUM = BSUM*CMPLX(PP,0.0E0)\n endif\n endif\n return\n END\n subroutine DEVS17(Z,FNU,KODE,IKFLG,N,Y,NUF,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-765 (DEC 1989).\n!\n! Original name: CUOIK\n!\n! DEVS17 COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC\n! EXPANSIONS FOR THE I AND K functionS AND COMPARES THEM\n! (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW\n! WHERE ALIM < ELIM. IF THE MAGNITUDE, BASED ON THE LEADING\n! EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN\n! THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER\n! MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE\n! EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)=\n! EXP(-ELIM)/TOL\n!\n! IKFLG=1 MEANS THE I SEQUENCE IS TESTED\n! =2 MEANS THE K SEQUENCE IS TESTED\n! NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE\n! =-1 MEANS AN OVERFLOW WOULD OCCUR\n! IKFLG=1 AND NUF>0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO\n! THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE\n! IKFLG=2 AND NUF==N MEANS ALL Y VALUES WERE SET TO ZERO\n! IKFLG=2 AND 0 < NUF < N NOT CONSIDERED. Y MUST BE SET BY\n! ANOTHER ROUTINE\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER IKFLG, KODE, N, NUF\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX ARG, ASUM, BSUM, CZ, CZERO, PHI, SUM, ZB, ZETA1, &\n ZETA2, ZN, ZR\n REAL AARG, AIC, APHI, ASCLE, AX, AY, FNN, GNN, GNU, &\n RCZ, X, YY\n INTEGER I, IFORM, INIT, NN, NW\n! .. Local Arrays ..\n COMPLEX CWRK(16)\n! .. External functions ..\n REAL X02AME\n EXTERNAL X02AME\n! .. External subroutines ..\n EXTERNAL DEUS17, DEWS17, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, LOG, MAX, &\n REAL, SIN\n! .. Data statements ..\n DATA CZERO/(0.0E0,0.0E0)/\n DATA AIC/1.265512123484645396E+00/\n! .. Executable Statements ..\n!\n NUF = 0\n NN = N\n X = REAL(Z)\n ZR = Z\n if (X < 0.0E0) ZR = -Z\n ZB = ZR\n YY = AIMAG(ZR)\n AX = ABS(X)*1.7321E0\n AY = ABS(YY)\n IFORM = 1\n if (AY > AX) IFORM = 2\n GNU = MAX(FNU,1.0E0)\n if (IKFLG /= 1) then\n FNN = NN\n GNN = FNU + FNN - 1.0E0\n GNU = MAX(GNN,FNN)\n endif\n! ------------------------------------------------------------------\n! ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE\n! REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET\n! THE SIGN OF THE IMAGINARY PART CORRECT.\n! ------------------------------------------------------------------\n if (IFORM == 2) then\n ZN = -ZR*CMPLX(0.0E0,1.0E0)\n if (YY <= 0.0E0) ZN = CONJG(-ZN)\n CALL DEUS17(ZN,GNU,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM)\n CZ = -ZETA1 + ZETA2\n AARG = ABS(ARG)\n ELSE\n INIT = 0\n CALL DEWS17(ZR,GNU,IKFLG,1,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK, &\n ELIM)\n CZ = -ZETA1 + ZETA2\n endif\n if (KODE == 2) CZ = CZ - ZB\n if (IKFLG == 2) CZ = -CZ\n APHI = ABS(PHI)\n RCZ = REAL(CZ)\n! ------------------------------------------------------------------\n! OVERFLOW TEST\n! ------------------------------------------------------------------\n if (RCZ <= ELIM) then\n if (RCZ < ALIM) then\n! ------------------------------------------------------------\n! UNDERFLOW TEST\n! ------------------------------------------------------------\n if (RCZ >= (-ELIM)) then\n if (RCZ > (-ALIM)) then\n goto 40\n ELSE\n RCZ = RCZ + LOG(APHI)\n if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC\n if (RCZ > (-ELIM)) then\n ASCLE = (1.0E+3*X02AME())/TOL\n CZ = CZ + LOG(PHI)\n if (IFORM /= 1) CZ = CZ - CMPLX(0.25E0,0.0E0) &\n *LOG(ARG) - CMPLX(AIC,0.0E0)\n AX = EXP(RCZ)/TOL\n AY = AIMAG(CZ)\n CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY))\n CALL DGVS17(CZ,NW,ASCLE,TOL)\n if (NW /= 1) goto 40\n endif\n endif\n endif\n DO 20 I = 1, NN\n Y(I) = CZERO\n 20 continue\n NUF = NN\n return\n ELSE\n RCZ = RCZ + LOG(APHI)\n if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC\n if (RCZ > ELIM) goto 80\n endif\n 40 if (IKFLG /= 2) then\n if (N /= 1) then\n 60 continue\n! ---------------------------------------------------------\n! SET UNDERFLOWS ON I SEQUENCE\n! ---------------------------------------------------------\n GNU = FNU + NN - 1\n if (IFORM == 2) then\n CALL DEUS17(ZN,GNU,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM, &\n BSUM,ELIM)\n CZ = -ZETA1 + ZETA2\n AARG = ABS(ARG)\n ELSE\n INIT = 0\n CALL DEWS17(ZR,GNU,IKFLG,1,TOL,INIT,PHI,ZETA1,ZETA2, &\n SUM,CWRK,ELIM)\n CZ = -ZETA1 + ZETA2\n endif\n if (KODE == 2) CZ = CZ - ZB\n APHI = ABS(PHI)\n RCZ = REAL(CZ)\n if (RCZ >= (-ELIM)) then\n if (RCZ > (-ALIM)) then\n return\n ELSE\n RCZ = RCZ + LOG(APHI)\n if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC\n if (RCZ > (-ELIM)) then\n ASCLE = (1.0E+3*X02AME())/TOL\n CZ = CZ + LOG(PHI)\n if (IFORM /= 1) CZ = CZ - CMPLX(0.25E0,0.0E0) &\n *LOG(ARG) - CMPLX(AIC, &\n 0.0E0)\n AX = EXP(RCZ)/TOL\n AY = AIMAG(CZ)\n CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY))\n CALL DGVS17(CZ,NW,ASCLE,TOL)\n if (NW /= 1) return\n endif\n endif\n endif\n Y(NN) = CZERO\n NN = NN - 1\n NUF = NUF + 1\n if (NN /= 0) goto 60\n endif\n endif\n return\n endif\n 80 NUF = -1\n return\n END\n subroutine DEWS17(ZR,FNU,IKFLG,IPMTR,TOL,INIT,PHI,ZETA1,ZETA2,SUM, &\n CWRK,ELIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-766 (DEC 1989).\n!\n! Original name: CUNIK\n!\n! DEWS17 COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC\n! EXPANSIONS OF THE I AND K functionS ON IKFLG= 1 OR 2\n! RESPECTIVELY BY\n!\n! W(FNU,ZR) = PHI*EXP(ZETA)*SUM\n!\n! WHERE ZETA=-ZETA1 + ZETA2 OR\n! ZETA1 - ZETA2\n!\n! THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE\n! SAME ZR AND FNU WILL return THE I OR K function ON IKFLG=\n! 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK\n! ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI,\n! ZETA1,ZETA2.\n!\n! .. Scalar Arguments ..\n COMPLEX PHI, SUM, ZETA1, ZETA2, ZR\n REAL ELIM, FNU, TOL\n INTEGER IKFLG, INIT, IPMTR\n! .. Array Arguments ..\n COMPLEX CWRK(16)\n! .. Local Scalars ..\n COMPLEX CFN, CONE, CRFN, CZERO, S, SR, T, T2, ZN\n REAL AC, RFN, TEST, TSTI, TSTR\n INTEGER I, J, K, L\n! .. Local Arrays ..\n COMPLEX CON(2)\n REAL C(120)\n!bc\n! .. external functions ..\n real x02ane\n external x02ane\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, EXP, LOG, REAL, SQRT\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n DATA CON(1), CON(2)/(3.98942280401432678E-01,0.0E0), &\n (1.25331413731550025E+00,0.0E0)/\n DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), &\n C(9), C(10), C(11), C(12), C(13), C(14), C(15), &\n C(16)/1.00000000000000000E+00, &\n -2.08333333333333333E-01, &\n 1.25000000000000000E-01, &\n 3.34201388888888889E-01, &\n -4.01041666666666667E-01, &\n 7.03125000000000000E-02, &\n -1.02581259645061728E+00, &\n 1.84646267361111111E+00, &\n -8.91210937500000000E-01, &\n 7.32421875000000000E-02, &\n 4.66958442342624743E+00, &\n -1.12070026162229938E+01, &\n 8.78912353515625000E+00, &\n -2.36408691406250000E+00, &\n 1.12152099609375000E-01, &\n -2.82120725582002449E+01/\n DATA C(17), C(18), C(19), C(20), C(21), C(22), C(23), &\n C(24)/8.46362176746007346E+01, &\n -9.18182415432400174E+01, &\n 4.25349987453884549E+01, &\n -7.36879435947963170E+00, &\n 2.27108001708984375E-01, &\n 2.12570130039217123E+02, &\n -7.65252468141181642E+02, &\n 1.05999045252799988E+03/\n DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), &\n C(32), C(33), C(34), C(35), C(36), C(37), C(38), &\n C(39), C(40)/-6.99579627376132541E+02, &\n 2.18190511744211590E+02, &\n -2.64914304869515555E+01, &\n 5.72501420974731445E-01, &\n -1.91945766231840700E+03, &\n 8.06172218173730938E+03, &\n -1.35865500064341374E+04, &\n 1.16553933368645332E+04, &\n -5.30564697861340311E+03, &\n 1.20090291321635246E+03, &\n -1.08090919788394656E+02, &\n 1.72772750258445740E+00, &\n 2.02042913309661486E+04, &\n -9.69805983886375135E+04, &\n 1.92547001232531532E+05, &\n -2.03400177280415534E+05/\n DATA C(41), C(42), C(43), C(44), C(45), C(46), C(47), &\n C(48)/1.22200464983017460E+05, &\n -4.11926549688975513E+04, &\n 7.10951430248936372E+03, &\n -4.93915304773088012E+02, &\n 6.07404200127348304E+00, &\n -2.42919187900551333E+05, &\n 1.31176361466297720E+06, &\n -2.99801591853810675E+06/\n DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), &\n C(56), C(57), C(58), C(59), C(60), C(61), C(62), &\n C(63), C(64)/3.76327129765640400E+06, &\n -2.81356322658653411E+06, &\n 1.26836527332162478E+06, &\n -3.31645172484563578E+05, &\n 4.52187689813627263E+04, &\n -2.49983048181120962E+03, &\n 2.43805296995560639E+01, &\n 3.28446985307203782E+06, &\n -1.97068191184322269E+07, &\n 5.09526024926646422E+07, &\n -7.41051482115326577E+07, &\n 6.63445122747290267E+07, &\n -3.75671766607633513E+07, &\n 1.32887671664218183E+07, &\n -2.78561812808645469E+06, &\n 3.08186404612662398E+05/\n DATA C(65), C(66), C(67), C(68), C(69), C(70), C(71), &\n C(72)/-1.38860897537170405E+04, &\n 1.10017140269246738E+02, &\n -4.93292536645099620E+07, &\n 3.25573074185765749E+08, &\n -9.39462359681578403E+08, &\n 1.55359689957058006E+09, &\n -1.62108055210833708E+09, &\n 1.10684281682301447E+09/\n DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), &\n C(80), C(81), C(82), C(83), C(84), C(85), C(86), &\n C(87), C(88)/-4.95889784275030309E+08, &\n 1.42062907797533095E+08, &\n -2.44740627257387285E+07, &\n 2.24376817792244943E+06, &\n -8.40054336030240853E+04, &\n 5.51335896122020586E+02, &\n 8.14789096118312115E+08, &\n -5.86648149205184723E+09, &\n 1.86882075092958249E+10, &\n -3.46320433881587779E+10, &\n 4.12801855797539740E+10, &\n -3.30265997498007231E+10, &\n 1.79542137311556001E+10, &\n -6.56329379261928433E+09, &\n 1.55927986487925751E+09, &\n -2.25105661889415278E+08/\n DATA C(89), C(90), C(91), C(92), C(93), C(94), C(95), &\n C(96)/1.73951075539781645E+07, &\n -5.49842327572288687E+05, &\n 3.03809051092238427E+03, &\n -1.46792612476956167E+10, &\n 1.14498237732025810E+11, &\n -3.99096175224466498E+11, &\n 8.19218669548577329E+11, &\n -1.09837515608122331E+12/\n DATA C(97), C(98), C(99), C(100), C(101), C(102), &\n C(103), C(104), C(105), C(106), C(107), C(108), &\n C(109), C(110)/1.00815810686538209E+12, &\n -6.45364869245376503E+11, &\n 2.87900649906150589E+11, &\n -8.78670721780232657E+10, &\n 1.76347306068349694E+10, &\n -2.16716498322379509E+09, &\n 1.43157876718888981E+08, &\n -3.87183344257261262E+06, &\n 1.82577554742931747E+04, &\n 2.86464035717679043E+11, &\n -2.40629790002850396E+12, &\n 9.10934118523989896E+12, &\n -2.05168994109344374E+13, &\n 3.05651255199353206E+13/\n DATA C(111), C(112), C(113), C(114), C(115), C(116), &\n C(117), C(118), C(119), &\n C(120)/-3.16670885847851584E+13, &\n 2.33483640445818409E+13, &\n -1.23204913055982872E+13, &\n 4.61272578084913197E+12, &\n -1.19655288019618160E+12, &\n 2.05914503232410016E+11, &\n -2.18229277575292237E+10, &\n 1.24700929351271032E+09, &\n -2.91883881222208134E+07, &\n 1.18838426256783253E+05/\n! .. Executable Statements ..\n!\n if (INIT == 0) then\n! ---------------------------------------------------------------\n! INITIALIZE ALL VARIABLES\n! ---------------------------------------------------------------\n RFN = 1.0E0/FNU\n CRFN = CMPLX(RFN,0.0E0)\n TSTR = REAL(ZR)\n TSTI = AIMAG(ZR)\n TEST = FNU*EXP(-ELIM)\n if (ABS(TSTR) < TEST) TSTR = 0.0E0\n if (ABS(TSTI) < TEST) TSTI = 0.0E0\n!bc if (TSTR==0.0E0 .and. TSTI==0.0E0) then\n if (abs(tstr) <= x02ane() .and. abs(tsti) <= x02ane()) then\n ZETA1 = CMPLX(ELIM+ELIM+FNU,0.0E0)\n ZETA2 = CMPLX(FNU,0.0E0)\n PHI = CONE\n return\n endif\n T = CMPLX(TSTR,TSTI)*CRFN\n S = CONE + T*T\n SR = SQRT(S)\n CFN = CMPLX(FNU,0.0E0)\n ZN = (CONE+SR)/T\n ZETA1 = CFN*LOG(ZN)\n ZETA2 = CFN*SR\n T = CONE/SR\n SR = T*CRFN\n CWRK(16) = SQRT(SR)\n PHI = CWRK(16)*CON(IKFLG)\n if (IPMTR /= 0) then\n return\n ELSE\n T2 = CONE/S\n CWRK(1) = CONE\n CRFN = CONE\n AC = 1.0E0\n L = 1\n DO 40 K = 2, 15\n S = CZERO\n DO 20 J = 1, K\n L = L + 1\n S = S*T2 + CMPLX(C(L),0.0E0)\n 20 continue\n CRFN = CRFN*SR\n CWRK(K) = CRFN*S\n AC = AC*RFN\n TSTR = REAL(CWRK(K))\n TSTI = AIMAG(CWRK(K))\n TEST = ABS(TSTR) + ABS(TSTI)\n if (AC < TOL .and. TEST < TOL) goto 60\n 40 continue\n K = 15\n 60 INIT = K\n endif\n endif\n if (IKFLG == 2) then\n! ---------------------------------------------------------------\n! COMPUTE SUM FOR THE K function\n! ---------------------------------------------------------------\n S = CZERO\n T = CONE\n DO 80 I = 1, INIT\n S = S + T*CWRK(I)\n T = -T\n 80 continue\n SUM = S\n PHI = CWRK(16)*CON(2)\n ELSE\n! ---------------------------------------------------------------\n! COMPUTE SUM FOR THE I function\n! ---------------------------------------------------------------\n S = CZERO\n DO 100 I = 1, INIT\n S = S + CWRK(I)\n 100 continue\n SUM = S\n PHI = CWRK(16)*CON(1)\n endif\n return\n END\n subroutine DEXS17(Z,FNU,KODE,N,Y,NZ,NLAST,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-767 (DEC 1989).\n!\n! Original name: CUNI1\n!\n! DEXS17 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC\n! EXPANSION FOR I(FNU,Z) IN -PI/3 <= ARG Z <= PI/3.\n!\n! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC\n! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.\n! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER\n! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL.\n! Y(I)=CZERO FOR I=NLAST+1,N\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, TOL\n INTEGER KODE, N, NLAST, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CFN, CONE, CRSC, CSCL, CZERO, PHI, RZ, &\n S1, S2, SUM, ZETA1, ZETA2\n REAL APHI, ASCLE, C2I, C2M, C2R, FN, RS1, YY\n INTEGER I, IFLAG, INIT, K, M, ND, NN, NUF, NW\n! .. Local Arrays ..\n COMPLEX CSR(3), CSS(3), CWRK(16), CY(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEVS17, DEWS17, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MAX, MIN, &\n REAL, SIN\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n ND = N\n NLAST = 0\n! ------------------------------------------------------------------\n! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-\n! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,\n! EXP(ALIM)=EXP(ELIM)*TOL\n! ------------------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n! ------------------------------------------------------------------\n! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER\n! ------------------------------------------------------------------\n FN = MAX(FNU,1.0E0)\n INIT = 0\n CALL DEWS17(Z,FN,1,1,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK,ELIM)\n if (KODE == 1) then\n S1 = -ZETA1 + ZETA2\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2))\n endif\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n 20 continue\n NN = MIN(2,ND)\n DO 40 I = 1, NN\n FN = FNU + ND - I\n INIT = 0\n CALL DEWS17(Z,FN,1,0,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK,ELIM)\n if (KODE == 1) then\n S1 = -ZETA1 + ZETA2\n ELSE\n CFN = CMPLX(FN,0.0E0)\n YY = AIMAG(Z)\n S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + CMPLX(0.0E0,YY)\n endif\n! ------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) > ELIM) then\n goto 60\n ELSE\n if (I == 1) IFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ------------------------------------------------------\n! REFINE TEST AND SCALE\n! ------------------------------------------------------\n APHI = ABS(PHI)\n RS1 = RS1 + LOG(APHI)\n if (ABS(RS1) > ELIM) then\n goto 60\n ELSE\n if (I == 1) IFLAG = 1\n if (RS1 >= 0.0E0) then\n if (I == 1) IFLAG = 3\n endif\n endif\n endif\n! ---------------------------------------------------------\n! SCALE S1 IF CABS(S1) < ASCLE\n! ---------------------------------------------------------\n S2 = PHI*SUM\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(IFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (IFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) goto 60\n endif\n M = ND - I + 1\n CY(I) = S2\n Y(M) = S2*CSR(IFLAG)\n endif\n 40 continue\n goto 80\n! ---------------------------------------------------------------\n! SET UNDERFLOW AND UPDATE PARAMETERS\n! ---------------------------------------------------------------\n 60 continue\n if (RS1 > 0.0E0) then\n goto 160\n ELSE\n Y(ND) = CZERO\n NZ = NZ + 1\n ND = ND - 1\n if (ND == 0) then\n return\n ELSE\n CALL DEVS17(Z,FNU,KODE,1,ND,Y,NUF,TOL,ELIM,ALIM)\n if (NUF < 0) then\n goto 160\n ELSE\n ND = ND - NUF\n NZ = NZ + NUF\n if (ND == 0) then\n return\n ELSE\n FN = FNU + ND - 1\n if (FN >= FNUL) then\n goto 20\n ELSE\n goto 120\n endif\n endif\n endif\n endif\n endif\n 80 if (ND > 2) then\n RZ = CMPLX(2.0E0,0.0E0)/Z\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n S1 = CY(1)\n S2 = CY(2)\n C1 = CSR(IFLAG)\n ASCLE = BRY(IFLAG)\n K = ND - 2\n FN = K\n DO 100 I = 3, ND\n C2 = S2\n S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2\n S1 = C2\n C2 = S2*C1\n Y(K) = C2\n K = K - 1\n FN = FN - 1.0E0\n if (IFLAG < 3) then\n C2R = REAL(C2)\n C2I = AIMAG(C2)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*C1\n S2 = C2\n S1 = S1*CSS(IFLAG)\n S2 = S2*CSS(IFLAG)\n C1 = CSR(IFLAG)\n endif\n endif\n 100 continue\n endif\n return\n 120 NLAST = ND\n return\n else if (RS1 <= 0.0E0) then\n NZ = N\n DO 140 I = 1, N\n Y(I) = CZERO\n 140 continue\n return\n endif\n 160 NZ = -1\n return\n END\n subroutine DEYS17(Z,FNU,KODE,N,Y,NZ,NUI,NLAST,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-768 (DEC 1989).\n!\n! Original name: CBUNI\n!\n! DEYS17 COMPUTES THE I BESSEL function FOR LARGE CABS(Z)>\n! FNUL AND FNU+N-1 < FNUL. THE ORDER IS INCREASED FROM\n! FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING\n! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z)\n! ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, TOL\n INTEGER KODE, N, NLAST, NUI, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX CSCL, CSCR, RZ, S1, S2, ST\n REAL ASCLE, AX, AY, DFNU, FNUI, GNU, STI, STM, STR, &\n XX, YY\n INTEGER I, IFLAG, IFORM, K, NL, NW\n! .. Local Arrays ..\n COMPLEX CY(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME\n EXTERNAL X02AME\n! .. External subroutines ..\n EXTERNAL DETS17, DEXS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, MAX, REAL\n! .. Executable Statements ..\n!\n NZ = 0\n XX = REAL(Z)\n YY = AIMAG(Z)\n AX = ABS(XX)*1.7321E0\n AY = ABS(YY)\n IFORM = 1\n if (AY > AX) IFORM = 2\n if (NUI == 0) then\n if (IFORM == 2) then\n! ------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU\n! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I\n! AND HPI=PI/2\n! ------------------------------------------------------------\n CALL DETS17(Z,FNU,KODE,N,Y,NW,NLAST,FNUL,TOL,ELIM,ALIM)\n ELSE\n! ------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN\n! -PI/3 <= ARG(Z) <= PI/3\n! ------------------------------------------------------------\n CALL DEXS17(Z,FNU,KODE,N,Y,NW,NLAST,FNUL,TOL,ELIM,ALIM)\n endif\n if (NW >= 0) then\n NZ = NW\n return\n endif\n ELSE\n FNUI = NUI\n DFNU = FNU + N - 1\n GNU = DFNU + FNUI\n if (IFORM == 2) then\n! ------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU\n! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I\n! AND HPI=PI/2\n! ------------------------------------------------------------\n CALL DETS17(Z,GNU,KODE,2,CY,NW,NLAST,FNUL,TOL,ELIM,ALIM)\n ELSE\n! ------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN\n! -PI/3 <= ARG(Z) <= PI/3\n! ------------------------------------------------------------\n CALL DEXS17(Z,GNU,KODE,2,CY,NW,NLAST,FNUL,TOL,ELIM,ALIM)\n endif\n if (NW >= 0) then\n if (NW /= 0) then\n NLAST = N\n ELSE\n AY = ABS(CY(1))\n! ---------------------------------------------------------\n! SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER\n! USED\n! ---------------------------------------------------------\n BRY(1) = (1.0E+3*X02AME())/TOL\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = BRY(2)\n IFLAG = 2\n ASCLE = BRY(2)\n AX = 1.0E0\n CSCL = CMPLX(AX,0.0E0)\n if (AY <= BRY(1)) then\n IFLAG = 1\n ASCLE = BRY(1)\n AX = 1.0E0/TOL\n CSCL = CMPLX(AX,0.0E0)\n else if (AY >= BRY(2)) then\n IFLAG = 3\n ASCLE = BRY(3)\n AX = TOL\n CSCL = CMPLX(AX,0.0E0)\n endif\n AY = 1.0E0/AX\n CSCR = CMPLX(AY,0.0E0)\n S1 = CY(2)*CSCL\n S2 = CY(1)*CSCL\n RZ = CMPLX(2.0E0,0.0E0)/Z\n DO 20 I = 1, NUI\n ST = S2\n S2 = CMPLX(DFNU+FNUI,0.0E0)*RZ*S2 + S1\n S1 = ST\n FNUI = FNUI - 1.0E0\n if (IFLAG < 3) then\n ST = S2*CSCR\n STR = REAL(ST)\n STI = AIMAG(ST)\n STR = ABS(STR)\n STI = ABS(STI)\n STM = MAX(STR,STI)\n if (STM > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*CSCR\n S2 = ST\n AX = AX*TOL\n AY = 1.0E0/AX\n CSCL = CMPLX(AX,0.0E0)\n CSCR = CMPLX(AY,0.0E0)\n S1 = S1*CSCL\n S2 = S2*CSCL\n endif\n endif\n 20 continue\n Y(N) = S2*CSCR\n if (N /= 1) then\n NL = N - 1\n FNUI = NL\n K = NL\n DO 40 I = 1, NL\n ST = S2\n S2 = CMPLX(FNU+FNUI,0.0E0)*RZ*S2 + S1\n S1 = ST\n ST = S2*CSCR\n Y(K) = ST\n FNUI = FNUI - 1.0E0\n K = K - 1\n if (IFLAG < 3) then\n STR = REAL(ST)\n STI = AIMAG(ST)\n STR = ABS(STR)\n STI = ABS(STI)\n STM = MAX(STR,STI)\n if (STM > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*CSCR\n S2 = ST\n AX = AX*TOL\n AY = 1.0E0/AX\n CSCL = CMPLX(AX,0.0E0)\n CSCR = CMPLX(AY,0.0E0)\n S1 = S1*CSCL\n S2 = S2*CSCL\n endif\n endif\n 40 continue\n endif\n endif\n return\n endif\n endif\n NZ = -1\n if (NW == (-2)) NZ = -2\n return\n END\n subroutine DEZS17(Z,FNU,KODE,N,CY,NZ,RL,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-769 (DEC 1989).\n!\n! Original name: CBINU\n!\n! DEZS17 COMPUTES THE I function IN THE RIGHT HALF Z PLANE\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, RL, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX CY(N)\n! .. Local Scalars ..\n COMPLEX CZERO\n REAL AZ, DFNU\n INTEGER I, INW, NLAST, NN, NUI, NW\n! .. Local Arrays ..\n COMPLEX CW(2)\n! .. External subroutines ..\n EXTERNAL DESS17, DEVS17, DEYS17, DGRS17, DGTS17, DGYS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, INT, MAX\n! .. Data statements ..\n DATA CZERO/(0.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n AZ = ABS(Z)\n NN = N\n DFNU = FNU + N - 1\n if (AZ > 2.0E0) then\n if (AZ*AZ*0.25E0 > DFNU+1.0E0) goto 20\n endif\n! ------------------------------------------------------------------\n! POWER SERIES\n! ------------------------------------------------------------------\n CALL DGRS17(Z,FNU,KODE,NN,CY,NW,TOL,ELIM,ALIM)\n INW = ABS(NW)\n NZ = NZ + INW\n NN = NN - INW\n if (NN == 0) then\n return\n else if (NW >= 0) then\n return\n ELSE\n DFNU = FNU + NN - 1\n endif\n 20 if (AZ >= RL) then\n if (DFNU > 1.0E0) then\n if (AZ+AZ < DFNU*DFNU) goto 40\n endif\n! ---------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR LARGE Z\n! ---------------------------------------------------------------\n CALL DGYS17(Z,FNU,KODE,NN,CY,NW,RL,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 120\n ELSE\n return\n endif\n else if (DFNU <= 1.0E0) then\n goto 100\n endif\n! ------------------------------------------------------------------\n! OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM\n! ------------------------------------------------------------------\n 40 CALL DEVS17(Z,FNU,KODE,1,NN,CY,NW,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 120\n ELSE\n NZ = NZ + NW\n NN = NN - NW\n if (NN == 0) then\n return\n ELSE\n DFNU = FNU + NN - 1\n if (DFNU <= FNUL) then\n if (AZ <= FNUL) goto 60\n endif\n! ------------------------------------------------------------\n! INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD\n! ------------------------------------------------------------\n NUI = INT(FNUL-DFNU) + 1\n NUI = MAX(NUI,0)\n CALL DEYS17(Z,FNU,KODE,NN,CY,NW,NUI,NLAST,FNUL,TOL,ELIM, &\n ALIM)\n if (NW < 0) then\n goto 120\n ELSE\n NZ = NZ + NW\n if (NLAST == 0) then\n return\n ELSE\n NN = NLAST\n endif\n endif\n 60 if (AZ > RL) then\n! ---------------------------------------------------------\n! MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN\n! ---------------------------------------------------------\n! ---------------------------------------------------------\n! OVERFLOW TEST ON K functionS USED IN WRONSKIAN\n! ---------------------------------------------------------\n CALL DEVS17(Z,FNU,KODE,2,2,CW,NW,TOL,ELIM,ALIM)\n if (NW < 0) then\n NZ = NN\n DO 80 I = 1, NN\n CY(I) = CZERO\n 80 continue\n return\n else if (NW > 0) then\n goto 120\n ELSE\n CALL DESS17(Z,FNU,KODE,NN,CY,NW,CW,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 120\n ELSE\n return\n endif\n endif\n endif\n endif\n endif\n! ------------------------------------------------------------------\n! MILLER ALGORITHM NORMALIZED BY THE SERIES\n! ------------------------------------------------------------------\n 100 CALL DGTS17(Z,FNU,KODE,NN,CY,NW,TOL)\n if (NW >= 0) return\n 120 NZ = -1\n if (NW == (-2)) NZ = -2\n if (NW == (-3)) NZ = -3\n return\n END\n subroutine DGRS17(Z,FNU,KODE,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-771 (DEC 1989).\n!\n! Original name: CSERI\n!\n! DGRS17 COMPUTES THE I BESSEL function FOR REAL(Z) >= 0.0 BY\n! MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE\n! REGION CABS(Z) <= 2*SQRT(FNU+1). NZ=0 IS A NORMAL return.\n! NZ>0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO\n! DUE TO UNDERFLOW. NZ < 0 MEANS UNDERFLOW OCCURRED, BUT THE\n! CONDITION CABS(Z) <= 2*SQRT(FNU+1) WAS VIOLATED AND THE\n! COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ).\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX AK1, CK, COEF, CONE, CRSC, CZ, CZERO, HZ, RZ, &\n S1, S2\n REAL AA, ACZ, AK, ARM, ASCLE, ATOL, AZ, DFNU, FNUP, &\n RAK1, RS, RTR1, S, SS, X\n INTEGER I, IB, IDUM, IFLAG, IL, K, L, M, NN, NW\n! .. Local Arrays ..\n COMPLEX W(2)\n! .. External functions ..\n REAL S14ABE, X02AME\n EXTERNAL S14ABE, X02AME\n! .. External subroutines ..\n EXTERNAL DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, REAL, &\n SIN, SQRT\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n AZ = ABS(Z)\n if (AZ /= 0.0E0) then\n X = REAL(Z)\n ARM = 1.0E+3*X02AME()\n RTR1 = SQRT(ARM)\n CRSC = CMPLX(1.0E0,0.0E0)\n IFLAG = 0\n if (AZ < ARM) then\n NZ = N\n if (FNU == 0.0E0) NZ = NZ - 1\n ELSE\n HZ = Z*CMPLX(0.5E0,0.0E0)\n CZ = CZERO\n if (AZ > RTR1) CZ = HZ*HZ\n ACZ = ABS(CZ)\n NN = N\n CK = LOG(HZ)\n 20 continue\n DFNU = FNU + NN - 1\n FNUP = DFNU + 1.0E0\n! ------------------------------------------------------------\n! UNDERFLOW TEST\n! ------------------------------------------------------------\n AK1 = CK*CMPLX(DFNU,0.0E0)\n IDUM = 0\n! S14ABE assumed not to fail, therefore IDUM set to zero.\n AK = S14ABE(FNUP,IDUM)\n AK1 = AK1 - CMPLX(AK,0.0E0)\n if (KODE == 2) AK1 = AK1 - CMPLX(X,0.0E0)\n RAK1 = REAL(AK1)\n if (RAK1 > (-ELIM)) then\n if (RAK1 <= (-ALIM)) then\n IFLAG = 1\n SS = 1.0E0/TOL\n CRSC = CMPLX(TOL,0.0E0)\n ASCLE = ARM*SS\n endif\n AK = AIMAG(AK1)\n AA = EXP(RAK1)\n if (IFLAG == 1) AA = AA*SS\n COEF = CMPLX(AA,0.0E0)*CMPLX(COS(AK),SIN(AK))\n ATOL = TOL*ACZ/FNUP\n IL = MIN(2,NN)\n DO 60 I = 1, IL\n DFNU = FNU + NN - I\n FNUP = DFNU + 1.0E0\n S1 = CONE\n if (ACZ >= TOL*FNUP) then\n AK1 = CONE\n AK = FNUP + 2.0E0\n S = FNUP\n AA = 2.0E0\n 40 continue\n RS = 1.0E0/S\n AK1 = AK1*CZ*CMPLX(RS,0.0E0)\n S1 = S1 + AK1\n S = S + AK\n AK = AK + 2.0E0\n AA = AA*ACZ*RS\n if (AA > ATOL) goto 40\n endif\n M = NN - I + 1\n S2 = S1*COEF\n W(I) = S2\n if (IFLAG /= 0) then\n CALL DGVS17(S2,NW,ASCLE,TOL)\n if (NW /= 0) goto 80\n endif\n Y(M) = S2*CRSC\n if (I /= IL) COEF = COEF*CMPLX(DFNU,0.0E0)/HZ\n 60 continue\n goto 100\n endif\n 80 NZ = NZ + 1\n Y(NN) = CZERO\n if (ACZ > DFNU) then\n goto 180\n ELSE\n NN = NN - 1\n if (NN == 0) then\n return\n ELSE\n goto 20\n endif\n endif\n 100 if (NN > 2) then\n K = NN - 2\n AK = K\n RZ = (CONE+CONE)/Z\n if (IFLAG == 1) then\n! ------------------------------------------------------\n! RECUR BACKWARD WITH SCALED VALUES\n! ------------------------------------------------------\n! ------------------------------------------------------\n! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE\n! THE UNDERFLOW LIMIT = ASCLE = X02AME()*CSCL*1.0E+3\n! ------------------------------------------------------\n S1 = W(1)\n S2 = W(2)\n DO 120 L = 3, NN\n CK = S2\n S2 = S1 + CMPLX(AK+FNU,0.0E0)*RZ*S2\n S1 = CK\n CK = S2*CRSC\n Y(K) = CK\n AK = AK - 1.0E0\n K = K - 1\n if (ABS(CK) > ASCLE) goto 140\n 120 continue\n return\n 140 IB = L + 1\n if (IB > NN) return\n ELSE\n IB = 3\n endif\n DO 160 I = IB, NN\n Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2)\n AK = AK - 1.0E0\n K = K - 1\n 160 continue\n endif\n return\n! ------------------------------------------------------------\n! return WITH NZ < 0 IF CABS(Z*Z/4)>FNU+N-NZ-1 COMPLETE\n! THE CALCULATION IN DEZS17 WITH N=N-IABS(NZ)\n! ------------------------------------------------------------\n 180 continue\n NZ = -NZ\n return\n endif\n endif\n Y(1) = CZERO\n if (FNU == 0.0E0) Y(1) = CONE\n if (N /= 1) then\n DO 200 I = 2, N\n Y(I) = CZERO\n 200 continue\n endif\n return\n END\n subroutine DGSS17(ZR,S1,S2,NZ,ASCLE,ALIM,IUF)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-772 (DEC 1989).\n!\n! Original name: CS1S2\n!\n! DGSS17 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE\n! ADDITION OF THE I AND K functionS IN THE ANALYTIC CON-\n! TINUATION FORMULA WHERE S1=K function AND S2=I function.\n! ON KODE=1 THE I AND K functionS ARE DIFFERENT ORDERS OF\n! MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER\n! OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE\n! PRECISION ABOVE THE UNDERFLOW LIMIT.\n!\n! .. Scalar Arguments ..\n COMPLEX S1, S2, ZR\n REAL ALIM, ASCLE\n INTEGER IUF, NZ\n! .. Local Scalars ..\n COMPLEX C1, CZERO, S1D\n REAL AA, ALN, AS1, AS2, XX\n INTEGER IF1\n! .. External functions ..\n COMPLEX S01EAE\n EXTERNAL S01EAE\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, LOG, MAX, REAL\n! .. Data statements ..\n DATA CZERO/(0.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n AS1 = ABS(S1)\n AS2 = ABS(S2)\n AA = REAL(S1)\n ALN = AIMAG(S1)\n if (AA /= 0.0E0 .or. ALN /= 0.0E0) then\n if (AS1 /= 0.0E0) then\n XX = REAL(ZR)\n ALN = -XX - XX + LOG(AS1)\n S1D = S1\n S1 = CZERO\n AS1 = 0.0E0\n if (ALN >= (-ALIM)) then\n C1 = LOG(S1D) - ZR - ZR\n! S1 = EXP(C1)\n IF1 = 1\n S1 = S01EAE(C1,IF1)\n AS1 = ABS(S1)\n IUF = IUF + 1\n endif\n endif\n endif\n AA = MAX(AS1,AS2)\n if (AA <= ASCLE) then\n S1 = CZERO\n S2 = CZERO\n NZ = 1\n IUF = 0\n endif\n return\n END\n subroutine DGTS17(Z,FNU,KODE,N,Y,NZ,TOL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-773 (DEC 1989).\n! Mark 17 REVISED. IER-1703 (JUN 1995).\n!\n! Original name: CMLRI\n!\n! DGTS17 COMPUTES THE I BESSEL function FOR RE(Z) >= 0.0 BY THE\n! MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES.\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL FNU, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX CK, CNORM, CONE, CTWO, CZERO, P1, P2, PT, RZ, &\n SUM\n REAL ACK, AK, AP, AT, AZ, BK, FKAP, FKK, FLAM, FNF, &\n RHO, RHO2, SCLE, TFNF, TST, X\n INTEGER I, IAZ, IDUM, IFL, IFNU, INU, ITIME, K, KK, KM, &\n M\n! .. External functions ..\n COMPLEX S01EAE\n REAL S14ABE, X02ANE\n EXTERNAL S14ABE, S01EAE, X02ANE\n! .. Intrinsic functions ..\n INTRINSIC ABS, CMPLX, CONJG, EXP, INT, LOG, MAX, MIN, &\n REAL, SQRT\n! .. Data statements ..\n DATA CZERO, CONE, CTWO/(0.0E0,0.0E0), (1.0E0,0.0E0), &\n (2.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n SCLE = (1.0E+3*X02ANE())/TOL\n NZ = 0\n AZ = ABS(Z)\n X = REAL(Z)\n IAZ = INT(AZ)\n IFNU = INT(FNU)\n INU = IFNU + N - 1\n AT = IAZ + 1.0E0\n CK = CMPLX(AT,0.0E0)/Z\n RZ = CTWO/Z\n P1 = CZERO\n P2 = CONE\n ACK = (AT+1.0E0)/AZ\n RHO = ACK + SQRT(ACK*ACK-1.0E0)\n RHO2 = RHO*RHO\n TST = (RHO2+RHO2)/((RHO2-1.0E0)*(RHO-1.0E0))\n TST = TST/TOL\n! ------------------------------------------------------------------\n! COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES\n! ------------------------------------------------------------------\n AK = AT\n DO 20 I = 1, 80\n PT = P2\n P2 = P1 - CK*P2\n P1 = PT\n CK = CK + RZ\n AP = ABS(P2)\n if (AP > TST*AK*AK) then\n goto 40\n ELSE\n AK = AK + 1.0E0\n endif\n 20 continue\n goto 180\n 40 I = I + 1\n K = 0\n if (INU >= IAZ) then\n! ---------------------------------------------------------------\n! COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS\n! ---------------------------------------------------------------\n P1 = CZERO\n P2 = CONE\n AT = INU + 1.0E0\n CK = CMPLX(AT,0.0E0)/Z\n ACK = AT/AZ\n TST = SQRT(ACK/TOL)\n ITIME = 1\n DO 60 K = 1, 80\n PT = P2\n P2 = P1 - CK*P2\n P1 = PT\n CK = CK + RZ\n AP = ABS(P2)\n if (AP >= TST) then\n if (ITIME == 2) then\n goto 80\n ELSE\n ACK = ABS(CK)\n FLAM = ACK + SQRT(ACK*ACK-1.0E0)\n FKAP = AP/ABS(P1)\n RHO = MIN(FLAM,FKAP)\n TST = TST*SQRT(RHO/(RHO*RHO-1.0E0))\n ITIME = 2\n endif\n endif\n 60 continue\n goto 180\n endif\n! ------------------------------------------------------------------\n! BACKWARD RECURRENCE AND SUM NORMALIZING RELATION\n! ------------------------------------------------------------------\n 80 K = K + 1\n KK = MAX(I+IAZ,K+INU)\n FKK = KK\n P1 = CZERO\n! ------------------------------------------------------------------\n! SCALE P2 AND SUM BY SCLE\n! ------------------------------------------------------------------\n P2 = CMPLX(SCLE,0.0E0)\n FNF = FNU - IFNU\n TFNF = FNF + FNF\n IDUM = 0\n! S14ABE assumed not to fail, therefore IDUM set to zero.\n BK = S14ABE(FKK+TFNF+1.0E0,IDUM) - S14ABE(FKK+1.0E0,IDUM) - &\n S14ABE(TFNF+1.0E0,IDUM)\n BK = EXP(BK)\n SUM = CZERO\n KM = KK - INU\n DO 100 I = 1, KM\n PT = P2\n P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2\n P1 = PT\n AK = 1.0E0 - TFNF/(FKK+TFNF)\n ACK = BK*AK\n SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1\n BK = ACK\n FKK = FKK - 1.0E0\n 100 continue\n Y(N) = P2\n if (N /= 1) then\n DO 120 I = 2, N\n PT = P2\n P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2\n P1 = PT\n AK = 1.0E0 - TFNF/(FKK+TFNF)\n ACK = BK*AK\n SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1\n BK = ACK\n FKK = FKK - 1.0E0\n M = N - I + 1\n Y(M) = P2\n 120 continue\n endif\n if (IFNU > 0) then\n DO 140 I = 1, IFNU\n PT = P2\n P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2\n P1 = PT\n AK = 1.0E0 - TFNF/(FKK+TFNF)\n ACK = BK*AK\n SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1\n BK = ACK\n FKK = FKK - 1.0E0\n 140 continue\n endif\n PT = Z\n if (KODE == 2) PT = PT - CMPLX(X,0.0E0)\n P1 = -CMPLX(FNF,0.0E0)*LOG(RZ) + PT\n IDUM = 0\n! S14ABE assumed not to fail, therefore IDUM set to zero.\n AP = S14ABE(1.0E0+FNF,IDUM)\n PT = P1 - CMPLX(AP,0.0E0)\n! ------------------------------------------------------------------\n! THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW\n! IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES\n! ------------------------------------------------------------------\n P2 = P2 + SUM\n AP = ABS(P2)\n P1 = CMPLX(1.0E0/AP,0.0E0)\n! CK = EXP(PT)*P1\n IFL = 1\n CK = S01EAE(PT,IFL)*P1\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 200\n PT = CONJG(P2)*P1\n CNORM = CK*PT\n DO 160 I = 1, N\n Y(I) = Y(I)*CNORM\n 160 continue\n return\n 180 NZ = -2\n return\n 200 NZ = -3\n return\n END\n subroutine DGUS17(Z,CSH,CCH)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-774 (DEC 1989).\n!\n! Original name: CSHCH\n!\n! DGUS17 COMPUTES THE COMPLEX HYPERBOLIC functionS CSH=SINH(X+I*Y)\n! AND CCH=COSH(X+I*Y), WHERE I**2=-1.\n!\n! .. Scalar Arguments ..\n COMPLEX CCH, CSH, Z\n! .. Local Scalars ..\n REAL CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y\n! .. Intrinsic functions ..\n INTRINSIC AIMAG, CMPLX, COS, COSH, REAL, SIN, SINH\n! .. Executable Statements ..\n!\n X = REAL(Z)\n Y = AIMAG(Z)\n SH = SINH(X)\n CH = COSH(X)\n SN = SIN(Y)\n CN = COS(Y)\n CSHR = SH*CN\n CSHI = CH*SN\n CSH = CMPLX(CSHR,CSHI)\n CCHR = CH*CN\n CCHI = SH*SN\n CCH = CMPLX(CCHR,CCHI)\n return\n END\n subroutine DGVS17(Y,NZ,ASCLE,TOL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-775 (DEC 1989).\n!\n! Original name: CUCHK\n!\n! Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN\n! EXP(-ALIM)=ASCLE=1.0E+3*X02AME()/TOL. THE TEST IS MADE TO SEE\n! IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW\n! WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED\n! IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE\n! OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE\n! ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED.\n!\n! .. Scalar Arguments ..\n COMPLEX Y\n REAL ASCLE, TOL\n INTEGER NZ\n! .. Local Scalars ..\n REAL SS, ST, YI, YR\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, MAX, MIN, REAL\n! .. Executable Statements ..\n!\n NZ = 0\n YR = REAL(Y)\n YI = AIMAG(Y)\n YR = ABS(YR)\n YI = ABS(YI)\n ST = MIN(YR,YI)\n if (ST <= ASCLE) then\n SS = MAX(YR,YI)\n ST = ST/TOL\n if (SS < ST) NZ = 1\n endif\n return\n END\n subroutine DGWS17(ZR,FNU,N,Y,NZ,RZ,ASCLE,TOL,ELIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-776 (DEC 1989).\n!\n! Original name: CKSCL\n!\n! SET K functionS TO ZERO ON UNDERFLOW, continue RECURRENCE\n! ON SCALED functionS UNTIL TWO MEMBERS COME ON SCALE, THEN\n! return WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL.\n!\n! .. Scalar Arguments ..\n COMPLEX RZ, ZR\n REAL ASCLE, ELIM, FNU, TOL\n INTEGER N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX CELM, CK, CS, CZERO, S1, S2, ZD\n REAL AA, ACS, ALAS, AS, CSI, CSR, ELM, FN, HELIM, XX, &\n ZRI\n INTEGER I, IC, K, KK, NN, NW\n! .. Local Arrays ..\n COMPLEX CY(2)\n! .. External subroutines ..\n EXTERNAL DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, REAL, SIN\n! .. Data statements ..\n DATA CZERO/(0.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n IC = 0\n XX = REAL(ZR)\n NN = MIN(2,N)\n DO 20 I = 1, NN\n S1 = Y(I)\n CY(I) = S1\n AS = ABS(S1)\n ACS = -XX + LOG(AS)\n NZ = NZ + 1\n Y(I) = CZERO\n if (ACS >= (-ELIM)) then\n CS = -ZR + LOG(S1)\n CSR = REAL(CS)\n CSI = AIMAG(CS)\n AA = EXP(CSR)/TOL\n CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI))\n CALL DGVS17(CS,NW,ASCLE,TOL)\n if (NW == 0) then\n Y(I) = CS\n NZ = NZ - 1\n IC = I\n endif\n endif\n 20 continue\n if (N /= 1) then\n if (IC <= 1) then\n Y(1) = CZERO\n NZ = 2\n endif\n if (N /= 2) then\n if (NZ /= 0) then\n FN = FNU + 1.0E0\n CK = CMPLX(FN,0.0E0)*RZ\n S1 = CY(1)\n S2 = CY(2)\n HELIM = 0.5E0*ELIM\n ELM = EXP(-ELIM)\n CELM = CMPLX(ELM,0.0E0)\n ZRI = AIMAG(ZR)\n ZD = ZR\n!\n! FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE\n! RECURRENCE IF S2 GETS LARGER THAN EXP(ELIM/2)\n!\n DO 40 I = 3, N\n KK = I\n CS = S2\n S2 = CK*S2 + S1\n S1 = CS\n CK = CK + RZ\n AS = ABS(S2)\n ALAS = LOG(AS)\n ACS = -XX + ALAS\n NZ = NZ + 1\n Y(I) = CZERO\n if (ACS >= (-ELIM)) then\n CS = -ZD + LOG(S2)\n CSR = REAL(CS)\n CSI = AIMAG(CS)\n AA = EXP(CSR)/TOL\n CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI))\n CALL DGVS17(CS,NW,ASCLE,TOL)\n if (NW == 0) then\n Y(I) = CS\n NZ = NZ - 1\n if (IC == (KK-1)) then\n goto 60\n ELSE\n IC = KK\n goto 40\n endif\n endif\n endif\n if (ALAS >= HELIM) then\n XX = XX - ELIM\n S1 = S1*CELM\n S2 = S2*CELM\n ZD = CMPLX(XX,ZRI)\n endif\n 40 continue\n NZ = N\n if (IC == N) NZ = N - 1\n goto 80\n 60 NZ = KK - 2\n 80 DO 100 K = 1, NZ\n Y(K) = CZERO\n 100 continue\n endif\n endif\n endif\n return\n END\n subroutine DGXS17(Z,FNU,KODE,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-777 (DEC 1989).\n!\n! Original name: CBKNU\n!\n! DGXS17 COMPUTES THE K BESSEL function IN THE RIGHT HALF Z PLANE\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX CCH, CELM, CK, COEF, CONE, CRSC, CS, CSCL, CSH, &\n CTWO, CZ, CZERO, F, FMU, P, P1, P2, PT, Q, RZ, &\n S1, S2, SMU, ST, ZD\n REAL A1, A2, AA, AK, ALAS, AS, ASCLE, BB, BK, CAZ, &\n DNU, DNU2, ELM, ETEST, FC, FHS, FK, FKS, FPI, &\n G1, G2, HELIM, HPI, P2I, P2M, P2R, PI, R1, RK, &\n RTHPI, S, SPI, T1, T2, TM, TTH, XD, XX, YD, YY\n INTEGER I, IC, IDUM, IFL, IFLAG, INU, INUB, J, K, KFLAG, &\n KK, KMAX, KODED, NW\n! .. Local Arrays ..\n COMPLEX CSR(3), CSS(3), CY(2)\n REAL BRY(3), CC(8)\n! .. External functions ..\n COMPLEX S01EAE\n REAL S14ABE, X02AME, X02ALE\n INTEGER X02BHE, X02BJE\n EXTERNAL S14ABE, S01EAE, X02AME, X02ALE, X02BHE, X02BJE\n! .. External subroutines ..\n EXTERNAL DGUS17, DGVS17, DGWS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, ATAN, CMPLX, CONJG, COS, EXP, INT, &\n LOG, LOG10, MAX, MIN, REAL, SIN, SQRT\n! .. Data statements ..\n!\n!\n!\n DATA KMAX/30/\n DATA R1/2.0E0/\n DATA CZERO, CONE, CTWO/(0.0E0,0.0E0), (1.0E0,0.0E0), &\n (2.0E0,0.0E0)/\n DATA PI, RTHPI, SPI, HPI, FPI, &\n TTH/3.14159265358979324E0, &\n 1.25331413731550025E0, 1.90985931710274403E0, &\n 1.57079632679489662E0, 1.89769999331517738E0, &\n 6.66666666666666666E-01/\n DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), &\n CC(8)/5.77215664901532861E-01, &\n -4.20026350340952355E-02, &\n -4.21977345555443367E-02, &\n 7.21894324666309954E-03, &\n -2.15241674114950973E-04, &\n -2.01348547807882387E-05, &\n 1.13302723198169588E-06, &\n 6.11609510448141582E-09/\n! .. Executable Statements ..\n!\n XX = REAL(Z)\n YY = AIMAG(Z)\n CAZ = ABS(Z)\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n NZ = 0\n IFLAG = 0\n KODED = KODE\n RZ = CTWO/Z\n INU = INT(FNU+0.5E0)\n DNU = FNU - INU\n if (ABS(DNU) /= 0.5E0) then\n DNU2 = 0.0E0\n if (ABS(DNU) > TOL) DNU2 = DNU*DNU\n if (CAZ <= R1) then\n! ------------------------------------------------------------\n! SERIES FOR CABS(Z) <= R1\n! ------------------------------------------------------------\n FC = 1.0E0\n SMU = LOG(RZ)\n FMU = SMU*CMPLX(DNU,0.0E0)\n CALL DGUS17(FMU,CSH,CCH)\n if (DNU /= 0.0E0) then\n FC = DNU*PI\n FC = FC/SIN(FC)\n SMU = CSH*CMPLX(1.0E0/DNU,0.0E0)\n endif\n A2 = 1.0E0 + DNU\n! ------------------------------------------------------------\n! GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU),\n! T2=1/GAM(1+DNU)\n! ------------------------------------------------------------\n IDUM = 0\n! S14ABE assumed not to fail, therefore IDUM set to zero.\n T2 = EXP(-S14ABE(A2,IDUM))\n T1 = 1.0E0/(T2*FC)\n if (ABS(DNU) > 0.1E0) then\n G1 = (T1-T2)/(DNU+DNU)\n ELSE\n! ---------------------------------------------------------\n! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)\n! ---------------------------------------------------------\n AK = 1.0E0\n S = CC(1)\n DO 20 K = 2, 8\n AK = AK*DNU2\n TM = CC(K)*AK\n S = S + TM\n if (ABS(TM) < TOL) goto 40\n 20 continue\n 40 G1 = -S\n endif\n G2 = 0.5E0*(T1+T2)*FC\n G1 = G1*FC\n F = CMPLX(G1,0.0E0)*CCH + SMU*CMPLX(G2,0.0E0)\n IFL = 1\n PT = S01EAE(FMU,IFL)\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320\n P = CMPLX(0.5E0/T2,0.0E0)*PT\n Q = CMPLX(0.5E0/T1,0.0E0)/PT\n S1 = F\n S2 = P\n AK = 1.0E0\n A1 = 1.0E0\n CK = CONE\n BK = 1.0E0 - DNU2\n if (INU > 0 .or. N > 1) then\n! ---------------------------------------------------------\n! GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE\n! ---------------------------------------------------------\n if (CAZ >= TOL) then\n CZ = Z*Z*CMPLX(0.25E0,0.0E0)\n T1 = 0.25E0*CAZ*CAZ\n 60 continue\n F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0)\n P = P*CMPLX(1.0E0/(AK-DNU),0.0E0)\n Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0)\n RK = 1.0E0/AK\n CK = CK*CZ*CMPLX(RK,0.0E0)\n S1 = S1 + CK*F\n S2 = S2 + CK*(P-F*CMPLX(AK,0.0E0))\n A1 = A1*T1*RK\n BK = BK + AK + AK + 1.0E0\n AK = AK + 1.0E0\n if (A1 > TOL) goto 60\n endif\n KFLAG = 2\n BK = REAL(SMU)\n A1 = FNU + 1.0E0\n AK = A1*ABS(BK)\n if (AK > ALIM) KFLAG = 3\n P2 = S2*CSS(KFLAG)\n S2 = P2*RZ\n S1 = S1*CSS(KFLAG)\n if (KODED /= 1) then\n! F = EXP(Z)\n IFL = 1\n F = S01EAE(Z,IFL)\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320\n S1 = S1*F\n S2 = S2*F\n endif\n goto 160\n ELSE\n! ---------------------------------------------------------\n! GENERATE K(FNU,Z), 0.0D0 <= FNU < 0.5D0 AND N=1\n! ---------------------------------------------------------\n if (CAZ >= TOL) then\n CZ = Z*Z*CMPLX(0.25E0,0.0E0)\n T1 = 0.25E0*CAZ*CAZ\n 80 continue\n F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0)\n P = P*CMPLX(1.0E0/(AK-DNU),0.0E0)\n Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0)\n RK = 1.0E0/AK\n CK = CK*CZ*CMPLX(RK,0.0E0)\n S1 = S1 + CK*F\n A1 = A1*T1*RK\n BK = BK + AK + AK + 1.0E0\n AK = AK + 1.0E0\n if (A1 > TOL) goto 80\n endif\n Y(1) = S1\n! if (KODED /= 1) Y(1) = S1*EXP(Z)\n if (KODED /= 1) then\n IFL = 1\n Y(1) = S01EAE(Z,IFL)\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320\n Y(1) = S1*Y(1)\n endif\n return\n endif\n endif\n endif\n! ------------------------------------------------------------------\n! IFLAG=0 MEANS NO UNDERFLOW OCCURRED\n! IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH\n! KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD\n! RECURSION\n! ------------------------------------------------------------------\n COEF = CMPLX(RTHPI,0.0E0)/SQRT(Z)\n KFLAG = 2\n if (KODED /= 2) then\n if (XX > ALIM) then\n! ------------------------------------------------------------\n! SCALE BY EXP(Z), IFLAG = 1 CASES\n! ------------------------------------------------------------\n KODED = 2\n IFLAG = 1\n KFLAG = 2\n ELSE\n! BLANK LINE\n! A1 = EXP(-XX)*REAL(CSS(KFLAG))\n! PT = CMPLX(A1,0.0E0)*CMPLX(COS(YY),-SIN(YY))\n IFL = 1\n PT = S01EAE(CMPLX(-XX,-YY),IFL)\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320\n PT = PT*REAL(CSS(KFLAG))\n COEF = COEF*PT\n endif\n endif\n if (ABS(DNU) /= 0.5E0) then\n! ---------------------------------------------------------------\n! MILLER ALGORITHM FOR CABS(Z)>R1\n! ---------------------------------------------------------------\n AK = COS(PI*DNU)\n AK = ABS(AK)\n if (AK /= 0.0E0) then\n FHS = ABS(0.25E0-DNU2)\n if (FHS /= 0.0E0) then\n! ---------------------------------------------------------\n! COMPUTE R2=F(E). IF CABS(Z) >= R2, USE FORWARD RECURRENCE\n! TO DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT\n! LINE ON 12 <= E <= 60. E IS COMPUTED FROM\n! 2**(-E)=B**(1-X02BJE())=TOL WHERE B IS THE BASE OF THE\n! ARITHMETIC.\n! ---------------------------------------------------------\n T1 = (X02BJE()-1)*LOG10(REAL(X02BHE()))*3.321928094E0\n T1 = MAX(T1,12.0E0)\n T1 = MIN(T1,60.0E0)\n T2 = TTH*T1 - 6.0E0\n if (XX /= 0.0E0) then\n T1 = ATAN(YY/XX)\n T1 = ABS(T1)\n ELSE\n T1 = HPI\n endif\n if (T2 > CAZ) then\n! ------------------------------------------------------\n! COMPUTE BACKWARD INDEX K FOR CABS(Z) < R2\n! ------------------------------------------------------\n A2 = SQRT(CAZ)\n AK = FPI*AK/(TOL*SQRT(A2))\n AA = 3.0E0*T1/(1.0E0+CAZ)\n BB = 14.7E0*T1/(28.0E0+CAZ)\n AK = (LOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB)\n FK = 0.12125E0*AK*AK/CAZ + 1.5E0\n ELSE\n! ------------------------------------------------------\n! FORWARD RECURRENCE LOOP WHEN CABS(Z) >= R2\n! ------------------------------------------------------\n ETEST = AK/(PI*CAZ*TOL)\n FK = 1.0E0\n if (ETEST >= 1.0E0) then\n FKS = 2.0E0\n RK = CAZ + CAZ + 2.0E0\n A1 = 0.0E0\n A2 = 1.0E0\n DO 100 I = 1, KMAX\n AK = FHS/FKS\n BK = RK/(FK+1.0E0)\n TM = A2\n A2 = BK*A2 - AK*A1\n A1 = TM\n RK = RK + 2.0E0\n FKS = FKS + FK + FK + 2.0E0\n FHS = FHS + FK + FK\n FK = FK + 1.0E0\n TM = ABS(A2)*FK\n if (ETEST < TM) goto 120\n 100 continue\n NZ = -2\n return\n 120 FK = FK + SPI*T1*SQRT(T2/CAZ)\n FHS = ABS(0.25E0-DNU2)\n endif\n endif\n K = INT(FK)\n! ---------------------------------------------------------\n! BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM\n! ---------------------------------------------------------\n FK = K\n FKS = FK*FK\n P1 = CZERO\n P2 = CMPLX(TOL,0.0E0)\n CS = P2\n DO 140 I = 1, K\n A1 = FKS - FK\n A2 = (FKS+FK)/(A1+FHS)\n RK = 2.0E0/(FK+1.0E0)\n T1 = (FK+XX)*RK\n T2 = YY*RK\n PT = P2\n P2 = (P2*CMPLX(T1,T2)-P1)*CMPLX(A2,0.0E0)\n P1 = PT\n CS = CS + P2\n FKS = A1 - FK + 1.0E0\n FK = FK - 1.0E0\n 140 continue\n! ---------------------------------------------------------\n! COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR\n! BETTER SCALING\n! ---------------------------------------------------------\n TM = ABS(CS)\n PT = CMPLX(1.0E0/TM,0.0E0)\n S1 = PT*P2\n CS = CONJG(CS)*PT\n S1 = COEF*S1*CS\n if (INU > 0 .or. N > 1) then\n! ------------------------------------------------------\n! COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR\n! SCALING\n! ------------------------------------------------------\n TM = ABS(P2)\n PT = CMPLX(1.0E0/TM,0.0E0)\n P1 = PT*P1\n P2 = CONJG(P2)*PT\n PT = P1*P2\n S2 = S1*(CONE+(CMPLX(DNU+0.5E0,0.0E0)-PT)/Z)\n goto 160\n ELSE\n ZD = Z\n if (IFLAG == 1) then\n goto 240\n ELSE\n goto 260\n endif\n endif\n endif\n endif\n endif\n! ------------------------------------------------------------------\n! FNU=HALF ODD INTEGER CASE, DNU=-0.5\n! ------------------------------------------------------------------\n S1 = COEF\n S2 = COEF\n! ------------------------------------------------------------------\n! FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH\n! SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3\n! ------------------------------------------------------------------\n 160 continue\n CK = CMPLX(DNU+1.0E0,0.0E0)*RZ\n if (N == 1) INU = INU - 1\n if (INU > 0) then\n INUB = 1\n if (IFLAG == 1) then\n! ------------------------------------------------------------\n! IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON\n! UNDERFLOW\n! ------------------------------------------------------------\n HELIM = 0.5E0*ELIM\n ELM = EXP(-ELIM)\n CELM = CMPLX(ELM,0.0E0)\n ASCLE = BRY(1)\n ZD = Z\n XD = XX\n YD = YY\n IC = -1\n J = 2\n DO 180 I = 1, INU\n ST = S2\n S2 = CK*S2 + S1\n S1 = ST\n CK = CK + RZ\n AS = ABS(S2)\n ALAS = LOG(AS)\n P2R = -XD + ALAS\n if (P2R >= (-ELIM)) then\n P2 = -ZD + LOG(S2)\n P2R = REAL(P2)\n P2I = AIMAG(P2)\n P2M = EXP(P2R)/TOL\n P1 = CMPLX(P2M,0.0E0)*CMPLX(COS(P2I),SIN(P2I))\n CALL DGVS17(P1,NW,ASCLE,TOL)\n if (NW == 0) then\n J = 3 - J\n CY(J) = P1\n if (IC == (I-1)) then\n goto 200\n ELSE\n IC = I\n goto 180\n endif\n endif\n endif\n if (ALAS >= HELIM) then\n XD = XD - ELIM\n S1 = S1*CELM\n S2 = S2*CELM\n ZD = CMPLX(XD,YD)\n endif\n 180 continue\n if (N == 1) S1 = S2\n goto 240\n 200 KFLAG = 1\n INUB = I + 1\n S2 = CY(J)\n J = 3 - J\n S1 = CY(J)\n if (INUB > INU) then\n if (N == 1) S1 = S2\n goto 260\n endif\n endif\n P1 = CSR(KFLAG)\n ASCLE = BRY(KFLAG)\n DO 220 I = INUB, INU\n ST = S2\n S2 = CK*S2 + S1\n S1 = ST\n CK = CK + RZ\n if (KFLAG < 3) then\n P2 = S2*P1\n P2R = REAL(P2)\n P2I = AIMAG(P2)\n P2R = ABS(P2R)\n P2I = ABS(P2I)\n P2M = MAX(P2R,P2I)\n if (P2M > ASCLE) then\n KFLAG = KFLAG + 1\n ASCLE = BRY(KFLAG)\n S1 = S1*P1\n S2 = P2\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n P1 = CSR(KFLAG)\n endif\n endif\n 220 continue\n if (N == 1) S1 = S2\n goto 260\n ELSE\n if (N == 1) S1 = S2\n ZD = Z\n if (IFLAG /= 1) goto 260\n endif\n 240 Y(1) = S1\n if (N /= 1) Y(2) = S2\n ASCLE = BRY(1)\n CALL DGWS17(ZD,FNU,N,Y,NZ,RZ,ASCLE,TOL,ELIM)\n INU = N - NZ\n if (INU <= 0) then\n return\n ELSE\n KK = NZ + 1\n S1 = Y(KK)\n Y(KK) = S1*CSR(1)\n if (INU == 1) then\n return\n ELSE\n KK = NZ + 2\n S2 = Y(KK)\n Y(KK) = S2*CSR(1)\n if (INU == 2) then\n return\n ELSE\n T2 = FNU + KK - 1\n CK = CMPLX(T2,0.0E0)*RZ\n KFLAG = 1\n goto 280\n endif\n endif\n endif\n 260 Y(1) = S1*CSR(KFLAG)\n if (N == 1) then\n return\n ELSE\n Y(2) = S2*CSR(KFLAG)\n if (N == 2) then\n return\n ELSE\n KK = 2\n endif\n endif\n 280 KK = KK + 1\n if (KK <= N) then\n P1 = CSR(KFLAG)\n ASCLE = BRY(KFLAG)\n DO 300 I = KK, N\n P2 = S2\n S2 = CK*S2 + S1\n S1 = P2\n CK = CK + RZ\n P2 = S2*P1\n Y(I) = P2\n if (KFLAG < 3) then\n P2R = REAL(P2)\n P2I = AIMAG(P2)\n P2R = ABS(P2R)\n P2I = ABS(P2I)\n P2M = MAX(P2R,P2I)\n if (P2M > ASCLE) then\n KFLAG = KFLAG + 1\n ASCLE = BRY(KFLAG)\n S1 = S1*P1\n S2 = P2\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n P1 = CSR(KFLAG)\n endif\n endif\n 300 continue\n endif\n return\n 320 NZ = -3\n return\n END\n subroutine DGYS17(Z,FNU,KODE,N,Y,NZ,RL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-778 (DEC 1989).\n!\n! Original name: CASYI\n!\n! DGYS17 COMPUTES THE I BESSEL function FOR REAL(Z) >= 0.0 BY\n! MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE\n! REGION CABS(Z)>MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL return.\n! NZ < 0 INDICATES AN OVERFLOW ON KODE=1.\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, RL, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, &\n RZ, S2\n REAL AA, ACZ, AEZ, AK, ARG, ARM, ATOL, AZ, BB, BK, &\n DFNU, DNU2, FDN, PI, RTPI, RTR1, S, SGN, SQK, X, &\n YY\n INTEGER I, IB, IERR1, IL, INU, J, JL, K, KODED, M, NN\n! .. External functions ..\n COMPLEX S01EAE\n REAL X02AME\n EXTERNAL S01EAE, X02AME\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, MIN, MOD, &\n REAL, SIN, SQRT\n! .. Data statements ..\n DATA PI, RTPI/3.14159265358979324E0, &\n 0.159154943091895336E0/\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n AZ = ABS(Z)\n X = REAL(Z)\n ARM = 1.0E+3*X02AME()\n RTR1 = SQRT(ARM)\n IL = MIN(2,N)\n DFNU = FNU + N - IL\n! ------------------------------------------------------------------\n! OVERFLOW TEST\n! ------------------------------------------------------------------\n AK1 = CMPLX(RTPI,0.0E0)/Z\n AK1 = SQRT(AK1)\n CZ = Z\n if (KODE == 2) CZ = Z - CMPLX(X,0.0E0)\n ACZ = REAL(CZ)\n if (ABS(ACZ) > ELIM) then\n NZ = -1\n ELSE\n DNU2 = DFNU + DFNU\n KODED = 1\n if ((ABS(ACZ) <= ALIM) .or. (N <= 2)) then\n KODED = 0\n IERR1 = 1\n AK1 = AK1*S01EAE(CZ,IERR1)\n! Allow reduced precision from S01EAE, but disallow other errors.\n if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) goto 140\n endif\n FDN = 0.0E0\n if (DNU2 > RTR1) FDN = DNU2*DNU2\n EZ = Z*CMPLX(8.0E0,0.0E0)\n! ---------------------------------------------------------------\n! WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO\n! THE FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF\n! THE EXPANSION FOR THE IMAGINARY PART.\n! ---------------------------------------------------------------\n AEZ = 8.0E0*AZ\n S = TOL/AEZ\n JL = INT(RL+RL) + 2\n YY = AIMAG(Z)\n P1 = CZERO\n if (YY /= 0.0E0) then\n! ------------------------------------------------------------\n! CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF\n! SIGNIFICANCE WHEN FNU OR N IS LARGE\n! ------------------------------------------------------------\n INU = INT(FNU)\n ARG = (FNU-INU)*PI\n INU = INU + N - IL\n AK = -SIN(ARG)\n BK = COS(ARG)\n if (YY < 0.0E0) BK = -BK\n P1 = CMPLX(AK,BK)\n if (MOD(INU,2) == 1) P1 = -P1\n endif\n DO 60 K = 1, IL\n SQK = FDN - 1.0E0\n ATOL = S*ABS(SQK)\n SGN = 1.0E0\n CS1 = CONE\n CS2 = CONE\n CK = CONE\n AK = 0.0E0\n AA = 1.0E0\n BB = AEZ\n DK = EZ\n DO 20 J = 1, JL\n CK = CK*CMPLX(SQK,0.0E0)/DK\n CS2 = CS2 + CK\n SGN = -SGN\n CS1 = CS1 + CK*CMPLX(SGN,0.0E0)\n DK = DK + EZ\n AA = AA*ABS(SQK)/BB\n BB = BB + AEZ\n AK = AK + 8.0E0\n SQK = SQK - AK\n if (AA <= ATOL) goto 40\n 20 continue\n goto 120\n 40 S2 = CS1\n if (X+X < ELIM) then\n IERR1 = 1\n S2 = S2 + P1*CS2*S01EAE(-Z-Z,IERR1)\n if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) &\n goto 140\n endif\n FDN = FDN + 8.0E0*DFNU + 4.0E0\n P1 = -P1\n M = N - IL + K\n Y(M) = S2*AK1\n 60 continue\n if (N > 2) then\n NN = N\n K = NN - 2\n AK = K\n RZ = (CONE+CONE)/Z\n IB = 3\n DO 80 I = IB, NN\n Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2)\n AK = AK - 1.0E0\n K = K - 1\n 80 continue\n if (KODED /= 0) then\n IERR1 = 1\n CK = S01EAE(CZ,IERR1)\n if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) &\n goto 140\n DO 100 I = 1, NN\n Y(I) = Y(I)*CK\n 100 continue\n endif\n endif\n return\n 120 NZ = -2\n return\n 140 NZ = -3\n endif\n return\n END\n subroutine DGZS17(Z,FNU,KODE,MR,N,Y,NZ,RL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-779 (DEC 1989).\n!\n! Original name: CACAI\n!\n! DGZS17 APPLIES THE ANALYTIC CONTINUATION FORMULA\n!\n! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)\n! MP=PI*MR*CMPLX(0.0,1.0)\n!\n! TO continue THE K function FROM THE RIGHT HALF TO THE LEFT\n! HALF Z PLANE FOR USE WITH S17DGE WHERE FNU=1/3 OR 2/3 AND N=1.\n! DGZS17 IS THE SAME AS DLZS17 WITH THE PARTS FOR LARGER ORDERS AND\n! RECURRENCE REMOVED. A RECURSIVE CALL TO DLZS17 CAN RESULT IF S17DL\n! IS CALLED FROM S17DGE.\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, RL, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CSGN, CSPN, ZN\n REAL ARG, ASCLE, AZ, CPN, DFNU, FMR, PI, SGN, SPN, YY\n INTEGER INU, IUF, NN, NW\n! .. Local Arrays ..\n COMPLEX CY(2)\n! .. External functions ..\n REAL X02AME\n EXTERNAL X02AME\n! .. External subroutines ..\n EXTERNAL DGRS17, DGSS17, DGTS17, DGXS17, DGYS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, INT, MOD, SIGN, SIN\n! .. Data statements ..\n DATA PI/3.14159265358979324E0/\n! .. Executable Statements ..\n!\n NZ = 0\n ZN = -Z\n AZ = ABS(Z)\n NN = N\n DFNU = FNU + N - 1\n if (AZ > 2.0E0) then\n if (AZ*AZ*0.25E0 > DFNU+1.0E0) then\n if (AZ < RL) then\n! ---------------------------------------------------------\n! MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I\n! function\n! ---------------------------------------------------------\n CALL DGTS17(ZN,FNU,KODE,NN,Y,NW,TOL)\n if (NW < 0) then\n goto 40\n ELSE\n goto 20\n endif\n ELSE\n! ---------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I function\n! ---------------------------------------------------------\n CALL DGYS17(ZN,FNU,KODE,NN,Y,NW,RL,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 40\n ELSE\n goto 20\n endif\n endif\n endif\n endif\n! ------------------------------------------------------------------\n! POWER SERIES FOR THE I function\n! ------------------------------------------------------------------\n CALL DGRS17(ZN,FNU,KODE,NN,Y,NW,TOL,ELIM,ALIM)\n! ------------------------------------------------------------------\n! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K function\n! ------------------------------------------------------------------\n 20 CALL DGXS17(ZN,FNU,KODE,1,CY,NW,TOL,ELIM,ALIM)\n if (NW == 0) then\n FMR = MR\n SGN = -SIGN(PI,FMR)\n CSGN = CMPLX(0.0E0,SGN)\n if (KODE /= 1) then\n YY = -AIMAG(ZN)\n CPN = COS(YY)\n SPN = SIN(YY)\n CSGN = CSGN*CMPLX(CPN,SPN)\n endif\n! ---------------------------------------------------------------\n! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE\n! WHEN FNU IS LARGE\n! ---------------------------------------------------------------\n INU = INT(FNU)\n ARG = (FNU-INU)*SGN\n CPN = COS(ARG)\n SPN = SIN(ARG)\n CSPN = CMPLX(CPN,SPN)\n if (MOD(INU,2) == 1) CSPN = -CSPN\n C1 = CY(1)\n C2 = Y(1)\n if (KODE /= 1) then\n IUF = 0\n ASCLE = (1.0E+3*X02AME())/TOL\n CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(1) = CSPN*C1 + CSGN*C2\n return\n endif\n 40 NZ = -1\n if (NW == (-2)) NZ = -2\n if (NW == (-3)) NZ = -3\n return\n END\n subroutine DLYS17(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-782 (DEC 1989).\n!\n! Original name: CBUNK\n!\n! DLYS17 COMPUTES THE K BESSEL function FOR FNU>FNUL.\n! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z)\n! IN DCZS18 AND THE EXPANSION FOR H(2,FNU,Z) IN DCYS18\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n REAL AX, AY, XX, YY\n! .. External subroutines ..\n EXTERNAL DCYS18, DCZS18\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, REAL\n! .. Executable Statements ..\n!\n NZ = 0\n XX = REAL(Z)\n YY = AIMAG(Z)\n AX = ABS(XX)*1.7321E0\n AY = ABS(YY)\n if (AY > AX) then\n! ---------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU\n! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I\n! AND HPI=PI/2\n! ---------------------------------------------------------------\n CALL DCYS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n ELSE\n! ---------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN\n! -PI/3 <= ARG(Z) <= PI/3\n! ---------------------------------------------------------------\n CALL DCZS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n endif\n return\n END\n subroutine DLZS17(Z,FNU,KODE,MR,N,Y,NZ,RL,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-783 (DEC 1989).\n!\n! Original name: CACON\n!\n! DLZS17 APPLIES THE ANALYTIC CONTINUATION FORMULA\n!\n! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)\n! MP=PI*MR*CMPLX(0.0,1.0)\n!\n! TO continue THE K function FROM THE RIGHT HALF TO THE LEFT\n! HALF Z PLANE\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, RL, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, &\n RZ, S1, S2, SC1, SC2, ST, ZN\n REAL ARG, AS2, ASCLE, BSCLE, C1I, C1M, C1R, CPN, FMR, &\n PI, SGN, SPN, YY\n INTEGER I, INU, IUF, KFLAG, NN, NW\n! .. Local Arrays ..\n COMPLEX CSR(3), CSS(3), CY(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEZS17, DGSS17, DGXS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, INT, MAX, MIN, MOD, &\n REAL, SIGN, SIN\n! .. Data statements ..\n DATA PI/3.14159265358979324E0/\n DATA CONE/(1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n ZN = -Z\n NN = N\n CALL DEZS17(ZN,FNU,KODE,NN,Y,NW,RL,FNUL,TOL,ELIM,ALIM)\n if (NW >= 0) then\n! ---------------------------------------------------------------\n! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K function\n! ---------------------------------------------------------------\n NN = MIN(2,N)\n CALL DGXS17(ZN,FNU,KODE,NN,CY,NW,TOL,ELIM,ALIM)\n if (NW == 0) then\n S1 = CY(1)\n FMR = MR\n SGN = -SIGN(PI,FMR)\n CSGN = CMPLX(0.0E0,SGN)\n if (KODE /= 1) then\n YY = -AIMAG(ZN)\n CPN = COS(YY)\n SPN = SIN(YY)\n CSGN = CSGN*CMPLX(CPN,SPN)\n endif\n! ------------------------------------------------------------\n! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF\n! SIGNIFICANCE WHEN FNU IS LARGE\n! ------------------------------------------------------------\n INU = INT(FNU)\n ARG = (FNU-INU)*SGN\n CPN = COS(ARG)\n SPN = SIN(ARG)\n CSPN = CMPLX(CPN,SPN)\n if (MOD(INU,2) == 1) CSPN = -CSPN\n IUF = 0\n C1 = S1\n C2 = Y(1)\n ASCLE = (1.0E+3*X02AME())/TOL\n if (KODE /= 1) then\n CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF)\n NZ = NZ + NW\n SC1 = C1\n endif\n Y(1) = CSPN*C1 + CSGN*C2\n if (N /= 1) then\n CSPN = -CSPN\n S2 = CY(2)\n C1 = S2\n C2 = Y(2)\n if (KODE /= 1) then\n CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF)\n NZ = NZ + NW\n SC2 = C1\n endif\n Y(2) = CSPN*C1 + CSGN*C2\n if (N /= 2) then\n CSPN = -CSPN\n RZ = CMPLX(2.0E0,0.0E0)/ZN\n CK = CMPLX(FNU+1.0E0,0.0E0)*RZ\n! ------------------------------------------------------\n! SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON\n! K functionS\n! ------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CSCR = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CSCR\n CSR(1) = CSCR\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = ASCLE\n BRY(2) = 1.0E0/ASCLE\n BRY(3) = X02ALE()\n AS2 = ABS(S2)\n KFLAG = 2\n if (AS2 <= BRY(1)) then\n KFLAG = 1\n else if (AS2 >= BRY(2)) then\n KFLAG = 3\n endif\n BSCLE = BRY(KFLAG)\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n CS = CSR(KFLAG)\n DO 20 I = 3, N\n ST = S2\n S2 = CK*S2 + S1\n S1 = ST\n C1 = S2*CS\n ST = C1\n C2 = Y(I)\n if (KODE /= 1) then\n if (IUF >= 0) then\n CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF)\n NZ = NZ + NW\n SC1 = SC2\n SC2 = C1\n if (IUF == 3) then\n IUF = -4\n S1 = SC1*CSS(KFLAG)\n S2 = SC2*CSS(KFLAG)\n ST = SC2\n endif\n endif\n endif\n Y(I) = CSPN*C1 + CSGN*C2\n CK = CK + RZ\n CSPN = -CSPN\n if (KFLAG < 3) then\n C1R = REAL(C1)\n C1I = AIMAG(C1)\n C1R = ABS(C1R)\n C1I = ABS(C1I)\n C1M = MAX(C1R,C1I)\n if (C1M > BSCLE) then\n KFLAG = KFLAG + 1\n BSCLE = BRY(KFLAG)\n S1 = S1*CS\n S2 = ST\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n CS = CSR(KFLAG)\n endif\n endif\n 20 continue\n endif\n endif\n return\n endif\n endif\n NZ = -1\n if (NW == (-2)) NZ = -2\n if (NW == (-3)) NZ = -3\n return\n END\n INTEGER function P01ABE(IFAIL,IERROR,SRNAME,NREC,REC)\n! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986.\n! MARK 13 REVISED. IER-621 (APR 1988).\n! MARK 13B REVISED. IER-668 (AUG 1988).\n!\n! P01ABE is the error-handling routine for the NAG Library.\n!\n! P01ABE either returns the value of IERROR through the routine\n! name (soft failure), or terminates execution of the program\n! (hard failure). Diagnostic messages may be output.\n!\n! If IERROR = 0 (successful exit from the calling routine),\n! the value 0 is returned through the routine name, and no\n! message is output\n!\n! If IERROR is non-zero (abnormal exit from the calling routine),\n! the action taken depends on the value of IFAIL.\n!\n! IFAIL = 1: soft failure, silent exit (i.e. no messages are\n! output)\n! IFAIL = -1: soft failure, noisy exit (i.e. messages are output)\n! IFAIL =-13: soft failure, noisy exit but standard messages from\n! P01ABE are suppressed\n! IFAIL = 0: hard failure, noisy exit\n!\n! For compatibility with certain routines included before Mark 12\n! P01ABE also allows an alternative specification of IFAIL in which\n! it is regarded as a decimal integer with least significant digits\n! cba. Then\n!\n! a = 0: hard failure a = 1: soft failure\n! b = 0: silent exit b = 1: noisy exit\n!\n! except that hard failure now always implies a noisy exit.\n!\n! S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office.\n!\n! .. Scalar Arguments ..\n INTEGER IERROR, IFAIL, NREC\n CHARACTER*(*) SRNAME\n! .. Array Arguments ..\n CHARACTER*(*) REC(*)\n! .. Local Scalars ..\n INTEGER I, NERR\n CHARACTER*72 MESS\n! .. External subroutines ..\n EXTERNAL ABZP01, X04AAE, X04BAE\n! .. Intrinsic functions ..\n INTRINSIC ABS, MOD\n! .. Executable Statements ..\n if (IERROR /= 0) then\n! Abnormal exit from calling routine\n if (IFAIL == -1 .or. IFAIL == 0 .or. IFAIL == -13 .or. &\n (IFAIL > 0 .and. MOD(IFAIL/10,10) /= 0)) then\n! Noisy exit\n CALL X04AAE(0,NERR)\n DO 20 I = 1, NREC\n CALL X04BAE(NERR,REC(I))\n 20 continue\n if (IFAIL /= -13) then\n WRITE (MESS,FMT=99999) SRNAME, IERROR\n CALL X04BAE(NERR,MESS)\n if (ABS(MOD(IFAIL,10)) /= 1) then\n! Hard failure\n CALL X04BAE(NERR, &\n ' ** NAG hard failure - execution terminated' &\n )\n CALL ABZP01\n ELSE\n! Soft failure\n CALL X04BAE(NERR, &\n ' ** NAG soft failure - control returned')\n endif\n endif\n endif\n endif\n P01ABE = IERROR\n return\n!\n 99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', &\n ' =',I6)\n END\n COMPLEX function S01EAE(Z,IFAIL)\n! MARK 14 RELEASE. NAG COPYRIGHT 1989.\n! returns exp(Z) for complex Z.\n! .. Parameters ..\n REAL ONE, ZERO\n PARAMETER (ONE=1.0E0,ZERO=0.0E0)\n CHARACTER*6 SRNAME\n PARAMETER (SRNAME='S01EAE')\n! .. Scalar Arguments ..\n COMPLEX Z\n INTEGER IFAIL\n! .. Local Scalars ..\n REAL COSY, EXPX, LNSAFE, RECEPS, RESI, RESR, &\n RTSAFS, SAFE, SAFSIN, SINY, X, XPLNCY, &\n XPLNSY, Y\n INTEGER IER, NREC\n LOGICAL FIRST\n! .. Local Arrays ..\n CHARACTER*80 REC(2)\n! .. External functions ..\n REAL X02AHE, X02AJE, X02AME\n INTEGER P01ABE\n EXTERNAL X02AHE, X02AJE, X02AME, P01ABE\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, &\n REAL, SIGN, SIN, SQRT\n! .. Save statement ..\n SAVE SAFE, LNSAFE, SAFSIN, RTSAFS, FIRST\n! .. Data statements ..\n DATA FIRST/.true./\n! .. Executable Statements ..\n if (FIRST) then\n FIRST = .false.\n SAFE = ONE/X02AME()\n LNSAFE = LOG(SAFE)\n RECEPS = ONE/X02AJE()\n SAFSIN = MIN(X02AHE(ONE),RECEPS)\n if (SAFSIN < RECEPS**0.75E0) then\n! Assume that SAFSIN is approximately sqrt(RECEPS), in which\n! case IFAIL=4 cannot occur.\n RTSAFS = SAFSIN\n ELSE\n! Set RTSAFS to the argument above which SINE and COSINE will\n! return results of less than half precision, assuming that\n! SAFSIN is approximately equal to RECEPS.\n RTSAFS = SQRT(SAFSIN)\n endif\n endif\n NREC = 0\n IER = 0\n X = REAL(Z)\n Y = AIMAG(Z)\n if (ABS(Y) > SAFSIN) then\n IER = 5\n NREC = 2\n WRITE (REC,FMT=99995) Z\n S01EAE = ZERO\n ELSE\n COSY = COS(Y)\n SINY = SIN(Y)\n if (X > LNSAFE) then\n if (COSY == ZERO) then\n RESR = ZERO\n ELSE\n XPLNCY = X + LOG(ABS(COSY))\n if (XPLNCY > LNSAFE) then\n IER = 1\n RESR = SIGN(SAFE,COSY)\n ELSE\n RESR = SIGN(EXP(XPLNCY),COSY)\n endif\n endif\n if (SINY == ZERO) then\n RESI = ZERO\n ELSE\n XPLNSY = X + LOG(ABS(SINY))\n if (XPLNSY > LNSAFE) then\n IER = IER + 2\n RESI = SIGN(SAFE,SINY)\n ELSE\n RESI = SIGN(EXP(XPLNSY),SINY)\n endif\n endif\n ELSE\n EXPX = EXP(X)\n RESR = EXPX*COSY\n RESI = EXPX*SINY\n endif\n S01EAE = CMPLX(RESR,RESI)\n if (IER == 3) then\n NREC = 2\n WRITE (REC,FMT=99997) Z\n else if (ABS(Y) > RTSAFS) then\n IER = 4\n NREC = 2\n WRITE (REC,FMT=99996) Z\n else if (IER == 1) then\n NREC = 2\n WRITE (REC,FMT=99999) Z\n else if (IER == 2) then\n NREC = 2\n WRITE (REC,FMT=99998) Z\n endif\n endif\n IFAIL = P01ABE(IFAIL,IER,SRNAME,NREC,REC)\n return\n!\n 99999 FORMAT (1X,'** Argument Z causes overflow in real part of result:' &\n ,/4X,'Z = (',1P,E13.5,',',E13.5,')')\n 99998 FORMAT (1X,'** Argument Z causes overflow in imaginary part of r', &\n 'esult:',/4X,'Z = (',1P,E13.5,',',E13.5,')')\n 99997 FORMAT (1X,'** Argument Z causes overflow in both real and imagi', &\n 'nary parts of result:',/4X,'Z = (',1P,E13.5,',',E13.5,')')\n 99996 FORMAT (1X,'** The imaginary part of argument Z is so large that', &\n ' the result is',/4X,'accurate to less than half precisio', &\n 'n: Z = (',1P,E13.5,',',E13.5,')')\n 99995 FORMAT (1X,'** The imaginary part of argument Z is so large that', &\n ' the result has no',/4X,'precision: Z = (',1P,E13.5,',', &\n E13.5,')')\n END\n REAL function S14ABE(X,IFAIL)\n! MARK 8 RELEASE. NAG COPYRIGHT 1979.\n! MARK 11.5(F77) REVISED. (SEPT 1985.)\n! LNGAMMA(X) function\n! ABRAMOWITZ AND STEGUN CH.6\n!\n! **************************************************************\n!\n! TO EXTRACT THE CORRECT CODE FOR A PARTICULAR MACHINE-RANGE,\n! ACTIVATE THE STATEMENTS CONTAINED IN COMMENTS BEGINNING CDD ,\n! WHERE DD IS THE APPROXIMATE NUMBER OF SIGNIFICANT DECIMAL\n! DIGITS REPRESENTED BY THE MACHINE\n! DELETE THE ILLEGAL DUMMY STATEMENTS OF THE FORM\n! * EXPANSION (NNNN) *\n!\n! ALSO INSERT APPROPRIATE DATA STATEMENTS TO DEFINE CONSTANTS\n! WHICH DEPEND ON THE RANGE OF NUMBERS REPRESENTED BY THE\n! MACHINE, RATHER THAN THE PRECISION (SUITABLE STATEMENTS FOR\n! SOME MACHINES ARE CONTAINED IN COMMENTS BEGINNING CRD WHERE\n! D IS A DIGIT WHICH SIMPLY DISTINGUISHES A GROUP OF MACHINES).\n! DELETE THE ILLEGAL DUMMY DATA STATEMENTS WITH VALUES WRITTEN\n! *VALUE*\n!\n! **************************************************************\n!\n! IMPLEMENTATION DEPENDENT CONSTANTS\n!\n! if (X < XSMALL)GAMMA(X)=1/X\n! I.E. XSMALL*EULGAM <= XRELPR\n! LNGAM(XVBIG)=GBIG <= XOVFLO\n! LNR2PI=LN(SQRT(2*PI))\n! if (X>XBIG)LNGAM(X)=(X-0.5)LN(X)-X+LNR2PI\n!\n! .. Parameters ..\n CHARACTER*6 SRNAME\n PARAMETER (SRNAME='S14ABE')\n! .. Scalar Arguments ..\n REAL X\n INTEGER IFAIL\n! .. Local Scalars ..\n REAL G, GBIG, LNR2PI, T, XBIG, XSMALL, XVBIG, Y\n INTEGER I, M\n! .. Local Arrays ..\n CHARACTER*1 P01REC(1)\n! .. External functions ..\n INTEGER P01ABE\n EXTERNAL P01ABE\n! .. Intrinsic functions ..\n INTRINSIC LOG, REAL\n! .. Data statements ..\n!08 DATA XSMALL,XBIG,LNR2PI/\n!08 *1.0E-8,1.2E+3,9.18938533E-1/\n!09 DATA XSMALL,XBIG,LNR2PI/\n!09 *1.0E-9,4.8E+3,9.189385332E-1/\n!12 DATA XSMALL,XBIG,LNR2PI/\n!12 *1.0E-12,3.7E+5,9.189385332047E-1/\n DATA XSMALL,XBIG,LNR2PI/ &\n 1.0E-15,6.8E+6,9.189385332046727E-1/\n!17 DATA XSMALL,XBIG,LNR2PI/\n!17 *1.0E-17,7.7E+7,9.18938533204672742E-1/\n!19 DATA XSMALL,XBIG,LNR2PI/\n!19 *1.0E-19,3.1E+8,9.189385332046727418E-1/\n!\n! RANGE DEPENDENT CONSTANTS\n! DK DK DATA XVBIG,GBIG/4.81E+2461,2.72E+2465/\n DATA XVBIG,GBIG/4.08E+36,3.40E+38/\n! FOR IEEE SINGLE PRECISION\n!R0 DATA XVBIG,GBIG/4.08E+36,3.40E+38/\n! FOR IBM 360/370 AND SIMILAR MACHINES\n!R1 DATA XVBIG,GBIG/4.29E+73,7.231E+75/\n! FOR DEC10, HONEYWELL, UNIVAC 1100 (S.P.)\n!R2 DATA XVBIG,GBIG/2.05E36,1.69E38/\n! FOR ICL 1900\n!R3 DATA XVBIG,GBIG/3.39E+74,5.784E+76/\n! FOR CDC 7600/CYBER\n!R4 DATA XVBIG,GBIG/1.72E+319,1.26E+322/\n! FOR UNIVAC 1100 (D.P.)\n!R5 DATA XVBIG,GBIG/1.28E305,8.98E+307/\n! FOR IEEE DOUBLE PRECISION\n!R7 DATA XVBIG,GBIG/2.54D+305,1.79D+308/\n! .. Executable Statements ..\n if (X > XSMALL) goto 20\n! VERY SMALL RANGE\n if (X <= 0.0) goto 160\n IFAIL = 0\n S14ABE = -LOG(X)\n goto 200\n!\n 20 if (X > 15.0) goto 120\n! MAIN SMALL X RANGE\n M = X\n T = X - FLOAT(M)\n M = M - 1\n G = 1.0\n if (M) 40, 100, 60\n 40 G = G/X\n goto 100\n 60 DO 80 I = 1, M\n G = (X-FLOAT(I))*G\n 80 continue\n 100 T = 2.0*T - 1.0\n!\n! * EXPANSION (0026) *\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 08E.09\n!08 Y = (((((((((((+1.88278283E-6*T-5.48272091E-6)*T+1.03144033E-5)\n!08 * *T-3.13088821E-5)*T+1.01593694E-4)*T-2.98340924E-4)\n!08 * *T+9.15547391E-4)*T-2.42216251E-3)*T+9.04037536E-3)\n!08 * *T-1.34119055E-2)*T+1.03703361E-1)*T+1.61692007E-2)*T +\n!08 * 8.86226925E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 09E.10\n!09 Y = ((((((((((((-6.463247484E-7*T+1.882782826E-6)\n!09 * *T-3.382165478E-6)*T+1.031440334E-5)*T-3.393457634E-5)\n!09 * *T+1.015936944E-4)*T-2.967655076E-4)*T+9.155473906E-4)\n!09 * *T-2.422622002E-3)*T+9.040375355E-3)*T-1.341184808E-2)\n!09 * *T+1.037033609E-1)*T+1.616919866E-2)*T + 8.862269255E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 12E.13\n!12 Y = ((((((((((((((((-8.965837291520E-9*T+2.612707393536E-8)\n!12 * *T-3.802866827264E-8)*T+1.173294768947E-7)\n!12 * *T-4.275076254106E-7)*T+1.276176602829E-6)\n!12 * *T-3.748495971011E-6)*T+1.123829871408E-5)\n!12 * *T-3.364018663166E-5)*T+1.009331480887E-4)\n!12 * *T-2.968895120407E-4)*T+9.157850115110E-4)\n!12 * *T-2.422595461409E-3)*T+9.040335037321E-3)\n!12 * *T-1.341185056618E-2)*T+1.037033634184E-1)\n!12 * *T+1.616919872437E-2)*T + 8.862269254528E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 15E.16\n Y = (((((((((((((((-1.243191705600000E-10*T+ &\n 3.622882508800000E-10)*T-4.030909644800000E-10) &\n *T+1.265236705280000E-9)*T-5.419466096640000E-9) &\n *T+1.613133578240000E-8)*T-4.620920340480000E-8) &\n *T+1.387603440435200E-7)*T-4.179652784537600E-7) &\n *T+1.253148247777280E-6)*T-3.754930502328320E-6) &\n *T+1.125234962812416E-5)*T-3.363759801664768E-5) &\n *T+1.009281733953869E-4)*T-2.968901194293069E-4) &\n *T+9.157859942174304E-4)*T-2.422595384546340E-3\n Y = ((((Y*T+9.040334940477911E-3)*T-1.341185057058971E-2) &\n *T+1.037033634220705E-1)*T+1.616919872444243E-2)*T + &\n 8.862269254527580E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 17E.18\n!17 Y = (((((((((((((((-1.46381209600000000E-11*T+\n!17 * 4.26560716800000000E-11)*T-4.01499750400000000E-11)\n!17 * *T+1.27679856640000000E-10)*T-6.13513953280000000E-10)\n!17 * *T+1.82243164160000000E-9)*T-5.11961333760000000E-9)\n!17 * *T+1.53835215257600000E-8)*T-4.64774927155200000E-8)\n!17 * *T+1.39383522590720000E-7)*T-4.17808776355840000E-7)\n!17 * *T+1.25281466396672000E-6)*T-3.75499034136576000E-6)\n!17 * *T+1.12524642975590400E-5)*T-3.36375833240268800E-5)\n!17 * *T+1.00928148823365120E-4)*T-2.96890121633200000E-4\n!17 Y = ((((((Y*T+9.15785997288933120E-4)*T-2.42259538436268176E-3)\n!17 * *T+9.04033494028101968E-3)*T-1.34118505705967765E-2)\n!17 * *T+1.03703363422075456E-1)*T+1.61691987244425092E-2)*T +\n!17 * 8.86226925452758013E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 19E.19\n!19 Y = (((((((((((((((+6.710886400000000000E-13*T-\n!19 * 1.677721600000000000E-12)*T+6.710886400000000000E-13)\n!19 * *T-4.152360960000000000E-12)*T+2.499805184000000000E-11)\n!19 * *T-6.898581504000000000E-11)*T+1.859597107200000000E-10)\n!19 * *T-5.676387532800000000E-10)*T+1.725556326400000000E-9)\n!19 * *T-5.166307737600000000E-9)*T+1.548131827712000000E-8)\n!19 * *T-4.644574052352000000E-8)*T+1.393195837030400000E-7)\n!19 * *T-4.178233990758400000E-7)*T+1.252842254950400000E-6)\n!19 * *T-3.754985815285760000E-6)*T+1.125245651030528000E-5\n!19 Y = (((((((((Y*T-3.363758423922688000E-5)\n!19 * *T+1.009281502108083200E-4)\n!19 * *T-2.968901215188000000E-4)*T+9.157859971435078400E-4)\n!19 * *T-2.422595384370689760E-3)*T+9.040334940288877920E-3)\n!19 * *T-1.341185057059651648E-2)*T+1.037033634220752902E-1)\n!19 * *T+1.616919872444250674E-2)*T + 8.862269254527580137E-1\n!\n S14ABE = LOG(Y*G)\n IFAIL = 0\n goto 200\n!\n 120 if (X > XBIG) goto 140\n! MAIN LARGE X RANGE\n T = 450.0/(X*X) - 1.0\n!\n! * EXPANSION (0059) *\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 08E.09\n!08 Y = (+3.89980902E-9*T-6.16502533E-6)*T + 8.33271644E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 09E.10\n!09 Y = (+3.899809019E-9*T-6.165025333E-6)*T + 8.332716441E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 12E.13\n!12 Y = ((-6.451144077930E-12*T+3.899809018958E-9)\n!12 * *T-6.165020494506E-6)*T + 8.332716440658E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 15E.16\n Y = (((+2.002019273379824E-14*T-6.451144077929628E-12) &\n *T+3.899788998764847E-9)*T-6.165020494506090E-6)*T + &\n 8.332716440657866E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 17E.18\n!17 Y = ((((-9.94561064728159347E-17*T+2.00201927337982364E-14)\n!17 * *T-6.45101975779653651E-12)*T+3.89978899876484712E-9)\n!17 * *T-6.16502049453716986E-6)*T + 8.33271644065786580E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 19E.19\n!19 Y = (((((+7.196406678180202240E-19*T-9.945610647281593472E-17)\n!19 * *T+2.001911327279650935E-14)*T-6.451019757796536510E-12)\n!19 * *T+3.899788999169644998E-9)*T-6.165020494537169862E-6)*T +\n!19 * 8.332716440657865795E-2\n!\n S14ABE = (X-0.5)*LOG(X) - X + LNR2PI + Y/X\n IFAIL = 0\n goto 200\n!\n 140 if (X > XVBIG) goto 180\n! ASYMPTOTIC LARGE X RANGE\n S14ABE = (X-0.5)*LOG(X) - X + LNR2PI\n IFAIL = 0\n goto 200\n!\n! FAILURE EXITS\n 160 IFAIL = P01ABE(IFAIL,1,SRNAME,0,P01REC)\n S14ABE = 0.0\n goto 200\n 180 IFAIL = P01ABE(IFAIL,2,SRNAME,0,P01REC)\n S14ABE = GBIG\n!\n 200 return\n!\n END\n subroutine S17DGE(DERIV,Z,SCALE,AI,NZ,IFAIL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-770 (DEC 1989).\n!\n! Original name: CAIRY\n!\n! PURPOSE TO COMPUTE AIRY functionS AI(Z) AND DAI(Z) FOR COMPLEX Z\n!\n! DESCRIPTION\n! ===========\n!\n! ON SCALE='U', S17DGE COMPUTES THE COMPLEX AIRY function AI(Z)\n! OR ITS DERIVATIVE DAI(Z)/DZ ON DERIV='F' OR DERIV='D'\n! RESPECTIVELY. ON SCALE='S', A SCALING OPTION\n! CEXP(ZTA)*AI(Z) OR CEXP(ZTA)*DAI(Z)/DZ IS PROVIDED TO REMOVE\n! THE EXPONENTIAL DECAY IN -PI/3 < ARG(Z) < PI/3 AND THE\n! EXPONENTIAL GROWTH IN PI/3 < ABS(ARG(Z)) < PI WHERE\n! ZTA=(2/3)*Z*CSQRT(Z)\n!\n! WHILE THE AIRY functionS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN\n! THE WHOLE Z PLANE, THE CORRESPONDING SCALED functionS DEFINED\n! FOR SCALE='S' HAVE A CUT ALONG THE NEGATIVE REAL AXIS.\n! DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF\n! MATHEMATICAL functionS (REF. 1).\n!\n! INPUT\n! Z - Z=CMPLX(X,Y)\n! DERIV - return function (DERIV='F') OR DERIVATIVE\n! (DERIV='D')\n! SCALE - A PARAMETER TO INDICATE THE SCALING OPTION\n! SCALE = 'U' OR 'u' returnS\n! AI=AI(Z) ON DERIV='F' OR\n! AI=DAI(Z)/DZ ON DERIV='D'\n! SCALE = 'S' OR 's' returnS\n! AI=CEXP(ZTA)*AI(Z) ON DERIV='F' OR\n! AI=CEXP(ZTA)*DAI(Z)/DZ ON DERIV='D' WHERE\n! ZTA=(2/3)*Z*CSQRT(Z)\n!\n! OUTPUT\n! AI - COMPLEX ANSWER DEPENDING ON THE CHOICES FOR DERIV\n! AND SCALE\n! NZ - UNDERFLOW INDICATOR\n! NZ= 0 , NORMAL return\n! NZ= 1 , AI=CMPLX(0.0,0.0) DUE TO UNDERFLOW IN\n! -PI/3 < ARG(Z) < PI/3 ON SCALE='U'\n! IFAIL - ERROR FLAG\n! IFAIL=0, NORMAL return - COMPUTATION COMPLETED\n! IFAIL=1, INPUT ERROR - NO COMPUTATION\n! IFAIL=2, OVERFLOW - NO COMPUTATION, REAL(ZTA)\n! TOO LARGE WITH SCALE = 'U'\n! IFAIL=3, CABS(Z) LARGE - COMPUTATION COMPLETED\n! LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION\n! PRODUCE LESS THAN HALF OF MACHINE ACCURACY\n! IFAIL=4, CABS(Z) TOO LARGE - NO COMPUTATION\n! COMPLETE LOSS OF ACCURACY BY ARGUMENT\n! REDUCTION\n! IFAIL=5, ERROR - NO COMPUTATION,\n! ALGORITHM TERMINATION CONDITION NOT MET\n!\n! LONG DESCRIPTION\n! ================\n!\n! AI AND DAI ARE COMPUTED FOR CABS(Z)>1.0 FROM THE K BESSEL\n! functionS BY\n!\n! AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA)\n! C=1.0/(PI*SQRT(3.0))\n! ZTA=(2/3)*Z**(3/2)\n!\n! WITH THE POWER SERIES FOR CABS(Z) <= 1.0.\n!\n! IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-\n! MENTARY functionS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES\n! OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF\n! THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),\n! THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR\n! FLAG IFAIL=3 IS TRIGGERED WHERE UR=X02AJE()=UNIT ROUNDOFF.\n! ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN\n! ALL SIGNIFICANCE IS LOST AND IFAIL=4. IN ORDER TO USE THE INT\n! function, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE\n! LARGEST INTEGER, U3=X02BBE(). THUS, THE MAGNITUDE OF ZETA\n! MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,\n! AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE\n! PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE\n! PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-\n! ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-\n! NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN\n! DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN\n! EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,\n! NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE\n! PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER\n! MACHINES.\n!\n! THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX\n! BESSEL function CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT\n! ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-\n! SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE\n! ELEMENTARY functionS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),\n! ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF\n! CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY\n! HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN\n! ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY\n! SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER\n! THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,\n! 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS\n! THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER\n! COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY\n! BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER\n! COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE\n! MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,\n! THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,\n! OR -PI/2+P.\n!\n! REFERENCES\n! ==========\n! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ\n! AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF\n! COMMERCE, 1955.\n!\n! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT\n! AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983\n!\n! A subroutine PACKAGE FOR BESSEL functionS OF A COMPLEX\n! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-\n! 1018, MAY, 1985\n!\n! A PORTABLE PACKAGE FOR BESSEL functionS OF A COMPLEX\n! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.\n! MATH. SOFTWARE, 1986\n!\n! DATE WRITTEN 830501 (YYMMDD)\n! REVISION DATE 830501 (YYMMDD)\n! AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES\n!\n! .. Parameters ..\n CHARACTER*6 SRNAME\n PARAMETER (SRNAME='S17DGE')\n! .. Scalar Arguments ..\n COMPLEX AI, Z\n INTEGER IFAIL, NZ\n CHARACTER DERIV, SCALE\n! .. Local Scalars ..\n COMPLEX CONE, CSQ, S1, S2, TRM1, TRM2, Z3, ZTA\n REAL AA, AD, AK, ALAZ, ALIM, ATRM, AZ, AZ3, BB, BK, &\n C1, C2, CK, COEF, D1, D2, DIG, DK, ELIM, FID, &\n FNU, R1M5, RL, SAVAA, SFAC, TOL, TTH, Z3I, Z3R, &\n ZI, ZR\n INTEGER ID, IERR, IFL, IFLAG, K, K1, K2, KODE, MR, NN, &\n NREC\n! .. Local Arrays ..\n COMPLEX CY(1)\n CHARACTER*80 REC(1)\n! .. External functions ..\n COMPLEX S01EAE\n REAL X02AHE, X02AJE, X02AME\n INTEGER P01ABE, X02BBE, X02BHE, X02BJE, X02BKE, X02BLE\n EXTERNAL S01EAE, X02AHE, X02AJE, X02AME, P01ABE, X02BBE, &\n X02BHE, X02BJE, X02BKE, X02BLE\n! .. External subroutines ..\n EXTERNAL DGXS17, DGZS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, LOG, LOG10, MAX, MIN, REAL, &\n SQRT\n! .. Data statements ..\n DATA TTH, C1, C2, COEF/6.66666666666666667E-01, &\n 3.55028053887817240E-01, &\n 2.58819403792806799E-01, &\n 1.83776298473930683E-01/\n DATA CONE/(1.0E0,0.0E0)/\n! .. Executable Statements ..\n IERR = 0\n NREC = 0\n NZ = 0\n if (DERIV == 'F' .or. DERIV == 'f') then\n ID = 0\n else if (DERIV == 'D' .or. DERIV == 'd') then\n ID = 1\n ELSE\n ID = -1\n endif\n if (SCALE == 'U' .or. SCALE == 'u') then\n KODE = 1\n else if (SCALE == 'S' .or. SCALE == 's') then\n KODE = 2\n ELSE\n KODE = -1\n endif\n if (ID == -1) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99999) DERIV\n else if (KODE == -1) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99998) SCALE\n endif\n if (IERR == 0) then\n AZ = ABS(Z)\n TOL = MAX(X02AJE(),1.0E-18)\n FID = ID\n if (AZ > 1.0E0) then\n! ------------------------------------------------------------\n! CASE FOR CABS(Z)>1.0\n! ------------------------------------------------------------\n FNU = (1.0E0+FID)/3.0E0\n! ------------------------------------------------------------\n! SET PARAMETERS RELATED TO MACHINE CONSTANTS.\n! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.\n! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW\n! LIMIT.\n! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND\n! EXP(ELIM)>EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS\n! NEAR UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC\n! IS DONE.\n! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR\n! LARGE Z.\n! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).\n! ------------------------------------------------------------\n K1 = X02BKE()\n K2 = X02BLE()\n R1M5 = LOG10(REAL(X02BHE()))\n K = MIN(ABS(K1),ABS(K2))\n ELIM = 2.303E0*(K*R1M5-3.0E0)\n K1 = X02BJE() - 1\n AA = R1M5*K1\n DIG = MIN(AA,18.0E0)\n AA = AA*2.303E0\n ALIM = ELIM + MAX(-AA,-41.45E0)\n RL = 1.2E0*DIG + 3.0E0\n ALAZ = LOG(AZ)\n! ------------------------------------------------------------\n! TEST FOR RANGE\n! ------------------------------------------------------------\n AA = 0.5E0/TOL\n BB = X02BBE(1.0E0)*0.5E0\n AA = MIN(AA,BB,X02AHE(1.0E0))\n AA = AA**TTH\n if (AZ > AA) then\n NZ = 0\n IERR = 4\n NREC = 1\n WRITE (REC,FMT=99997) AZ, AA\n ELSE\n AA = SQRT(AA)\n SAVAA = AA\n if (AZ > AA) then\n IERR = 3\n NREC = 1\n WRITE (REC,FMT=99996) AZ, AA\n endif\n CSQ = SQRT(Z)\n ZTA = Z*CSQ*CMPLX(TTH,0.0E0)\n! ---------------------------------------------------------\n! RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS\n! SMALL\n! ---------------------------------------------------------\n IFLAG = 0\n SFAC = 1.0E0\n ZI = AIMAG(Z)\n ZR = REAL(Z)\n AK = AIMAG(ZTA)\n if (ZR < 0.0E0) then\n BK = REAL(ZTA)\n CK = -ABS(BK)\n ZTA = CMPLX(CK,AK)\n endif\n if (ZI == 0.0E0) then\n if (ZR <= 0.0E0) ZTA = CMPLX(0.0E0,AK)\n endif\n AA = REAL(ZTA)\n if (AA >= 0.0E0 .and. ZR > 0.0E0) then\n if (KODE /= 2) then\n! ---------------------------------------------------\n! UNDERFLOW TEST\n! ---------------------------------------------------\n if (AA >= ALIM) then\n AA = -AA - 0.25E0*ALAZ\n IFLAG = 2\n SFAC = 1.0E0/TOL\n if (AA < (-ELIM)) then\n NZ = 1\n AI = CMPLX(0.0E0,0.0E0)\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n endif\n endif\n CALL DGXS17(ZTA,FNU,KODE,1,CY,NZ,TOL,ELIM,ALIM)\n ELSE\n if (KODE /= 2) then\n! ---------------------------------------------------\n! OVERFLOW TEST\n! ---------------------------------------------------\n if (AA <= (-ALIM)) then\n AA = -AA + 0.25E0*ALAZ\n IFLAG = 1\n SFAC = TOL\n if (AA > ELIM) goto 20\n endif\n endif\n! ------------------------------------------------------\n! DGXS17 AND DGZS17 return EXP(ZTA)*K(FNU,ZTA) ON KODE=2\n! ------------------------------------------------------\n MR = 1\n if (ZI < 0.0E0) MR = -1\n CALL DGZS17(ZTA,FNU,KODE,MR,1,CY,NN,RL,TOL,ELIM,ALIM)\n if (NN >= 0) then\n NZ = NZ + NN\n goto 40\n else if (NN == (-3)) then\n NZ = 0\n IERR = 4\n NREC = 1\n WRITE (REC,FMT=99997) AZ, SAVAA\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n else if (NN /= (-1)) then\n NZ = 0\n IERR = 5\n NREC = 1\n WRITE (REC,FMT=99995)\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n 20 NZ = 0\n IERR = 2\n NREC = 1\n WRITE (REC,FMT=99994)\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n 40 S1 = CY(1)*CMPLX(COEF,0.0E0)\n if (IFLAG /= 0) then\n S1 = S1*CMPLX(SFAC,0.0E0)\n if (ID == 1) then\n S1 = -S1*Z\n AI = S1*CMPLX(1.0E0/SFAC,0.0E0)\n ELSE\n S1 = S1*CSQ\n AI = S1*CMPLX(1.0E0/SFAC,0.0E0)\n endif\n else if (ID == 1) then\n AI = -Z*S1\n ELSE\n AI = CSQ*S1\n endif\n endif\n ELSE\n! ------------------------------------------------------------\n! POWER SERIES FOR CABS(Z) <= 1.\n! ------------------------------------------------------------\n S1 = CONE\n S2 = CONE\n if (AZ < TOL) then\n AA = 1.0E+3*X02AME()\n S1 = CMPLX(0.0E0,0.0E0)\n if (ID == 1) then\n AI = -CMPLX(C2,0.0E0)\n AA = SQRT(AA)\n if (AZ > AA) S1 = Z*Z*CMPLX(0.5E0,0.0E0)\n AI = AI + S1*CMPLX(C1,0.0E0)\n ELSE\n if (AZ > AA) S1 = CMPLX(C2,0.0E0)*Z\n AI = CMPLX(C1,0.0E0) - S1\n endif\n ELSE\n AA = AZ*AZ\n if (AA >= TOL/AZ) then\n TRM1 = CONE\n TRM2 = CONE\n ATRM = 1.0E0\n Z3 = Z*Z*Z\n AZ3 = AZ*AA\n AK = 2.0E0 + FID\n BK = 3.0E0 - FID - FID\n CK = 4.0E0 - FID\n DK = 3.0E0 + FID + FID\n D1 = AK*DK\n D2 = BK*CK\n AD = MIN(D1,D2)\n AK = 24.0E0 + 9.0E0*FID\n BK = 30.0E0 - 9.0E0*FID\n Z3R = REAL(Z3)\n Z3I = AIMAG(Z3)\n DO 60 K = 1, 25\n TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1)\n S1 = S1 + TRM1\n TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2)\n S2 = S2 + TRM2\n ATRM = ATRM*AZ3/AD\n D1 = D1 + AK\n D2 = D2 + BK\n AD = MIN(D1,D2)\n if (ATRM < TOL*AD) then\n goto 80\n ELSE\n AK = AK + 18.0E0\n BK = BK + 18.0E0\n endif\n 60 continue\n endif\n 80 if (ID == 1) then\n AI = -S2*CMPLX(C2,0.0E0)\n if (AZ > TOL) AI = AI + Z*Z*S1*CMPLX(C1/(1.0E0+FID), &\n 0.0E0)\n if (KODE /= 1) then\n ZTA = Z*SQRT(Z)*CMPLX(TTH,0.0E0)\n! AI = AI*EXP(ZTA)\n IFL = 1\n AI = AI*S01EAE(ZTA,IFL)\n endif\n ELSE\n AI = S1*CMPLX(C1,0.0E0) - Z*S2*CMPLX(C2,0.0E0)\n if (KODE /= 1) then\n ZTA = Z*SQRT(Z)*CMPLX(TTH,0.0E0)\n! AI = AI*EXP(ZTA)\n IFL = 1\n AI = AI*S01EAE(ZTA,IFL)\n endif\n endif\n endif\n endif\n endif\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n!\n 99999 FORMAT (1X,'** On entry, DERIV has illegal value: DERIV = ''',A, &\n '''')\n 99998 FORMAT (1X,'** On entry, SCALE has illegal value: SCALE = ''',A, &\n '''')\n 99997 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' > ', &\n E13.5)\n 99996 FORMAT (1X,'** Results lack precision because abs(Z) =',1P,E13.5, &\n ' > ',E13.5)\n 99995 FORMAT (1X,'** No computation - algorithm termination condition ', &\n 'not met.')\n 99994 FORMAT (1X,'** No computation because real(ZTA) too large, where', &\n ' ZTA = (2/3)*Z**(3/2).')\n END\n subroutine S17DLE(M,FNU,Z,N,SCALE,CY,NZ,IFAIL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-781 (DEC 1989).\n!\n! Original name: CBESH\n!\n! PURPOSE TO COMPUTE THE H-BESSEL functionS OF A COMPLEX ARGUMENT\n!\n! DESCRIPTION\n! ===========\n!\n! ON SCALE='U', S17DLE COMPUTES AN N MEMBER SEQUENCE OF COMPLEX\n! HANKEL (BESSEL) functionS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1\n! OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX\n! Z /= CMPLX(0.0E0,0.0E0) IN THE CUT PLANE -PI < ARG(Z) <= PI.\n! ON SCALE='S', S17DLE COMPUTES THE SCALED HANKEL functionS\n!\n! CY(I)=H(M,FNU+J-1,Z)*EXP(-MM*Z*I) MM=3-2M, I**2=-1.\n!\n! WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER\n! AND LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN\n! THE NBS HANDBOOK OF MATHEMATICAL functionS (REF. 1).\n!\n! INPUT\n! Z - Z=CMPLX(X,Y), Z /= CMPLX(0.,0.),-PI < ARG(Z) <= PI\n! FNU - ORDER OF INITIAL H function, FNU >= 0.0E0\n! SCALE - A PARAMETER TO INDICATE THE SCALING OPTION\n! SCALE = 'U' OR SCALE = 'u' returnS\n! CY(J)=H(M,FNU+J-1,Z), J=1,...,N\n! = 'S' OR SCALE = 's' returnS\n! CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))\n! J=1,...,N , I**2=-1\n! M - KIND OF HANKEL function, M=1 OR 2\n! N - NUMBER OF MEMBERS OF THE SEQUENCE, N >= 1\n!\n! OUTPUT\n! CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN\n! VALUES FOR THE SEQUENCE\n! CY(J)=H(M,FNU+J-1,Z) OR\n! CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N\n! DEPENDING ON SCALE, I**2=-1.\n! NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,\n! NZ= 0 , NORMAL return\n! NZ>0 , FIRST NZ COMPONENTS OF CY SET TO ZERO\n! DUE TO UNDERFLOW, CY(J)=CMPLX(0.0,0.0)\n! J=1,...,NZ WHEN Y>0.0 AND M=1 OR\n! Y < 0.0 AND M=2. FOR THE COMPLMENTARY\n! HALF PLANES, NZ STATES ONLY THE NUMBER\n! OF UNDERFLOWS.\n! IERR -ERROR FLAG\n! IERR=0, NORMAL return - COMPUTATION COMPLETED\n! IERR=1, INPUT ERROR - NO COMPUTATION\n! IERR=2, OVERFLOW - NO COMPUTATION,\n! CABS(Z) TOO SMALL\n! IERR=3 OVERFLOW - NO COMPUTATION,\n! FNU+N-1 TOO LARGE\n! IERR=4, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE\n! BUT LOSSES OF SIGNIFCANCE BY ARGUMENT\n! REDUCTION PRODUCE LESS THAN HALF OF MACHINE\n! ACCURACY\n! IERR=5, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-\n! TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-\n! CANCE BY ARGUMENT REDUCTION\n! IERR=6, ERROR - NO COMPUTATION,\n! ALGORITHM TERMINATION CONDITION NOT MET\n!\n! LONG DESCRIPTION\n! ================\n!\n! THE COMPUTATION IS CARRIED OUT BY THE RELATION\n!\n! H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP))\n! MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1\n!\n! FOR M=1 OR 2 WHERE THE K BESSEL function IS COMPUTED FOR THE\n! RIGHT HALF PLANE RE(Z) >= 0.0. THE K function IS continueD\n! TO THE LEFT HALF PLANE BY THE RELATION\n!\n! K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)\n! MP=MR*PI*I, MR=+1 OR -1, RE(Z)>0, I**2=-1\n!\n! WHERE I(FNU,Z) IS THE I BESSEL function.\n!\n! EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z\n! PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL\n! GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING\n! BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE\n! WHOLE Z PLANE FOR Z TO INFINITY.\n!\n! FOR NEGATIVE ORDERS,THE FORMULAE\n!\n! H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I)\n! H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I)\n! I**2=-1\n!\n! CAN BE USED.\n!\n! IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-\n! MENTARY functionS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS\n! LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.\n! CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN\n! LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG\n! IERR=4 IS TRIGGERED WHERE UR=X02AJE()=UNIT ROUNDOFF. ALSO\n! IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS\n! LOST AND IERR=5. IN ORDER TO USE THE INT function, ARGUMENTS\n! MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE\n! INTEGER, U3=X02BBE(). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS\n! RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3\n! ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION\n! ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION\n! ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN\n! THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT\n! TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS\n! IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.\n! SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.\n!\n! THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX\n! BESSEL function CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT\n! ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-\n! SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE\n! ELEMENTARY functionS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),\n! ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF\n! CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY\n! HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN\n! ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY\n! SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER\n! THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,\n! 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS\n! THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER\n! COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY\n! BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER\n! COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE\n! MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,\n! THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,\n! OR -PI/2+P.\n!\n! REFERENCES\n! ==========\n! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ\n! AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF\n! COMMERCE, 1955.\n!\n! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT\n! BY D. E. AMOS, SAND83-0083, MAY, 1983.\n!\n! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT\n! AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983\n!\n! A subroutine PACKAGE FOR BESSEL functionS OF A COMPLEX\n! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-\n! 1018, MAY, 1985\n!\n! A PORTABLE PACKAGE FOR BESSEL functionS OF A COMPLEX\n! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.\n! MATH. SOFTWARE, 1986\n!\n! DATE WRITTEN 830501 (YYMMDD)\n! REVISION DATE 830501 (YYMMDD)\n! AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES\n!\n! .. Parameters ..\n CHARACTER*6 SRNAME\n PARAMETER (SRNAME='S17DLE')\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL FNU\n INTEGER IFAIL, M, N, NZ\n CHARACTER*1 SCALE\n! .. Array Arguments ..\n COMPLEX CY(N)\n! .. Local Scalars ..\n COMPLEX CSGN, ZN, ZT\n REAL AA, ALIM, ALN, ARG, ASCLE, ATOL, AZ, BB, CPN, &\n DIG, ELIM, FMM, FN, FNUL, HPI, R1M5, RHPI, RL, &\n RTOL, SGN, SPN, TOL, UFL, XN, XX, YN, YY\n INTEGER I, IERR, INU, INUH, IR, K, K1, K2, KODE, MM, MR, &\n NN, NREC, NUF, NW\n! .. Local Arrays ..\n CHARACTER*80 REC(1)\n! .. External functions ..\n REAL X02AHE, X02AJE\n INTEGER P01ABE, X02BBE, X02BHE, X02BJE, X02BKE, X02BLE\n EXTERNAL X02AHE, X02AJE, P01ABE, X02BBE, X02BHE, X02BJE, &\n X02BKE, X02BLE\n! .. External subroutines ..\n EXTERNAL DEVS17, DGXS17, DLYS17, DLZS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, LOG, LOG10, &\n MAX, MIN, MOD, REAL, SIGN, SIN, SQRT\n! .. Data statements ..\n!\n DATA HPI/1.57079632679489662E0/\n! .. Executable Statements ..\n NZ = 0\n NREC = 0\n XX = REAL(Z)\n YY = AIMAG(Z)\n IERR = 0\n if (SCALE == 'U' .or. SCALE == 'u') then\n KODE = 1\n else if (SCALE == 'S' .or. SCALE == 's') then\n KODE = 2\n ELSE\n KODE = -1\n endif\n if (XX == 0.0E0 .and. YY == 0.0E0) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99999)\n else if (FNU < 0.0E0) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99998) FNU\n else if (KODE == -1) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99997) SCALE\n else if (N < 1) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99996) N\n else if (M < 1 .or. M > 2) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99995) M\n endif\n if (IERR == 0) then\n NN = N\n! ---------------------------------------------------------------\n! SET PARAMETERS RELATED TO MACHINE CONSTANTS.\n! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.\n! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.\n! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND\n! EXP(ELIM)>EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR\n! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.\n! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR\n! LARGE Z.\n! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).\n! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE\n! FNU\n! ---------------------------------------------------------------\n TOL = MAX(X02AJE(),1.0E-18)\n K1 = X02BKE()\n K2 = X02BLE()\n R1M5 = LOG10(REAL(X02BHE()))\n K = MIN(ABS(K1),ABS(K2))\n ELIM = 2.303E0*(K*R1M5-3.0E0)\n K1 = X02BJE() - 1\n AA = R1M5*K1\n DIG = MIN(AA,18.0E0)\n AA = AA*2.303E0\n ALIM = ELIM + MAX(-AA,-41.45E0)\n FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)\n RL = 1.2E0*DIG + 3.0E0\n FN = FNU + NN - 1\n MM = 3 - M - M\n FMM = MM\n ZN = Z*CMPLX(0.0E0,-FMM)\n XN = REAL(ZN)\n YN = AIMAG(ZN)\n AZ = ABS(Z)\n! ---------------------------------------------------------------\n! TEST FOR RANGE\n! ---------------------------------------------------------------\n AA = 0.5E0/TOL\n BB = X02BBE(1.0E0)*0.5E0\n AA = MIN(AA,BB,X02AHE(1.0E0))\n if (AZ <= AA) then\n if (FN <= AA) then\n AA = SQRT(AA)\n if (AZ > AA) then\n IERR = 4\n NREC = 1\n WRITE (REC,FMT=99994) AZ, AA\n else if (FN > AA) then\n IERR = 4\n NREC = 1\n WRITE (REC,FMT=99993) FN, AA\n endif\n! ---------------------------------------------------------\n! OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE\n! ---------------------------------------------------------\n UFL = EXP(-ELIM)\n if (AZ >= UFL) then\n if (FNU > FNUL) then\n! ---------------------------------------------------\n! UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU>FNUL\n! ---------------------------------------------------\n MR = 0\n if ((XN < 0.0E0) .or. (XN == 0.0E0 .and. YN <&\n 0.0E0 .and. M == 2)) then\n MR = -MM\n if (XN == 0.0E0 .and. YN < 0.0E0) ZN = -ZN\n endif\n CALL DLYS17(ZN,FNU,KODE,MR,NN,CY,NW,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 40\n ELSE\n NZ = NZ + NW\n endif\n ELSE\n if (FN > 1.0E0) then\n if (FN > 2.0E0) then\n CALL DEVS17(ZN,FNU,KODE,2,NN,CY,NUF,TOL,ELIM, &\n ALIM)\n if (NUF < 0) then\n goto 60\n ELSE\n NZ = NZ + NUF\n NN = NN - NUF\n! ------------------------------------------\n! HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1\n! ON return FROM DEVS17\n! IF NUF=NN, THEN CY(I)=CZERO FOR ALL I\n! ------------------------------------------\n if (NN == 0) then\n if (XN < 0.0E0) then\n goto 60\n ELSE\n IFAIL = P01ABE(IFAIL,IERR,SRNAME, &\n NREC,REC)\n return\n endif\n endif\n endif\n else if (AZ <= TOL) then\n ARG = 0.5E0*AZ\n ALN = -FN*LOG(ARG)\n if (ALN > ELIM) goto 60\n endif\n endif\n if ((XN < 0.0E0) .or. (XN == 0.0E0 .and. YN <&\n 0.0E0 .and. M == 2)) then\n! ------------------------------------------------\n! LEFT HALF PLANE COMPUTATION\n! ------------------------------------------------\n MR = -MM\n CALL DLZS17(ZN,FNU,KODE,MR,NN,CY,NW,RL,FNUL,TOL, &\n ELIM,ALIM)\n if (NW < 0) then\n goto 40\n ELSE\n NZ = NW\n endif\n ELSE\n! ------------------------------------------------\n! RIGHT HALF PLANE COMPUTATION, XN >= 0. .and.\n! (XN /= 0. .or. YN >= 0. .or. M=1)\n! ------------------------------------------------\n CALL DGXS17(ZN,FNU,KODE,NN,CY,NZ,TOL,ELIM,ALIM)\n endif\n endif\n! ------------------------------------------------------\n! H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT)\n!\n! ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2\n! ------------------------------------------------------\n SGN = SIGN(HPI,-FMM)\n! ------------------------------------------------------\n! CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF\n! SIGNIFICANCE WHEN FNU IS LARGE\n! ------------------------------------------------------\n INU = INT(FNU)\n INUH = INU/2\n IR = INU - 2*INUH\n ARG = (FNU-INU+IR)*SGN\n RHPI = 1.0E0/SGN\n CPN = RHPI*COS(ARG)\n SPN = RHPI*SIN(ARG)\n! ZN = CMPLX(-SPN,CPN)\n CSGN = CMPLX(-SPN,CPN)\n! if (MOD(INUH,2)==1) ZN = -ZN\n if (MOD(INUH,2) == 1) CSGN = -CSGN\n ZT = CMPLX(0.0E0,-FMM)\n RTOL = 1.0E0/TOL\n ASCLE = UFL*RTOL\n DO 20 I = 1, NN\n! CY(I) = CY(I)*ZN\n! ZN = ZN*ZT\n ZN = CY(I)\n AA = REAL(ZN)\n BB = AIMAG(ZN)\n ATOL = 1.0E0\n if (MAX(ABS(AA),ABS(BB)) <= ASCLE) then\n ZN = ZN*RTOL\n ATOL = TOL\n endif\n ZN = ZN*CSGN\n CY(I) = ZN*ATOL\n CSGN = CSGN*ZT\n 20 continue\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n 40 if (NW == (-3)) then\n NZ = 0\n IERR = 5\n NREC = 1\n WRITE (REC,FMT=99988) AZ, AA\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n else if (NW /= (-1)) then\n NZ = 0\n IERR = 6\n NREC = 1\n WRITE (REC,FMT=99992)\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n 60 IERR = 3\n NZ = 0\n NREC = 1\n WRITE (REC,FMT=99991) FN\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n ELSE\n IERR = 2\n NZ = 0\n NREC = 1\n WRITE (REC,FMT=99990) AZ, UFL\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n ELSE\n NZ = 0\n IERR = 5\n NREC = 1\n WRITE (REC,FMT=99989) FN, AA\n endif\n ELSE\n NZ = 0\n IERR = 5\n NREC = 1\n WRITE (REC,FMT=99988) AZ, AA\n endif\n endif\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n!\n 99999 FORMAT (1X,'** On entry, Z = (0.0,0.0)')\n 99998 FORMAT (1X,'** On entry, FNU < 0: FNU = ',E13.5)\n 99997 FORMAT (1X,'** On entry, SCALE has an illegal value: SCALE = ''', &\n A,'''')\n 99996 FORMAT (1X,'** On entry, N <= 0: N = ',I16)\n 99995 FORMAT (1X,'** On entry, M has illegal value: M = ',I16)\n 99994 FORMAT (1X,'** Results lack precision because abs(Z) =',1P,E13.5, &\n ' > ',E13.5)\n 99993 FORMAT (1X,'** Results lack precision, FNU+N-1 =',1P,E13.5, &\n ' > ',E13.5)\n 99992 FORMAT (1X,'** No computation - algorithm termination condition ', &\n 'not met.')\n 99991 FORMAT (1X,'** No computation because FNU+N-1 =',1P,E13.5,' is t', &\n 'oo large.')\n 99990 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' < ', &\n E13.5)\n 99989 FORMAT (1X,'** No computation because FNU+N-1 =',1P,E13.5,' > ', &\n E13.5)\n 99988 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' > ', &\n E13.5)\n END\n REAL function X02AHE(X)\n! MARK 9 RELEASE. NAG COPYRIGHT 1981.\n! MARK 11.5(F77) REVISED. (SEPT 1985.)\n!\n! * MAXIMUM ARGUMENT FOR SIN AND COS *\n! returnS THE LARGEST POSITIVE REAL NUMBER MAXSC SUCH THAT\n! SIN(MAXSC) AND COS(MAXSC) CAN BE SUCCESSFULLY COMPUTED\n! BY THE COMPILER SUPPLIED SIN AND COS ROUTINES.\n!\n! .. Scalar Arguments ..\n REAL X\n REAL CONX02\n DATA CONX02 /1.677721600000E+7 /\n! .. Executable Statements ..\n X02AHE = CONX02\n return\n END\n REAL function X02AJE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS (1/2)*B**(1-P) IF ROUNDS IS .true.\n! returnS B**(1-P) OTHERWISE\n!\n REAL CONX02\n DATA CONX02 /1.4210854715202E-14 /\n!bc DATA CONX02 /1.421090000020E-14 /\n! .. Executable Statements ..\n X02AJE = CONX02\n return\n END\n REAL function X02ALE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS (1 - B**(-P)) * B**EMAX (THE LARGEST POSITIVE MODEL\n! NUMBER)\n!\n REAL CONX02\n! DK DK DK DATA CONX02 /0577757777777777777777B /\n DATA CONX02 /1.e30/\n! .. Executable Statements ..\n X02ALE = CONX02\n return\n END\n REAL function X02AME()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE 'SAFE RANGE' PARAMETER\n! I.E. THE SMALLEST POSITIVE MODEL NUMBER Z SUCH THAT\n! FOR ANY X WHICH SATISFIES X >= Z AND X <= 1/Z\n! THE FOLLOWING CAN BE COMPUTED WITHOUT OVERFLOW, UNDERFLOW OR OTHER\n! ERROR\n!\n! -X\n! 1.0/X\n! SQRT(X)\n! LOG(X)\n! EXP(LOG(X))\n! Y**(LOG(X)/LOG(Y)) FOR ANY Y\n!\n REAL CONX02\n! DK DK DK DATA CONX02 /0200044000000000000004B /\n DATA CONX02 /1.e-27/\n! .. Executable Statements ..\n X02AME = CONX02\n return\n END\n REAL function X02ANE()\n! MARK 15 RELEASE. NAG COPYRIGHT 1991.\n!\n! returns the 'safe range' parameter for complex numbers,\n! i.e. the smallest positive model number Z such that\n! for any X which satisfies X >= Z and X <= 1/Z\n! the following can be computed without overflow, underflow or other\n! error\n!\n! -W\n! 1.0/W\n! SQRT(W)\n! LOG(W)\n! EXP(LOG(W))\n! Y**(LOG(W)/LOG(Y)) for any Y\n! ABS(W)\n!\n! where W is any of cmplx(X,0), cmplx(0,X), cmplx(X,X),\n! cmplx(1/X,0), cmplx(0,1/X), cmplx(1/X,1/X).\n!\n REAL CONX02\n!bc DATA CONX02 /0000006220426276611547B /\n!! DK DK DATA CONX02 / 2.708212596942E-1233 /\n DATA CONX02 / 2.708212596942E-30 /\n! .. Executable Statements ..\n X02ANE = CONX02\n return\n END\n INTEGER function X02BBE(X)\n! NAG COPYRIGHT 1975\n! MARK 4.5 RELEASE\n! MARK 11.5(F77) REVISED. (SEPT 1985.)\n! * MAXINT *\n! returnS THE LARGEST INTEGER REPRESENTABLE ON THE COMPUTER\n! THE X PARAMETER IS NOT USED\n! .. Scalar Arguments ..\n REAL X\n! .. Executable Statements ..\n! FOR ICL 1900\n! X02BBE = 8388607\n! DK DK DK X02BBE = 70368744177663\n X02BBE = 744177663\n return\n END\n INTEGER function X02BHE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE MODEL PARAMETER, B.\n!\n! .. Executable Statements ..\n X02BHE = 2\n return\n END\n INTEGER function X02BJE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE MODEL PARAMETER, p.\n!\n! .. Executable Statements ..\n X02BJE = 47\n return\n END\n INTEGER function X02BKE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE MODEL PARAMETER, EMIN.\n!\n! .. Executable Statements ..\n X02BKE = -8192\n return\n END\n INTEGER function X02BLE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE MODEL PARAMETER, EMAX.\n!\n! .. Executable Statements ..\n X02BLE = 8189\n return\n END\n subroutine X04AAE(I,NERR)\n! MARK 7 RELEASE. NAG COPYRIGHT 1978\n! MARK 7C REVISED IER-190 (MAY 1979)\n! MARK 11.5(F77) REVISED. (SEPT 1985.)\n! MARK 14 REVISED. IER-829 (DEC 1989).\n! IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER\n! (STORED IN NERR1).\n! IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO\n! VALUE SPECIFIED BY NERR.\n!\n! .. Scalar Arguments ..\n INTEGER I, NERR\n! .. Local Scalars ..\n INTEGER NERR1\n! .. Save statement ..\n SAVE NERR1\n! .. Data statements ..\n DATA NERR1/0/\n! .. Executable Statements ..\n if (I == 0) NERR = NERR1\n if (I == 1) NERR1 = NERR\n return\n END\n subroutine X04BAE(NOUT,REC)\n! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986.\n!\n! X04BAE writes the contents of REC to the unit defined by NOUT.\n!\n! Trailing blanks are not output, except that if REC is entirely\n! blank, a single blank character is output.\n! If NOUT < 0, i.e. if NOUT is not a valid Fortran unit identifier,\n! then no output occurs.\n!\n! .. Scalar Arguments ..\n INTEGER NOUT\n CHARACTER*(*) REC\n! .. Local Scalars ..\n INTEGER I\n! .. Intrinsic functions ..\n INTRINSIC LEN\n! .. Executable Statements ..\n if (NOUT >= 0) then\n! Remove trailing blanks\n DO 20 I = LEN(REC), 2, -1\n if (REC(I:I) /= ' ') goto 40\n 20 continue\n! Write record to external file\n 40 WRITE (NOUT,FMT=99999) REC(1:I)\n endif\n return\n!\n 99999 FORMAT (A)\n END\n\n" }, { "path": "analytical_solution_viscoelastic_2D_plane_strain_Carcione_correct_with_1_over_L.f90", "content": "\n program analytical_solution\n\n!! DK DK we compute the solution for velocity instead of for displacement in this version of the analytical code.\n\n! This program implements the analytical solution for the velocity vector in a 2D plane-strain viscoelastic medium\n! with a vertical force source located in (0,0),\n! from Appendix B of Carcione et al., Wave propagation simulation in a linear viscoelastic medium, GJI, vol. 95, p. 597-611 (1988)\n! (note that that Appendix contains two typos, fixed in this code; I added two comments below to mention them).\n! The amplitude of the force is called F and is defined below.\n\n implicit none\n\n!! DK DK May 2018: the missing 1/L factor in older Carcione papers\n!! DK DK May 2018: has been added to this code by Quentin Brissaud and by Etienne Bachmann\n!! DK DK for the viscoacoustic code in directory EXAMPLES/attenuation/viscoacoustic,\n!! DK DK it would be very easy to copy the changes from there to this viscoelastic version;\n!! DK DK but then all the values of the tau_epsilon in the code below would need to change.\n\n!! DK DK Dimitri Komatitsch, CNRS Marseille, France, April 2017: added the elastic reference calculation.\n\n! compute the non-viscoacoustic case as a reference if needed, i.e. turn attenuation off\n logical, parameter :: TURN_ATTENUATION_OFF = .false.\n\n! to see how small the contribution of the near-field term is,\n! here the user can ask not to include it, to then compare with the full result obtained with this flag set to false\n logical, parameter :: DO_NOT_COMPUTE_THE_NEAR_FIELD = .false.\n\n integer, parameter :: iratio = 64\n\n integer, parameter :: nfreq = 524288\n integer, parameter :: nt = iratio * nfreq\n\n double precision, parameter :: freqmax = 400.d0\n!! DK DK to print the velocity if we want to display the curve of how velocity varies with frequency\n!! DK DK for instance to compute the unrelaxed velocity in the Zener model\n! double precision, parameter :: freqmax = 20000.d0\n\n double precision, parameter :: freqseuil = 0.00005d0\n\n double precision, parameter :: pi = 3.141592653589793d0\n\n! for the solution in time domain\n integer it,i\n real wsave(4*nt+15)\n complex c(nt)\n\n!! DK DK for my slow inverse Discrete Fourier Transform using a double loop\n complex :: input(nt), i_imaginary_constant\n integer :: j,m\n\n! density of the medium\n double precision, parameter :: rho = 2000.d0\n\n! unrelaxed (f = +infinity) values\n! these values for the unrelaxed state are computed from the relaxed state values (Vp = 3000, Vs = 2000, rho = 2000)\n! given in Carcione et al. 1988 GJI vol 95 p 604 Table 1\n double precision, parameter :: Vp = 2000.d0\n double precision, parameter :: Vs = Vp / 1.732d0\n\n! unrelaxed (f = +infinity) values, i.e. using the fastest Vp and Vs velocities\n double precision, parameter :: M2_unrelaxed = Vs**2 * 2.d0 * rho\n double precision, parameter :: M1_unrelaxed = 2.d0 * Vp**2 * rho - M2_unrelaxed\n\n! amplitude of the force source\n double precision, parameter :: F = 1.d0\n\n! definition position recepteur Carcione\n double precision x1,x2\n\n! Definition source Dimitri\n double precision, parameter :: f0 = 35.d0\n double precision, parameter :: t0 = 1.2d0 / f0\n\n! Definition source Carcione\n! double precision f0,t0,eta,epsil\n! parameter(f0 = 50.d0)\n! parameter(t0 = 0.075d0)\n! parameter(epsil = 1.d0)\n! parameter(eta = 0.5d0)\n\n! number of Zener standard linear solids in parallel\n integer, parameter :: Lnu = 3\n\n! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform\n! DK DK at some point, for verification, using a double loop. I keep it just in case.\n! DK DK For large number of points it is extremely slow because of the double loop.\n! DK DK Thus there is no reason to turn this flag on.\n logical, parameter :: USE_SLOW_FOURIER_TRANSFORM = .false.\n\n!! DK DK March 2018: this missing 1/L factor has been added to this code by Quentin Brissaud\n!! DK DK for the viscoacoustic code in directory EXAMPLES/attenuation/viscoacoustic,\n!! DK DK it would be very easy to copy the changes from there to this viscoelastic version;\n!! DK DK but then all the values of the tau_epsilon below would need to change.\n\n double precision, dimension(Lnu) :: tau_sigma_nu1,tau_sigma_nu2,tau_epsilon_nu1,tau_epsilon_nu2\n\n integer :: ifreq,icalculation\n double precision :: deltafreq,freq,omega,omega0,deltat,time,a\n double complex :: comparg\n\n! Fourier transform of the Ricker wavelet source\n double complex fomega(0:nfreq)\n\n! real and imaginary parts\n double precision ra(0:nfreq),rb(0:nfreq)\n\n! spectral amplitude\n double precision ampli(0:nfreq)\n\n! analytical solution for the two components\n double complex phi1(-nfreq:nfreq)\n double complex phi2(-nfreq:nfreq)\n\n! external functions\n double complex, external :: u1,u2\n\n! modules elastiques\n double complex :: M1C, M2C, E, V1, V2, temp\n\n! ********** end of variable declarations ************\n\n! classical least-squares constants\n tau_epsilon_nu1 = (/ 2.408158185753685d-002, 4.699608990861351d-003, 9.567997872435925d-004 /)\n tau_sigma_nu1 = (/ 2.256014638636808d-002, 4.508471279712252d-003, 8.937876403768840d-004 /)\n\n tau_epsilon_nu2 = (/ 2.430544480527216d-002, 4.728107829226396d-003, 9.667252695863502d-004 /)\n tau_sigma_nu2 = (/ 2.250919779429490d-002, 4.501388007338097d-003, 8.917332095369118d-004 /)\n\n! do the calculation twice, because in the finite-difference code that we want to check using this analytical code\n! the Vy component is staggered half a grid cell away from Vx, thus to compute the analytical solution we need\n! to slightly change the location at which the calculation is done when computing the second component,\n! by half a grid cell\n do icalculation = 1,2\n\n! position of the receiver\n if (icalculation == 1) then\n x1 = +801. - 1.5/2.\n x2 = +801. - 1.5/2.\n else if (icalculation == 2) then\n x1 = +801.\n x2 = +801.\n else\n stop 'wrong value of icalculation'\n endif\n\n print *,'Force source located at the origin (0,0)'\n print *,'Receiver located in (x,z) = ',x1,x2\n\n if (TURN_ATTENUATION_OFF) then\n print *,'BEWARE: computing the elastic reference solution (i.e., without attenuation) instead of the viscoelastic solution'\n else\n print *,'Computing the viscoelastic solution'\n endif\n\n if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then\n print *,'BEWARE: computing the far-field solution only, rather than the full Green function'\n else\n print *,'Computing the full solution, including the near-field term of the Green function'\n endif\n\n! step in frequency\n deltafreq = freqmax / dble(nfreq)\n\n! define parameters for the Ricker source\n omega0 = 2.d0 * pi * f0\n a = pi**2 * f0**2\n\n deltat = 1.d0 / (freqmax*dble(iratio))\n\n! define the spectrum of the source\n do ifreq=0,nfreq\n freq = deltafreq * dble(ifreq)\n omega = 2.d0 * pi * freq\n\n! typo in equation (B7) of Carcione et al., Wave propagation simulation in a linear viscoelastic medium,\n! Geophysical Journal, vol. 95, p. 597-611 (1988), the exponential should be of -i omega t0,\n! fixed here by adding the minus sign\n comparg = dcmplx(0.d0,-omega*t0)\n\n! definir le spectre du Ricker de Carcione avec cos()\n! equation (B7) of Carcione et al., Wave propagation simulation in a linear viscoelastic medium,\n! Geophysical Journal, vol. 95, p. 597-611 (1988)\n! fomega(ifreq) = pi * dsqrt(pi/eta) * (1.d0/omega0) * cdexp(comparg) * ( dexp(- (pi*pi/eta) * (epsil/2 - omega/omega0)**2) &\n! + dexp(- (pi*pi/eta) * (epsil/2 + omega/omega0)**2) )\n\n! definir le spectre d'un Ricker classique (centre en t0)\n fomega(ifreq) = dsqrt(pi) * cdexp(comparg) * omega**2 * dexp(-omega**2/(4.d0*a)) / (2.d0 * dsqrt(a**3))\n!! DK DK multiply by i omega in order to get the solution for velocity instead of for displacement\n fomega(ifreq) = fomega(ifreq) * dcmplx(0.d0,omega)\n\n ra(ifreq) = dreal(fomega(ifreq))\n rb(ifreq) = dimag(fomega(ifreq))\n! prendre le module de l'amplitude spectrale\n ampli(ifreq) = dsqrt(ra(ifreq)**2 + rb(ifreq)**2)\n enddo\n\n! sauvegarde du spectre d'amplitude de la source en Hz au format Gnuplot\n open(unit=10,file='spectrum_of_the_source_used.gnu',status='unknown')\n do ifreq = 0,nfreq\n freq = deltafreq * dble(ifreq)\n write(10,*) sngl(freq),sngl(ampli(ifreq))\n enddo\n close(10)\n\n! ************** calcul solution analytique ****************\n\n! d'apres Carcione GJI vol 95 p 611 (1988)\n do ifreq=0,nfreq\n freq = deltafreq * dble(ifreq)\n omega = 2.d0 * pi * freq\n\n! critere ad-hoc pour eviter singularite en zero\n if (freq < freqseuil) omega = 2.d0 * pi * freqseuil\n\n! use standard infinite frequency (unrelaxed) reference,\n! in which waves slow down when attenuation is turned on.\n temp = dcmplx(0.d0,0.d0)\n do i=1,Lnu\n temp = temp + dcmplx(1.d0,omega*tau_epsilon_nu1(i)) / dcmplx(1.d0,omega*tau_sigma_nu1(i))\n enddo\n\n M1C = (M1_unrelaxed /(sum(tau_epsilon_nu1(:)/tau_sigma_nu1(:)))) * temp\n\n temp = dcmplx(0.d0,0.d0)\n do i=1,Lnu\n temp = temp + dcmplx(1.d0,omega*tau_epsilon_nu2(i)) / dcmplx(1.d0,omega*tau_sigma_nu2(i))\n enddo\n\n M2C = (M2_unrelaxed /(sum(tau_epsilon_nu2(:)/tau_sigma_nu2(:)))) * temp\n\n if (TURN_ATTENUATION_OFF) then\n! from Etienne Bachmann, May 2018: pour calculer la solution sans attenuation, il faut donner le Mu_unrelaxed et pas le Mu_relaxed.\n! En effet, pour comparer avec SPECFEM, il faut simplement partir de la bonne reference.\n! SPECFEM est defini en unrelaxed et les constantes unrelaxed dans Carcione matchent parfaitement les Vp et Vs definis dans SPECFEM.\n M1C = M1_unrelaxed\n M2C = M2_unrelaxed\n endif\n\n E = (M1C + M2C) / 2\n V1 = cdsqrt(E / rho) !! DK DK this is Vp\n!! DK DK print the velocity if we want to display the curve of how velocity varies with frequency\n!! DK DK for instance to compute the unrelaxed velocity in the Zener model\n! print *,freq,dsqrt(real(V1)**2 + imag(V1)**2)\n V2 = cdsqrt(M2C / (2.d0 * rho)) !! DK DK this is Vs\n!! DK DK print the velocity if we want to display the curve of how velocity varies with frequency\n!! DK DK for instance to compute the unrelaxed velocity in the Zener model\n! print *,freq,dsqrt(real(V2)**2 + imag(V2)**2)\n\n! calcul de la solution analytique en frequence\n phi1(ifreq) = u1(omega,V1,V2,x1,x2,rho,F,DO_NOT_COMPUTE_THE_NEAR_FIELD) * fomega(ifreq)\n phi2(ifreq) = u2(omega,V1,V2,x1,x2,rho,F,DO_NOT_COMPUTE_THE_NEAR_FIELD) * fomega(ifreq)\n\n enddo\n\n! take the conjugate value for negative frequencies\n do ifreq=-nfreq,-1\n phi1(ifreq) = dconjg(phi1(-ifreq))\n phi2(ifreq) = dconjg(phi2(-ifreq))\n enddo\n\n! save the result in the frequency domain\n! open(unit=11,file='cmplx_phi',status='unknown')\n! do ifreq=-nfreq,nfreq\n! freq = deltafreq * dble(ifreq)\n! write(11,*) sngl(freq),sngl(dreal(phi1(ifreq))),sngl(dimag(phi1(ifreq))),sngl(dreal(phi2(ifreq))),sngl(dimag(phi2(ifreq)))\n! enddo\n! close(11)\n\n! ***************************************************************************\n! Calculation of the time domain solution (using routine \"cfftb\" from Netlib)\n! ***************************************************************************\n\n! **********\n! Compute Vx\n! **********\n\n if (icalculation == 1) then\n\n! initialize FFT arrays\n call cffti(nt,wsave)\n\n! clear array of Fourier coefficients\n do it = 1,nt\n c(it) = cmplx(0.,0.)\n enddo\n\n! use the Fourier values for Vx\n c(1) = cmplx(phi1(0))\n do ifreq=1,nfreq-2\n c(ifreq+1) = cmplx(phi1(ifreq))\n c(nt+1-ifreq) = conjg(cmplx(phi1(ifreq)))\n enddo\n\n! perform the inverse FFT for Vx\n if (.not. USE_SLOW_FOURIER_TRANSFORM) then\n call cfftb(nt,c,wsave)\n else\n! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform here\n! DK DK at some point, for verification, using a double loop. I keep it just in case.\n! DK DK For large number of points it is extremely slow because of the double loop.\n input(:) = c(:)\n! imaginary constant \"i\"\n i_imaginary_constant = (0.,1.)\n do it = 1,nt\n if (mod(it,1000) == 0) print *,'FFT inverse it = ',it,' out of ',nt\n j = it\n c(j) = cmplx(0.,0.)\n do m = 1,nt\n c(j) = c(j) + input(m) * exp(2.d0 * PI * i_imaginary_constant * dble((m-1) * (j-1)) / nt)\n enddo\n enddo\n endif\n\n! in the inverse Discrete Fourier transform one needs to divide by N, the number of samples (number of time steps here)\n c(:) = c(:) / nt\n\n! value of a time step\n deltat = 1.d0 / (freqmax*dble(iratio))\n\n! to get the amplitude right, we need to divide by the time step\n c(:) = c(:) / deltat\n\n! save time result inverse FFT for Vx\n\n if (TURN_ATTENUATION_OFF) then\n if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then\n open(unit=11,file='Vx_time_analytical_solution_elastic_without_near_field.dat',status='unknown')\n else\n open(unit=11,file='Vx_time_analytical_solution_elastic.dat',status='unknown')\n endif\n else\n if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then\n open(unit=11,file='Vx_time_analytical_solution_viscoelastic_without_near_field.dat',status='unknown')\n else\n open(unit=11,file='Vx_time_analytical_solution_viscoelastic.dat',status='unknown')\n endif\n endif\n do it=1,nt\n! DK DK Dec 2011: subtract t0 to be consistent with the SPECFEM2D code\n time = dble(it-1)*deltat - t0\n! the seismograms are very long due to the very large number of FFT points used,\n! thus keeping the useful part of the signal only (the first six seconds of the seismogram)\n if (time >= 0.d0 .and. time <= 6.d0) write(11,*) sngl(time),real(c(it))\n enddo\n close(11)\n\n endif ! of if (icalculation == 1) then\n\n! **********\n! Compute Vz\n! **********\n\n if (icalculation == 2) then\n\n! clear array of Fourier coefficients\n do it = 1,nt\n c(it) = cmplx(0.,0.)\n enddo\n\n! use the Fourier values for Vz\n c(1) = cmplx(phi2(0))\n do ifreq=1,nfreq-2\n c(ifreq+1) = cmplx(phi2(ifreq))\n c(nt+1-ifreq) = conjg(cmplx(phi2(ifreq)))\n enddo\n\n! perform the inverse FFT for Vz\n if (.not. USE_SLOW_FOURIER_TRANSFORM) then\n call cfftb(nt,c,wsave)\n else\n! DK DK I implemented a very simple and slow inverse Discrete Fourier Transform here\n! DK DK at some point, for verification, using a double loop. I keep it just in case.\n! DK DK For large number of points it is extremely slow because of the double loop.\n input(:) = c(:)\n! imaginary constant \"i\"\n i_imaginary_constant = (0.,1.)\n do it = 1,nt\n if (mod(it,1000) == 0) print *,'FFT inverse it = ',it,' out of ',nt\n j = it\n c(j) = cmplx(0.,0.)\n do m = 1,nt\n c(j) = c(j) + input(m) * exp(2.d0 * PI * i_imaginary_constant * dble((m-1) * (j-1)) / nt)\n enddo\n enddo\n endif\n\n! in the inverse Discrete Fourier transform one needs to divide by N, the number of samples (number of time steps here)\n c(:) = c(:) / nt\n\n! value of a time step\n deltat = 1.d0 / (freqmax*dble(iratio))\n\n! to get the amplitude right, we need to divide by the time step\n c(:) = c(:) / deltat\n\n! save time result inverse FFT for Vz\n if (TURN_ATTENUATION_OFF) then\n if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then\n open(unit=11,file='Vz_time_analytical_solution_elastic_without_near_field.dat',status='unknown')\n else\n open(unit=11,file='Vz_time_analytical_solution_elastic.dat',status='unknown')\n endif\n else\n if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then\n open(unit=11,file='Vz_time_analytical_solution_viscoelastic_without_near_field.dat',status='unknown')\n else\n open(unit=11,file='Vz_time_analytical_solution_viscoelastic.dat',status='unknown')\n endif\n endif\n do it=1,nt\n! DK DK Dec 2011: subtract t0 to be consistent with the SPECFEM2D code\n time = dble(it-1)*deltat - t0\n! the seismograms are very long due to the very large number of FFT points used,\n! thus keeping the useful part of the signal only (the first six seconds of the seismogram)\n if (time >= 0.d0 .and. time <= 6.d0) write(11,*) sngl(time),real(c(it))\n enddo\n close(11)\n\n endif ! of if (icalculation == 2) then\n\n enddo ! of do icalculation = 1,2\n\n end\n\n! -----------\n\n double complex function u1(omega,v1,v2,x1,x2,rho,F,DO_NOT_COMPUTE_THE_NEAR_FIELD)\n\n implicit none\n\n double precision omega\n double complex v1,v2\n\n logical :: DO_NOT_COMPUTE_THE_NEAR_FIELD\n\n double complex G1,G2\n external G1,G2\n\n double precision, parameter :: pi = 3.141592653589793d0\n\n! amplitude of the force\n double precision F\n\n double precision x1,x2,r,rho\n\n! source-receiver distance\n r = dsqrt(x1**2 + x2**2)\n\n u1 = F * x1 * x2 * (G1(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD) + &\n G2(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD)) / (2.d0 * pi * rho * r**2)\n\n end\n\n! -----------\n\n double complex function u2(omega,v1,v2,x1,x2,rho,F,DO_NOT_COMPUTE_THE_NEAR_FIELD)\n\n implicit none\n\n double precision omega\n double complex v1,v2\n\n logical :: DO_NOT_COMPUTE_THE_NEAR_FIELD\n\n double complex G1,G2\n external G1,G2\n\n double precision, parameter :: pi = 3.141592653589793d0\n\n! amplitude of the force\n double precision F\n\n double precision x1,x2,r,rho\n\n! source-receiver distance\n r = dsqrt(x1**2 + x2**2)\n\n u2 = F * (x2*x2*G1(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD) - &\n x1*x1*G2(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD)) / (2.d0 * pi * rho * r**2)\n\n end\n\n! -----------\n\n double complex function G1(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD)\n\n implicit none\n\n double precision r,omega\n double complex v1,v2\n\n logical :: DO_NOT_COMPUTE_THE_NEAR_FIELD\n\n double complex hankel0,hankel1\n external hankel0,hankel1\n\n double precision, parameter :: pi = 3.141592653589793d0\n\n! typo in equations (B4a) and (B4b) of Carcione et al., Wave propagation simulation in a linear viscoelastic medium,\n! Geophysical Journal, vol. 95, p. 597-611 (1988), fixed here: omega/(r*v) -> omega*r/v\n\n if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then\n G1 = (hankel0(omega*r/v1)/(v1**2)) * dcmplx(0.d0,-pi/2.d0)\n else\n 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)\n endif\n\n end\n\n! -----------\n\n double complex function G2(r,omega,v1,v2,DO_NOT_COMPUTE_THE_NEAR_FIELD)\n\n implicit none\n\n double precision r,omega\n double complex v1,v2\n\n logical :: DO_NOT_COMPUTE_THE_NEAR_FIELD\n\n double complex hankel0,hankel1\n external hankel0,hankel1\n\n double precision, parameter :: pi = 3.141592653589793d0\n\n! typo in equations (B4a) and (B4b) of Carcione et al., Wave propagation simulation in a linear viscoelastic medium,\n! Geophysical Journal, vol. 95, p. 597-611 (1988), fixed here: omega/(r*v) -> omega*r/v\n\n if (DO_NOT_COMPUTE_THE_NEAR_FIELD) then\n G2 = (hankel0(omega*r/v2)/(v2**2)) * dcmplx(0.d0,+pi/2.d0)\n else\n 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)\n endif\n\n end\n\n! -----------\n\n double complex function hankel0(z)\n\n implicit none\n\n double complex z\n\n! on utilise la routine NAG appelee S17DLE (simple precision)\n\n integer ifail,nz\n complex result\n\n ifail = -1\n call S17DLE(2,0.0,cmplx(z),1,'U',result,nz,ifail)\n if (ifail /= 0) stop 'S17DLE failed in hankel0'\n if (nz > 0) print *,nz,' termes mis a zero par underflow'\n\n hankel0 = dcmplx(result)\n\n end\n\n! -----------\n\n double complex function hankel1(z)\n\n implicit none\n\n double complex z\n\n! on utilise la routine NAG appelee S17DLE (simple precision)\n\n integer ifail,nz\n complex result\n\n ifail = -1\n call S17DLE(2,1.0,cmplx(z),1,'U',result,nz,ifail)\n if (ifail /= 0) stop 'S17DLE failed in hankel1'\n if (nz > 0) print *,nz,' termes mis a zero par underflow'\n\n hankel1 = dcmplx(result)\n\n end\n\n! ***************** routine de FFT pour signal en temps ****************\n\n! FFT routine taken from Netlib\n\n subroutine CFFTB (N,C,WSAVE)\n DIMENSION C(1) ,WSAVE(1)\n if (N == 1) return\n IW1 = N+N+1\n IW2 = IW1+N+N\n CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))\n return\n END\n subroutine CFFTB1 (N,C,CH,WA,IFAC)\n DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1)\n NF = IFAC(2)\n NA = 0\n L1 = 1\n IW = 1\n DO 116 K1=1,NF\n IP = IFAC(K1+2)\n L2 = IP*L1\n IDO = N/L2\n IDOT = IDO+IDO\n IDL1 = IDOT*L1\n if (IP /= 4) goto 103\n IX2 = IW+IDOT\n IX3 = IX2+IDOT\n if (NA /= 0) goto 101\n CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))\n goto 102\n 101 CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))\n 102 NA = 1-NA\n goto 115\n 103 if (IP /= 2) goto 106\n if (NA /= 0) goto 104\n CALL PASSB2 (IDOT,L1,C,CH,WA(IW))\n goto 105\n 104 CALL PASSB2 (IDOT,L1,CH,C,WA(IW))\n 105 NA = 1-NA\n goto 115\n 106 if (IP /= 3) goto 109\n IX2 = IW+IDOT\n if (NA /= 0) goto 107\n CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2))\n goto 108\n 107 CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2))\n 108 NA = 1-NA\n goto 115\n 109 if (IP /= 5) goto 112\n IX2 = IW+IDOT\n IX3 = IX2+IDOT\n IX4 = IX3+IDOT\n if (NA /= 0) goto 110\n CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))\n goto 111\n 110 CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))\n 111 NA = 1-NA\n goto 115\n 112 if (NA /= 0) goto 113\n CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))\n goto 114\n 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))\n 114 if (NAC /= 0) NA = 1-NA\n 115 L1 = L2\n IW = IW+(IP-1)*IDOT\n 116 continue\n if (NA == 0) return\n N2 = N+N\n DO 117 I=1,N2\n C(I) = CH(I)\n 117 continue\n return\n END\n subroutine PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)\n DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1), &\n C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), &\n CH2(IDL1,IP)\n IDOT = IDO/2\n NT = IP*IDL1\n IPP2 = IP+2\n IPPH = (IP+1)/2\n IDP = IP*IDO\n!\n if (IDO < L1) goto 106\n DO 103 J=2,IPPH\n JC = IPP2-J\n DO 102 K=1,L1\n DO 101 I=1,IDO\n CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)\n CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)\n 101 continue\n 102 continue\n 103 continue\n DO 105 K=1,L1\n DO 104 I=1,IDO\n CH(I,K,1) = CC(I,1,K)\n 104 continue\n 105 continue\n goto 112\n 106 DO 109 J=2,IPPH\n JC = IPP2-J\n DO 108 I=1,IDO\n DO 107 K=1,L1\n CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)\n CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)\n 107 continue\n 108 continue\n 109 continue\n DO 111 I=1,IDO\n DO 110 K=1,L1\n CH(I,K,1) = CC(I,1,K)\n 110 continue\n 111 continue\n 112 IDL = 2-IDO\n INC = 0\n DO 116 L=2,IPPH\n LC = IPP2-L\n IDL = IDL+IDO\n DO 113 IK=1,IDL1\n C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)\n C2(IK,LC) = WA(IDL)*CH2(IK,IP)\n 113 continue\n IDLJ = IDL\n INC = INC+IDO\n DO 115 J=3,IPPH\n JC = IPP2-J\n IDLJ = IDLJ+INC\n if (IDLJ > IDP) IDLJ = IDLJ-IDP\n WAR = WA(IDLJ-1)\n WAI = WA(IDLJ)\n DO 114 IK=1,IDL1\n C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)\n C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)\n 114 continue\n 115 continue\n 116 continue\n DO 118 J=2,IPPH\n DO 117 IK=1,IDL1\n CH2(IK,1) = CH2(IK,1)+CH2(IK,J)\n 117 continue\n 118 continue\n DO 120 J=2,IPPH\n JC = IPP2-J\n DO 119 IK=2,IDL1,2\n CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)\n CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)\n CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)\n CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)\n 119 continue\n 120 continue\n NAC = 1\n if (IDO == 2) return\n NAC = 0\n DO 121 IK=1,IDL1\n C2(IK,1) = CH2(IK,1)\n 121 continue\n DO 123 J=2,IP\n DO 122 K=1,L1\n C1(1,K,J) = CH(1,K,J)\n C1(2,K,J) = CH(2,K,J)\n 122 continue\n 123 continue\n if (IDOT > L1) goto 127\n IDIJ = 0\n DO 126 J=2,IP\n IDIJ = IDIJ+2\n DO 125 I=4,IDO,2\n IDIJ = IDIJ+2\n DO 124 K=1,L1\n C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)\n C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)\n 124 continue\n 125 continue\n 126 continue\n return\n 127 IDJ = 2-IDO\n DO 130 J=2,IP\n IDJ = IDJ+IDO\n DO 129 K=1,L1\n IDIJ = IDJ\n DO 128 I=4,IDO,2\n IDIJ = IDIJ+2\n C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)\n C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)\n 128 continue\n 129 continue\n 130 continue\n return\n END\n subroutine PASSB2 (IDO,L1,CC,CH,WA1)\n DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2), &\n WA1(1)\n if (IDO > 2) goto 102\n DO 101 K=1,L1\n CH(1,K,1) = CC(1,1,K)+CC(1,2,K)\n CH(1,K,2) = CC(1,1,K)-CC(1,2,K)\n CH(2,K,1) = CC(2,1,K)+CC(2,2,K)\n CH(2,K,2) = CC(2,1,K)-CC(2,2,K)\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)\n TR2 = CC(I-1,1,K)-CC(I-1,2,K)\n CH(I,K,1) = CC(I,1,K)+CC(I,2,K)\n TI2 = CC(I,1,K)-CC(I,2,K)\n CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2\n CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2\n 103 continue\n 104 continue\n return\n END\n subroutine PASSB3 (IDO,L1,CC,CH,WA1,WA2)\n DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3), &\n WA1(1) ,WA2(1)\n DATA TAUR,TAUI /-.5,.866025403784439/\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TR2 = CC(1,2,K)+CC(1,3,K)\n CR2 = CC(1,1,K)+TAUR*TR2\n CH(1,K,1) = CC(1,1,K)+TR2\n TI2 = CC(2,2,K)+CC(2,3,K)\n CI2 = CC(2,1,K)+TAUR*TI2\n CH(2,K,1) = CC(2,1,K)+TI2\n CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))\n CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))\n CH(1,K,2) = CR2-CI3\n CH(1,K,3) = CR2+CI3\n CH(2,K,2) = CI2+CR3\n CH(2,K,3) = CI2-CR3\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TR2 = CC(I-1,2,K)+CC(I-1,3,K)\n CR2 = CC(I-1,1,K)+TAUR*TR2\n CH(I-1,K,1) = CC(I-1,1,K)+TR2\n TI2 = CC(I,2,K)+CC(I,3,K)\n CI2 = CC(I,1,K)+TAUR*TI2\n CH(I,K,1) = CC(I,1,K)+TI2\n CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))\n CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))\n DR2 = CR2-CI3\n DR3 = CR2+CI3\n DI2 = CI2+CR3\n DI3 = CI2-CR3\n CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2\n CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2\n CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3\n CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3\n 103 continue\n 104 continue\n return\n END\n subroutine PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3)\n DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4), &\n WA1(1) ,WA2(1) ,WA3(1)\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TI1 = CC(2,1,K)-CC(2,3,K)\n TI2 = CC(2,1,K)+CC(2,3,K)\n TR4 = CC(2,4,K)-CC(2,2,K)\n TI3 = CC(2,2,K)+CC(2,4,K)\n TR1 = CC(1,1,K)-CC(1,3,K)\n TR2 = CC(1,1,K)+CC(1,3,K)\n TI4 = CC(1,2,K)-CC(1,4,K)\n TR3 = CC(1,2,K)+CC(1,4,K)\n CH(1,K,1) = TR2+TR3\n CH(1,K,3) = TR2-TR3\n CH(2,K,1) = TI2+TI3\n CH(2,K,3) = TI2-TI3\n CH(1,K,2) = TR1+TR4\n CH(1,K,4) = TR1-TR4\n CH(2,K,2) = TI1+TI4\n CH(2,K,4) = TI1-TI4\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TI1 = CC(I,1,K)-CC(I,3,K)\n TI2 = CC(I,1,K)+CC(I,3,K)\n TI3 = CC(I,2,K)+CC(I,4,K)\n TR4 = CC(I,4,K)-CC(I,2,K)\n TR1 = CC(I-1,1,K)-CC(I-1,3,K)\n TR2 = CC(I-1,1,K)+CC(I-1,3,K)\n TI4 = CC(I-1,2,K)-CC(I-1,4,K)\n TR3 = CC(I-1,2,K)+CC(I-1,4,K)\n CH(I-1,K,1) = TR2+TR3\n CR3 = TR2-TR3\n CH(I,K,1) = TI2+TI3\n CI3 = TI2-TI3\n CR2 = TR1+TR4\n CR4 = TR1-TR4\n CI2 = TI1+TI4\n CI4 = TI1-TI4\n CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2\n CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2\n CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3\n CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3\n CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4\n CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4\n 103 continue\n 104 continue\n return\n END\n subroutine PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)\n DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5), &\n WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)\n DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, &\n -.809016994374947,.587785252292473/\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TI5 = CC(2,2,K)-CC(2,5,K)\n TI2 = CC(2,2,K)+CC(2,5,K)\n TI4 = CC(2,3,K)-CC(2,4,K)\n TI3 = CC(2,3,K)+CC(2,4,K)\n TR5 = CC(1,2,K)-CC(1,5,K)\n TR2 = CC(1,2,K)+CC(1,5,K)\n TR4 = CC(1,3,K)-CC(1,4,K)\n TR3 = CC(1,3,K)+CC(1,4,K)\n CH(1,K,1) = CC(1,1,K)+TR2+TR3\n CH(2,K,1) = CC(2,1,K)+TI2+TI3\n CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3\n CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3\n CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3\n CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3\n CR5 = TI11*TR5+TI12*TR4\n CI5 = TI11*TI5+TI12*TI4\n CR4 = TI12*TR5-TI11*TR4\n CI4 = TI12*TI5-TI11*TI4\n CH(1,K,2) = CR2-CI5\n CH(1,K,5) = CR2+CI5\n CH(2,K,2) = CI2+CR5\n CH(2,K,3) = CI3+CR4\n CH(1,K,3) = CR3-CI4\n CH(1,K,4) = CR3+CI4\n CH(2,K,4) = CI3-CR4\n CH(2,K,5) = CI2-CR5\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TI5 = CC(I,2,K)-CC(I,5,K)\n TI2 = CC(I,2,K)+CC(I,5,K)\n TI4 = CC(I,3,K)-CC(I,4,K)\n TI3 = CC(I,3,K)+CC(I,4,K)\n TR5 = CC(I-1,2,K)-CC(I-1,5,K)\n TR2 = CC(I-1,2,K)+CC(I-1,5,K)\n TR4 = CC(I-1,3,K)-CC(I-1,4,K)\n TR3 = CC(I-1,3,K)+CC(I-1,4,K)\n CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3\n CH(I,K,1) = CC(I,1,K)+TI2+TI3\n CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3\n CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3\n CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3\n CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3\n CR5 = TI11*TR5+TI12*TR4\n CI5 = TI11*TI5+TI12*TI4\n CR4 = TI12*TR5-TI11*TR4\n CI4 = TI12*TI5-TI11*TI4\n DR3 = CR3-CI4\n DR4 = CR3+CI4\n DI3 = CI3+CR4\n DI4 = CI3-CR4\n DR5 = CR2+CI5\n DR2 = CR2-CI5\n DI5 = CI2-CR5\n DI2 = CI2+CR5\n CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2\n CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2\n CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3\n CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3\n CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4\n CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4\n CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5\n CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5\n 103 continue\n 104 continue\n return\n END\n\n\n\n subroutine CFFTI (N,WSAVE)\n DIMENSION WSAVE(1)\n if (N == 1) return\n IW1 = N+N+1\n IW2 = IW1+N+N\n CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2))\n return\n END\n subroutine CFFTI1 (N,WA,IFAC)\n DIMENSION WA(1) ,IFAC(1) ,NTRYH(4)\n DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/\n NL = N\n NF = 0\n J = 0\n 101 J = J+1\n if (J-4) 102,102,103\n 102 NTRY = NTRYH(J)\n goto 104\n 103 NTRY = NTRY+2\n 104 NQ = NL/NTRY\n NR = NL-NTRY*NQ\n if (NR) 101,105,101\n 105 NF = NF+1\n IFAC(NF+2) = NTRY\n NL = NQ\n if (NTRY /= 2) goto 107\n if (NF == 1) goto 107\n DO 106 I=2,NF\n IB = NF-I+2\n IFAC(IB+2) = IFAC(IB+1)\n 106 continue\n IFAC(3) = 2\n 107 if (NL /= 1) goto 104\n IFAC(1) = N\n IFAC(2) = NF\n TPI = 6.28318530717959\n ARGH = TPI/FLOAT(N)\n I = 2\n L1 = 1\n DO 110 K1=1,NF\n IP = IFAC(K1+2)\n LD = 0\n L2 = L1*IP\n IDO = N/L2\n IDOT = IDO+IDO+2\n IPM = IP-1\n DO 109 J=1,IPM\n I1 = I\n WA(I-1) = 1.\n WA(I) = 0.\n LD = LD+L1\n FI = 0.\n ARGLD = FLOAT(LD)*ARGH\n DO 108 II=4,IDOT,2\n I = I+2\n FI = FI+1.\n ARG = FI*ARGLD\n WA(I-1) = COS(ARG)\n WA(I) = SIN(ARG)\n 108 continue\n if (IP <= 5) goto 109\n WA(I1-1) = WA(I-1)\n WA(I1) = WA(I)\n 109 continue\n L1 = L2\n 110 continue\n return\n END\n\n\n\n\n\n subroutine CFFTF (N,C,WSAVE)\n DIMENSION C(1) ,WSAVE(1)\n if (N == 1) return\n IW1 = N+N+1\n IW2 = IW1+N+N\n CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))\n return\n END\n subroutine CFFTF1 (N,C,CH,WA,IFAC)\n DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1)\n NF = IFAC(2)\n NA = 0\n L1 = 1\n IW = 1\n DO 116 K1=1,NF\n IP = IFAC(K1+2)\n L2 = IP*L1\n IDO = N/L2\n IDOT = IDO+IDO\n IDL1 = IDOT*L1\n if (IP /= 4) goto 103\n IX2 = IW+IDOT\n IX3 = IX2+IDOT\n if (NA /= 0) goto 101\n CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))\n goto 102\n 101 CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))\n 102 NA = 1-NA\n goto 115\n 103 if (IP /= 2) goto 106\n if (NA /= 0) goto 104\n CALL PASSF2 (IDOT,L1,C,CH,WA(IW))\n goto 105\n 104 CALL PASSF2 (IDOT,L1,CH,C,WA(IW))\n 105 NA = 1-NA\n goto 115\n 106 if (IP /= 3) goto 109\n IX2 = IW+IDOT\n if (NA /= 0) goto 107\n CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))\n goto 108\n 107 CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))\n 108 NA = 1-NA\n goto 115\n 109 if (IP /= 5) goto 112\n IX2 = IW+IDOT\n IX3 = IX2+IDOT\n IX4 = IX3+IDOT\n if (NA /= 0) goto 110\n CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))\n goto 111\n 110 CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))\n 111 NA = 1-NA\n goto 115\n 112 if (NA /= 0) goto 113\n CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))\n goto 114\n 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))\n 114 if (NAC /= 0) NA = 1-NA\n 115 L1 = L2\n IW = IW+(IP-1)*IDOT\n 116 continue\n if (NA == 0) return\n N2 = N+N\n DO 117 I=1,N2\n C(I) = CH(I)\n 117 continue\n return\n END\n subroutine PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)\n DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1), &\n C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), &\n CH2(IDL1,IP)\n IDOT = IDO/2\n NT = IP*IDL1\n IPP2 = IP+2\n IPPH = (IP+1)/2\n IDP = IP*IDO\n!\n if (IDO < L1) goto 106\n DO 103 J=2,IPPH\n JC = IPP2-J\n DO 102 K=1,L1\n DO 101 I=1,IDO\n CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)\n CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)\n 101 continue\n 102 continue\n 103 continue\n DO 105 K=1,L1\n DO 104 I=1,IDO\n CH(I,K,1) = CC(I,1,K)\n 104 continue\n 105 continue\n goto 112\n 106 DO 109 J=2,IPPH\n JC = IPP2-J\n DO 108 I=1,IDO\n DO 107 K=1,L1\n CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)\n CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)\n 107 continue\n 108 continue\n 109 continue\n DO 111 I=1,IDO\n DO 110 K=1,L1\n CH(I,K,1) = CC(I,1,K)\n 110 continue\n 111 continue\n 112 IDL = 2-IDO\n INC = 0\n DO 116 L=2,IPPH\n LC = IPP2-L\n IDL = IDL+IDO\n DO 113 IK=1,IDL1\n C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)\n C2(IK,LC) = -WA(IDL)*CH2(IK,IP)\n 113 continue\n IDLJ = IDL\n INC = INC+IDO\n DO 115 J=3,IPPH\n JC = IPP2-J\n IDLJ = IDLJ+INC\n if (IDLJ > IDP) IDLJ = IDLJ-IDP\n WAR = WA(IDLJ-1)\n WAI = WA(IDLJ)\n DO 114 IK=1,IDL1\n C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)\n C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)\n 114 continue\n 115 continue\n 116 continue\n DO 118 J=2,IPPH\n DO 117 IK=1,IDL1\n CH2(IK,1) = CH2(IK,1)+CH2(IK,J)\n 117 continue\n 118 continue\n DO 120 J=2,IPPH\n JC = IPP2-J\n DO 119 IK=2,IDL1,2\n CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)\n CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)\n CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)\n CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)\n 119 continue\n 120 continue\n NAC = 1\n if (IDO == 2) return\n NAC = 0\n DO 121 IK=1,IDL1\n C2(IK,1) = CH2(IK,1)\n 121 continue\n DO 123 J=2,IP\n DO 122 K=1,L1\n C1(1,K,J) = CH(1,K,J)\n C1(2,K,J) = CH(2,K,J)\n 122 continue\n 123 continue\n if (IDOT > L1) goto 127\n IDIJ = 0\n DO 126 J=2,IP\n IDIJ = IDIJ+2\n DO 125 I=4,IDO,2\n IDIJ = IDIJ+2\n DO 124 K=1,L1\n C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)\n C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)\n 124 continue\n 125 continue\n 126 continue\n return\n 127 IDJ = 2-IDO\n DO 130 J=2,IP\n IDJ = IDJ+IDO\n DO 129 K=1,L1\n IDIJ = IDJ\n DO 128 I=4,IDO,2\n IDIJ = IDIJ+2\n C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)\n C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)\n 128 continue\n 129 continue\n 130 continue\n return\n END\n subroutine PASSF2 (IDO,L1,CC,CH,WA1)\n DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2), &\n WA1(1)\n if (IDO > 2) goto 102\n DO 101 K=1,L1\n CH(1,K,1) = CC(1,1,K)+CC(1,2,K)\n CH(1,K,2) = CC(1,1,K)-CC(1,2,K)\n CH(2,K,1) = CC(2,1,K)+CC(2,2,K)\n CH(2,K,2) = CC(2,1,K)-CC(2,2,K)\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)\n TR2 = CC(I-1,1,K)-CC(I-1,2,K)\n CH(I,K,1) = CC(I,1,K)+CC(I,2,K)\n TI2 = CC(I,1,K)-CC(I,2,K)\n CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2\n CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2\n 103 continue\n 104 continue\n return\n END\n subroutine PASSF3 (IDO,L1,CC,CH,WA1,WA2)\n DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3), &\n WA1(1) ,WA2(1)\n DATA TAUR,TAUI /-.5,-.866025403784439/\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TR2 = CC(1,2,K)+CC(1,3,K)\n CR2 = CC(1,1,K)+TAUR*TR2\n CH(1,K,1) = CC(1,1,K)+TR2\n TI2 = CC(2,2,K)+CC(2,3,K)\n CI2 = CC(2,1,K)+TAUR*TI2\n CH(2,K,1) = CC(2,1,K)+TI2\n CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))\n CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))\n CH(1,K,2) = CR2-CI3\n CH(1,K,3) = CR2+CI3\n CH(2,K,2) = CI2+CR3\n CH(2,K,3) = CI2-CR3\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TR2 = CC(I-1,2,K)+CC(I-1,3,K)\n CR2 = CC(I-1,1,K)+TAUR*TR2\n CH(I-1,K,1) = CC(I-1,1,K)+TR2\n TI2 = CC(I,2,K)+CC(I,3,K)\n CI2 = CC(I,1,K)+TAUR*TI2\n CH(I,K,1) = CC(I,1,K)+TI2\n CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))\n CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))\n DR2 = CR2-CI3\n DR3 = CR2+CI3\n DI2 = CI2+CR3\n DI3 = CI2-CR3\n CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2\n CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2\n CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3\n CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3\n 103 continue\n 104 continue\n return\n END\n subroutine PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3)\n DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4), &\n WA1(1) ,WA2(1) ,WA3(1)\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TI1 = CC(2,1,K)-CC(2,3,K)\n TI2 = CC(2,1,K)+CC(2,3,K)\n TR4 = CC(2,2,K)-CC(2,4,K)\n TI3 = CC(2,2,K)+CC(2,4,K)\n TR1 = CC(1,1,K)-CC(1,3,K)\n TR2 = CC(1,1,K)+CC(1,3,K)\n TI4 = CC(1,4,K)-CC(1,2,K)\n TR3 = CC(1,2,K)+CC(1,4,K)\n CH(1,K,1) = TR2+TR3\n CH(1,K,3) = TR2-TR3\n CH(2,K,1) = TI2+TI3\n CH(2,K,3) = TI2-TI3\n CH(1,K,2) = TR1+TR4\n CH(1,K,4) = TR1-TR4\n CH(2,K,2) = TI1+TI4\n CH(2,K,4) = TI1-TI4\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TI1 = CC(I,1,K)-CC(I,3,K)\n TI2 = CC(I,1,K)+CC(I,3,K)\n TI3 = CC(I,2,K)+CC(I,4,K)\n TR4 = CC(I,2,K)-CC(I,4,K)\n TR1 = CC(I-1,1,K)-CC(I-1,3,K)\n TR2 = CC(I-1,1,K)+CC(I-1,3,K)\n TI4 = CC(I-1,4,K)-CC(I-1,2,K)\n TR3 = CC(I-1,2,K)+CC(I-1,4,K)\n CH(I-1,K,1) = TR2+TR3\n CR3 = TR2-TR3\n CH(I,K,1) = TI2+TI3\n CI3 = TI2-TI3\n CR2 = TR1+TR4\n CR4 = TR1-TR4\n CI2 = TI1+TI4\n CI4 = TI1-TI4\n CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2\n CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2\n CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3\n CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3\n CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4\n CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4\n 103 continue\n 104 continue\n return\n END\n subroutine PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)\n DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5), &\n WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)\n DATA TR11,TI11,TR12,TI12 /.309016994374947,-.951056516295154, &\n -.809016994374947,-.587785252292473/\n if (IDO /= 2) goto 102\n DO 101 K=1,L1\n TI5 = CC(2,2,K)-CC(2,5,K)\n TI2 = CC(2,2,K)+CC(2,5,K)\n TI4 = CC(2,3,K)-CC(2,4,K)\n TI3 = CC(2,3,K)+CC(2,4,K)\n TR5 = CC(1,2,K)-CC(1,5,K)\n TR2 = CC(1,2,K)+CC(1,5,K)\n TR4 = CC(1,3,K)-CC(1,4,K)\n TR3 = CC(1,3,K)+CC(1,4,K)\n CH(1,K,1) = CC(1,1,K)+TR2+TR3\n CH(2,K,1) = CC(2,1,K)+TI2+TI3\n CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3\n CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3\n CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3\n CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3\n CR5 = TI11*TR5+TI12*TR4\n CI5 = TI11*TI5+TI12*TI4\n CR4 = TI12*TR5-TI11*TR4\n CI4 = TI12*TI5-TI11*TI4\n CH(1,K,2) = CR2-CI5\n CH(1,K,5) = CR2+CI5\n CH(2,K,2) = CI2+CR5\n CH(2,K,3) = CI3+CR4\n CH(1,K,3) = CR3-CI4\n CH(1,K,4) = CR3+CI4\n CH(2,K,4) = CI3-CR4\n CH(2,K,5) = CI2-CR5\n 101 continue\n return\n 102 DO 104 K=1,L1\n DO 103 I=2,IDO,2\n TI5 = CC(I,2,K)-CC(I,5,K)\n TI2 = CC(I,2,K)+CC(I,5,K)\n TI4 = CC(I,3,K)-CC(I,4,K)\n TI3 = CC(I,3,K)+CC(I,4,K)\n TR5 = CC(I-1,2,K)-CC(I-1,5,K)\n TR2 = CC(I-1,2,K)+CC(I-1,5,K)\n TR4 = CC(I-1,3,K)-CC(I-1,4,K)\n TR3 = CC(I-1,3,K)+CC(I-1,4,K)\n CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3\n CH(I,K,1) = CC(I,1,K)+TI2+TI3\n CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3\n CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3\n CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3\n CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3\n CR5 = TI11*TR5+TI12*TR4\n CI5 = TI11*TI5+TI12*TI4\n CR4 = TI12*TR5-TI11*TR4\n CI4 = TI12*TI5-TI11*TI4\n DR3 = CR3-CI4\n DR4 = CR3+CI4\n DI3 = CI3+CR4\n DI4 = CI3-CR4\n DR5 = CR2+CI5\n DR2 = CR2-CI5\n DI5 = CI2-CR5\n DI2 = CI2+CR5\n CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2\n CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2\n CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3\n CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3\n CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4\n CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4\n CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5\n CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5\n 103 continue\n 104 continue\n return\n END\n\n! !!!!!!!! DK DK NAG routines included below\n\n! DK DK march99 : routines recuperees sur le Cray (simple precision)\n\n subroutine ABZP01\n! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986.\n!\n! Terminates execution when a hard failure occurs.\n!\n! ******************** IMPLEMENTATION NOTE ********************\n! The following STOP statement may be replaced by a call to an\n! implementation-dependent routine to display a message and/or\n! to abort the program.\n! *************************************************************\n! .. Executable Statements ..\n STOP\n END\n\n subroutine DCYS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-785 (DEC 1989).\n!\n! Original name: CUNK2\n!\n! DCYS18 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE\n! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE\n! UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN)\n! WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR\n! -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT\n! HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC-\n! ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.\n! NZ=-1 MEANS AN OVERFLOW WILL OCCUR\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX AI, ARGD, ASUMD, BSUMD, C1, C2, CFN, CI, CK, &\n CONE, CR1, CR2, CRSC, CS, CSCL, CSGN, CSPN, &\n CZERO, DAI, PHID, RZ, S1, S2, ZB, ZETA1D, &\n ZETA2D, ZN, ZR\n REAL AARG, AIC, ANG, APHI, ASC, ASCLE, C2I, C2M, C2R, &\n CAR, CPN, FMR, FN, FNF, HPI, PI, RS1, SAR, SGN, &\n SPN, X, YY\n INTEGER I, IB, IC, IDUM, IFLAG, IFN, IL, IN, INU, IPARD, &\n IUF, J, K, KDFLG, KFLAG, KK, NAI, NDAI, NW\n! .. Local Arrays ..\n COMPLEX ARG(2), ASUM(2), BSUM(2), CIP(4), CSR(3), &\n CSS(3), CY(2), PHI(2), ZETA1(2), ZETA2(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEUS17, S17DGE, DGSS17, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, INT, LOG, &\n MAX, MOD, REAL, SIGN, SIN\n! .. Data statements ..\n DATA CZERO, CONE, CI, CR1, CR2/(0.0E0,0.0E0), &\n (1.0E0,0.0E0), (0.0E0,1.0E0), &\n (1.0E0,1.73205080756887729E0), &\n (-0.5E0,-8.66025403784438647E-01)/\n DATA HPI, PI, AIC/1.57079632679489662E+00, &\n 3.14159265358979324E+00, &\n 1.26551212348464539E+00/\n DATA CIP(1), CIP(2), CIP(3), CIP(4)/(1.0E0,0.0E0), &\n (0.0E0,-1.0E0), (-1.0E0,0.0E0), (0.0E0,1.0E0)/\n! .. Executable Statements ..\n!\n KDFLG = 1\n NZ = 0\n! ------------------------------------------------------------------\n! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN\n! THE UNDERFLOW LIMIT\n! ------------------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n X = REAL(Z)\n ZR = Z\n if (X < 0.0E0) ZR = -Z\n YY = AIMAG(ZR)\n ZN = -ZR*CI\n ZB = ZR\n INU = INT(FNU)\n FNF = FNU - INU\n ANG = -HPI*FNF\n CAR = COS(ANG)\n SAR = SIN(ANG)\n CPN = -HPI*CAR\n SPN = -HPI*SAR\n C2 = CMPLX(-SPN,CPN)\n KK = MOD(INU,4) + 1\n CS = CR1*C2*CIP(KK)\n if (YY <= 0.0E0) then\n ZN = CONJG(-ZN)\n ZB = CONJG(ZB)\n endif\n! ------------------------------------------------------------------\n! K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST\n! QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY\n! CONJUGATION SINCE THE K function IS REAL ON THE POSITIVE REAL AXIS\n! ------------------------------------------------------------------\n J = 2\n DO 40 I = 1, N\n! ---------------------------------------------------------------\n! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J\n! ---------------------------------------------------------------\n J = 3 - J\n FN = FNU + I - 1\n CALL DEUS17(ZN,FN,0,TOL,PHI(J),ARG(J),ZETA1(J),ZETA2(J),ASUM(J) &\n ,BSUM(J),ELIM)\n if (KODE == 1) then\n S1 = ZETA1(J) - ZETA2(J)\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = ZETA1(J) - CFN*(CFN/(ZB+ZETA2(J)))\n endif\n! ---------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ---------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (KDFLG == 1) KFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ---------------------------------------------------------\n! REFINE TEST AND SCALE\n! ---------------------------------------------------------\n APHI = ABS(PHI(J))\n AARG = ABS(ARG(J))\n RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC\n if (ABS(RS1) > ELIM) then\n goto 20\n ELSE\n if (KDFLG == 1) KFLAG = 1\n if (RS1 >= 0.0E0) then\n if (KDFLG == 1) KFLAG = 3\n endif\n endif\n endif\n! ------------------------------------------------------------\n! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR\n! EXPONENT EXTREMES\n! ------------------------------------------------------------\n C2 = ARG(J)*CR2\n IDUM = 1\n! S17DGE assumed not to fail, therefore IDUM set to one.\n CALL S17DGE('F',C2,'S',AI,NAI,IDUM)\n IDUM = 1\n CALL S17DGE('D',C2,'S',DAI,NDAI,IDUM)\n S2 = CS*PHI(J)*(AI*ASUM(J)+CR2*DAI*BSUM(J))\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(KFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (KFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) goto 20\n endif\n if (YY <= 0.0E0) S2 = CONJG(S2)\n CY(KDFLG) = S2\n Y(I) = S2*CSR(KFLAG)\n CS = -CI*CS\n if (KDFLG == 2) then\n goto 60\n ELSE\n KDFLG = 2\n goto 40\n endif\n endif\n 20 if (RS1 > 0.0E0) then\n goto 280\n! ------------------------------------------------------------\n! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW\n! ------------------------------------------------------------\n else if (X < 0.0E0) then\n goto 280\n ELSE\n KDFLG = 1\n Y(I) = CZERO\n CS = -CI*CS\n NZ = NZ + 1\n if (I /= 1) then\n if (Y(I-1) /= CZERO) then\n Y(I-1) = CZERO\n NZ = NZ + 1\n endif\n endif\n endif\n 40 continue\n I = N\n 60 RZ = CMPLX(2.0E0,0.0E0)/ZR\n CK = CMPLX(FN,0.0E0)*RZ\n IB = I + 1\n if (N >= IB) then\n! ---------------------------------------------------------------\n! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO\n! ZERO ON UNDERFLOW\n! ---------------------------------------------------------------\n FN = FNU + N - 1\n IPARD = 1\n if (MR /= 0) IPARD = 0\n CALL DEUS17(ZN,FN,IPARD,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD, &\n BSUMD,ELIM)\n if (KODE == 1) then\n S1 = ZETA1D - ZETA2D\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = ZETA1D - CFN*(CFN/(ZB+ZETA2D))\n endif\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (ABS(RS1) >= ALIM) then\n! ---------------------------------------------------------\n! REFINE ESTIMATE AND TEST\n! ---------------------------------------------------------\n APHI = ABS(PHID)\n AARG = ABS(ARGD)\n RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC\n if (ABS(RS1) >= ELIM) goto 100\n endif\n! ------------------------------------------------------------\n! SCALED FORWARD RECURRENCE FOR REMAINDER OF THE SEQUENCE\n! ------------------------------------------------------------\n S1 = CY(1)\n S2 = CY(2)\n C1 = CSR(KFLAG)\n ASCLE = BRY(KFLAG)\n DO 80 I = IB, N\n C2 = S2\n S2 = CK*S2 + S1\n S1 = C2\n CK = CK + RZ\n C2 = S2*C1\n Y(I) = C2\n if (KFLAG < 3) then\n C2R = REAL(C2)\n C2I = AIMAG(C2)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n KFLAG = KFLAG + 1\n ASCLE = BRY(KFLAG)\n S1 = S1*C1\n S2 = C2\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n C1 = CSR(KFLAG)\n endif\n endif\n 80 continue\n goto 140\n endif\n 100 if (RS1 > 0.0E0) then\n goto 280\n! ------------------------------------------------------------\n! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW\n! ------------------------------------------------------------\n else if (X < 0.0E0) then\n goto 280\n ELSE\n NZ = N\n DO 120 I = 1, N\n Y(I) = CZERO\n 120 continue\n return\n endif\n endif\n 140 if (MR == 0) then\n return\n ELSE\n! ---------------------------------------------------------------\n! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0\n! ---------------------------------------------------------------\n NZ = 0\n FMR = MR\n SGN = -SIGN(PI,FMR)\n! ---------------------------------------------------------------\n! CSPN AND CSGN ARE COEFF OF K AND I functionS RESP.\n! ---------------------------------------------------------------\n CSGN = CMPLX(0.0E0,SGN)\n if (YY <= 0.0E0) CSGN = CONJG(CSGN)\n IFN = INU + N - 1\n ANG = FNF*SGN\n CPN = COS(ANG)\n SPN = SIN(ANG)\n CSPN = CMPLX(CPN,SPN)\n if (MOD(IFN,2) == 1) CSPN = -CSPN\n! ---------------------------------------------------------------\n! CS=COEFF OF THE J function TO GET THE I function. I(FNU,Z) IS\n! COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE\n! FIRST QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE\n! COMPUTED BY CONJUGATION SINCE THE I function IS REAL ON THE\n! POSITIVE REAL AXIS\n! ---------------------------------------------------------------\n CS = CMPLX(CAR,-SAR)*CSGN\n IN = MOD(IFN,4) + 1\n C2 = CIP(IN)\n CS = CS*CONJG(C2)\n ASC = BRY(1)\n KK = N\n KDFLG = 1\n IB = IB - 1\n IC = IB - 1\n IUF = 0\n DO 220 K = 1, N\n! ------------------------------------------------------------\n! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K\n! function ABOVE\n! ------------------------------------------------------------\n FN = FNU + KK - 1\n if (N > 2) then\n if ((KK == N) .and. (IB < N)) then\n goto 160\n else if ((KK /= IB) .and. (KK /= IC)) then\n CALL DEUS17(ZN,FN,0,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD, &\n BSUMD,ELIM)\n goto 160\n endif\n endif\n PHID = PHI(J)\n ARGD = ARG(J)\n ZETA1D = ZETA1(J)\n ZETA2D = ZETA2(J)\n ASUMD = ASUM(J)\n BSUMD = BSUM(J)\n J = 3 - J\n 160 if (KODE == 1) then\n S1 = -ZETA1D + ZETA2D\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = -ZETA1D + CFN*(CFN/(ZB+ZETA2D))\n endif\n! ------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (KDFLG == 1) IFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ------------------------------------------------------\n! REFINE TEST AND SCALE\n! ------------------------------------------------------\n APHI = ABS(PHID)\n AARG = ABS(ARGD)\n RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC\n if (ABS(RS1) > ELIM) then\n goto 180\n ELSE\n if (KDFLG == 1) IFLAG = 1\n if (RS1 >= 0.0E0) then\n if (KDFLG == 1) IFLAG = 3\n endif\n endif\n endif\n IDUM = 1\n! S17DGE assumed not to fail, therefore IDUM set to one.\n CALL S17DGE('F',ARGD,'S',AI,NAI,IDUM)\n IDUM = 1\n CALL S17DGE('D',ARGD,'S',DAI,NDAI,IDUM)\n S2 = CS*PHID*(AI*ASUMD+DAI*BSUMD)\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(IFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (IFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0)\n endif\n goto 200\n endif\n 180 if (RS1 > 0.0E0) then\n goto 280\n ELSE\n S2 = CZERO\n endif\n 200 if (YY <= 0.0E0) S2 = CONJG(S2)\n CY(KDFLG) = S2\n C2 = S2\n S2 = S2*CSR(IFLAG)\n! ------------------------------------------------------------\n! ADD I AND K functionS, K SEQUENCE IN Y(I), I=1,N\n! ------------------------------------------------------------\n S1 = Y(KK)\n if (KODE /= 1) then\n CALL DGSS17(ZR,S1,S2,NW,ASC,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(KK) = S1*CSPN + S2\n KK = KK - 1\n CSPN = -CSPN\n CS = -CS*CI\n if (C2 == CZERO) then\n KDFLG = 1\n else if (KDFLG == 2) then\n goto 240\n ELSE\n KDFLG = 2\n endif\n 220 continue\n K = N\n 240 IL = N - K\n if (IL /= 0) then\n! ------------------------------------------------------------\n! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE\n! K functionS, SCALING THE I SEQUENCE DURING RECURRENCE TO\n! KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT\n! EXTREMES.\n! ------------------------------------------------------------\n S1 = CY(1)\n S2 = CY(2)\n CS = CSR(IFLAG)\n ASCLE = BRY(IFLAG)\n FN = INU + IL\n DO 260 I = 1, IL\n C2 = S2\n S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2\n S1 = C2\n FN = FN - 1.0E0\n C2 = S2*CS\n CK = C2\n C1 = Y(KK)\n if (KODE /= 1) then\n CALL DGSS17(ZR,C1,C2,NW,ASC,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(KK) = C1*CSPN + C2\n KK = KK - 1\n CSPN = -CSPN\n if (IFLAG < 3) then\n C2R = REAL(CK)\n C2I = AIMAG(CK)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*CS\n S2 = CK\n S1 = S1*CSS(IFLAG)\n S2 = S2*CSS(IFLAG)\n CS = CSR(IFLAG)\n endif\n endif\n 260 continue\n endif\n return\n endif\n 280 NZ = -1\n return\n END\n subroutine DCZS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-786 (DEC 1989).\n!\n! Original name: CUNK1\n!\n! DCZS18 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE\n! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE\n! UNIFORM ASYMPTOTIC EXPANSION.\n! MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.\n! NZ=-1 MEANS AN OVERFLOW WILL OCCUR\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CFN, CK, CONE, CRSC, CS, CSCL, CSGN, &\n CSPN, CZERO, PHID, RZ, S1, S2, SUMD, ZETA1D, &\n ZETA2D, ZR\n REAL ANG, APHI, ASC, ASCLE, C2I, C2M, C2R, CPN, FMR, &\n FN, FNF, PI, RS1, SGN, SPN, X\n INTEGER I, IB, IC, IFLAG, IFN, IL, INITD, INU, IPARD, &\n IUF, J, K, KDFLG, KFLAG, KK, M, NW\n! .. Local Arrays ..\n COMPLEX CSR(3), CSS(3), CWRK(16,3), CY(2), PHI(2), &\n SUM(2), ZETA1(2), ZETA2(2)\n REAL BRY(3)\n INTEGER INIT(2)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEWS17, DGSS17, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, LOG, MAX, MOD, &\n REAL, SIGN, SIN\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n DATA PI/3.14159265358979324E0/\n! .. Executable Statements ..\n!\n KDFLG = 1\n NZ = 0\n! ------------------------------------------------------------------\n! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN\n! THE UNDERFLOW LIMIT\n! ------------------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n X = REAL(Z)\n ZR = Z\n if (X < 0.0E0) ZR = -Z\n J = 2\n DO 40 I = 1, N\n! ---------------------------------------------------------------\n! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J\n! ---------------------------------------------------------------\n J = 3 - J\n FN = FNU + I - 1\n INIT(J) = 0\n CALL DEWS17(ZR,FN,2,0,TOL,INIT(J),PHI(J),ZETA1(J),ZETA2(J), &\n SUM(J),CWRK(1,J),ELIM)\n if (KODE == 1) then\n S1 = ZETA1(J) - ZETA2(J)\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = ZETA1(J) - CFN*(CFN/(ZR+ZETA2(J)))\n endif\n! ---------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ---------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (KDFLG == 1) KFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ---------------------------------------------------------\n! REFINE TEST AND SCALE\n! ---------------------------------------------------------\n APHI = ABS(PHI(J))\n RS1 = RS1 + LOG(APHI)\n if (ABS(RS1) > ELIM) then\n goto 20\n ELSE\n if (KDFLG == 1) KFLAG = 1\n if (RS1 >= 0.0E0) then\n if (KDFLG == 1) KFLAG = 3\n endif\n endif\n endif\n! ------------------------------------------------------------\n! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR\n! EXPONENT EXTREMES\n! ------------------------------------------------------------\n S2 = PHI(J)*SUM(J)\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(KFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (KFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) goto 20\n endif\n CY(KDFLG) = S2\n Y(I) = S2*CSR(KFLAG)\n if (KDFLG == 2) then\n goto 60\n ELSE\n KDFLG = 2\n goto 40\n endif\n endif\n 20 if (RS1 > 0.0E0) then\n goto 280\n! ------------------------------------------------------------\n! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW\n! ------------------------------------------------------------\n else if (X < 0.0E0) then\n goto 280\n ELSE\n KDFLG = 1\n Y(I) = CZERO\n NZ = NZ + 1\n if (I /= 1) then\n if (Y(I-1) /= CZERO) then\n Y(I-1) = CZERO\n NZ = NZ + 1\n endif\n endif\n endif\n 40 continue\n I = N\n 60 RZ = CMPLX(2.0E0,0.0E0)/ZR\n CK = CMPLX(FN,0.0E0)*RZ\n IB = I + 1\n if (N >= IB) then\n! ---------------------------------------------------------------\n! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO\n! ZERO ON UNDERFLOW\n! ---------------------------------------------------------------\n FN = FNU + N - 1\n IPARD = 1\n if (MR /= 0) IPARD = 0\n INITD = 0\n CALL DEWS17(ZR,FN,2,IPARD,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, &\n CWRK(1,3),ELIM)\n if (KODE == 1) then\n S1 = ZETA1D - ZETA2D\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = ZETA1D - CFN*(CFN/(ZR+ZETA2D))\n endif\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (ABS(RS1) >= ALIM) then\n! ---------------------------------------------------------\n! REFINE ESTIMATE AND TEST\n! ---------------------------------------------------------\n APHI = ABS(PHID)\n RS1 = RS1 + LOG(APHI)\n if (ABS(RS1) >= ELIM) goto 100\n endif\n! ------------------------------------------------------------\n! RECUR FORWARD FOR REMAINDER OF THE SEQUENCE\n! ------------------------------------------------------------\n S1 = CY(1)\n S2 = CY(2)\n C1 = CSR(KFLAG)\n ASCLE = BRY(KFLAG)\n DO 80 I = IB, N\n C2 = S2\n S2 = CK*S2 + S1\n S1 = C2\n CK = CK + RZ\n C2 = S2*C1\n Y(I) = C2\n if (KFLAG < 3) then\n C2R = REAL(C2)\n C2I = AIMAG(C2)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n KFLAG = KFLAG + 1\n ASCLE = BRY(KFLAG)\n S1 = S1*C1\n S2 = C2\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n C1 = CSR(KFLAG)\n endif\n endif\n 80 continue\n goto 140\n endif\n 100 if (RS1 > 0.0E0) then\n goto 280\n! ------------------------------------------------------------\n! FOR X < 0.0, THE I function TO BE ADDED WILL OVERFLOW\n! ------------------------------------------------------------\n else if (X < 0.0E0) then\n goto 280\n ELSE\n NZ = N\n DO 120 I = 1, N\n Y(I) = CZERO\n 120 continue\n return\n endif\n endif\n 140 if (MR == 0) then\n return\n ELSE\n! ---------------------------------------------------------------\n! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0\n! ---------------------------------------------------------------\n NZ = 0\n FMR = MR\n SGN = -SIGN(PI,FMR)\n! ---------------------------------------------------------------\n! CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP.\n! ---------------------------------------------------------------\n CSGN = CMPLX(0.0E0,SGN)\n INU = INT(FNU)\n FNF = FNU - INU\n IFN = INU + N - 1\n ANG = FNF*SGN\n CPN = COS(ANG)\n SPN = SIN(ANG)\n CSPN = CMPLX(CPN,SPN)\n if (MOD(IFN,2) == 1) CSPN = -CSPN\n ASC = BRY(1)\n KK = N\n IUF = 0\n KDFLG = 1\n IB = IB - 1\n IC = IB - 1\n DO 220 K = 1, N\n FN = FNU + KK - 1\n! ------------------------------------------------------------\n! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K\n! function ABOVE\n! ------------------------------------------------------------\n M = 3\n if (N > 2) then\n if ((KK == N) .and. (IB < N)) then\n goto 160\n else if ((KK /= IB) .and. (KK /= IC)) then\n INITD = 0\n goto 160\n endif\n endif\n INITD = INIT(J)\n PHID = PHI(J)\n ZETA1D = ZETA1(J)\n ZETA2D = ZETA2(J)\n SUMD = SUM(J)\n M = J\n J = 3 - J\n 160 CALL DEWS17(ZR,FN,1,0,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, &\n CWRK(1,M),ELIM)\n if (KODE == 1) then\n S1 = -ZETA1D + ZETA2D\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = -ZETA1D + CFN*(CFN/(ZR+ZETA2D))\n endif\n! ------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n if (KDFLG == 1) IFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ------------------------------------------------------\n! REFINE TEST AND SCALE\n! ------------------------------------------------------\n APHI = ABS(PHID)\n RS1 = RS1 + LOG(APHI)\n if (ABS(RS1) > ELIM) then\n goto 180\n ELSE\n if (KDFLG == 1) IFLAG = 1\n if (RS1 >= 0.0E0) then\n if (KDFLG == 1) IFLAG = 3\n endif\n endif\n endif\n S2 = CSGN*PHID*SUMD\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(IFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (IFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0)\n endif\n goto 200\n endif\n 180 if (RS1 > 0.0E0) then\n goto 280\n ELSE\n S2 = CZERO\n endif\n 200 CY(KDFLG) = S2\n C2 = S2\n S2 = S2*CSR(IFLAG)\n! ------------------------------------------------------------\n! ADD I AND K functionS, K SEQUENCE IN Y(I), I=1,N\n! ------------------------------------------------------------\n S1 = Y(KK)\n if (KODE /= 1) then\n CALL DGSS17(ZR,S1,S2,NW,ASC,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(KK) = S1*CSPN + S2\n KK = KK - 1\n CSPN = -CSPN\n if (C2 == CZERO) then\n KDFLG = 1\n else if (KDFLG == 2) then\n goto 240\n ELSE\n KDFLG = 2\n endif\n 220 continue\n K = N\n 240 IL = N - K\n if (IL /= 0) then\n! ------------------------------------------------------------\n! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE\n! K functionS, SCALING THE I SEQUENCE DURING RECURRENCE TO\n! KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT\n! EXTREMES.\n! ------------------------------------------------------------\n S1 = CY(1)\n S2 = CY(2)\n CS = CSR(IFLAG)\n ASCLE = BRY(IFLAG)\n FN = INU + IL\n DO 260 I = 1, IL\n C2 = S2\n S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2\n S1 = C2\n FN = FN - 1.0E0\n C2 = S2*CS\n CK = C2\n C1 = Y(KK)\n if (KODE /= 1) then\n CALL DGSS17(ZR,C1,C2,NW,ASC,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(KK) = C1*CSPN + C2\n KK = KK - 1\n CSPN = -CSPN\n if (IFLAG < 3) then\n C2R = REAL(CK)\n C2I = AIMAG(CK)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*CS\n S2 = CK\n S1 = S1*CSS(IFLAG)\n S2 = S2*CSS(IFLAG)\n CS = CSR(IFLAG)\n endif\n endif\n 260 continue\n endif\n return\n endif\n 280 NZ = -1\n return\n END\n subroutine DERS17(Z,FNU,N,CY,TOL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-761 (DEC 1989).\n!\n! Original name: CRATI\n!\n! DERS17 COMPUTES RATIOS OF I BESSEL functionS BY BACKWARD\n! RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD\n! RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B,\n! MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973,\n! BESSEL functionS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER,\n! BY D. J. SOOKNE.\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL FNU, TOL\n INTEGER N\n! .. Array Arguments ..\n COMPLEX CY(N)\n! .. Local Scalars ..\n COMPLEX CDFNU, CONE, CZERO, P1, P2, PT, RZ, T1\n REAL AK, AMAGZ, AP1, AP2, ARG, AZ, DFNU, FDNU, FLAM, &\n FNUP, RAP1, RHO, TEST, TEST1\n INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, INT, MAX, MIN, REAL, SQRT\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n AZ = ABS(Z)\n INU = INT(FNU)\n IDNU = INU + N - 1\n FDNU = IDNU\n MAGZ = INT(AZ)\n AMAGZ = MAGZ + 1\n FNUP = MAX(AMAGZ,FDNU)\n ID = IDNU - MAGZ - 1\n ITIME = 1\n K = 1\n RZ = (CONE+CONE)/Z\n T1 = CMPLX(FNUP,0.0E0)*RZ\n P2 = -T1\n P1 = CONE\n T1 = T1 + RZ\n if (ID > 0) ID = 0\n AP2 = ABS(P2)\n AP1 = ABS(P1)\n! ------------------------------------------------------------------\n! THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNX\n! GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT\n! P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR\n! PREMATURELY.\n! ------------------------------------------------------------------\n ARG = (AP2+AP2)/(AP1*TOL)\n TEST1 = SQRT(ARG)\n TEST = TEST1\n RAP1 = 1.0E0/AP1\n P1 = P1*CMPLX(RAP1,0.0E0)\n P2 = P2*CMPLX(RAP1,0.0E0)\n AP2 = AP2*RAP1\n 20 continue\n K = K + 1\n AP1 = AP2\n PT = P2\n P2 = P1 - T1*P2\n P1 = PT\n T1 = T1 + RZ\n AP2 = ABS(P2)\n if (AP1 <= TEST) then\n goto 20\n else if (ITIME /= 2) then\n AK = ABS(T1)*0.5E0\n FLAM = AK + SQRT(AK*AK-1.0E0)\n RHO = MIN(AP2/AP1,FLAM)\n TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0E0))\n ITIME = 2\n goto 20\n endif\n KK = K + 1 - ID\n AK = KK\n DFNU = FNU + N - 1\n CDFNU = CMPLX(DFNU,0.0E0)\n T1 = CMPLX(AK,0.0E0)\n P1 = CMPLX(1.0E0/AP2,0.0E0)\n P2 = CZERO\n DO 40 I = 1, KK\n PT = P1\n P1 = RZ*(CDFNU+T1)*P1 + P2\n P2 = PT\n T1 = T1 - CONE\n 40 continue\n if (REAL(P1) == 0.0E0 .and. AIMAG(P1) == 0.0E0) P1 = CMPLX(TOL, &\n TOL)\n CY(N) = P2/P1\n if (N /= 1) then\n K = N - 1\n AK = K\n T1 = CMPLX(AK,0.0E0)\n CDFNU = CMPLX(FNU,0.0E0)*RZ\n DO 60 I = 2, N\n PT = CDFNU + T1*RZ + CY(K+1)\n if (REAL(PT) == 0.0E0 .and. AIMAG(PT) == 0.0E0) &\n PT = CMPLX(TOL,TOL)\n CY(K) = CONE/PT\n T1 = T1 - CONE\n K = K - 1\n 60 continue\n endif\n return\n END\n subroutine DESS17(ZR,FNU,KODE,N,Y,NZ,CW,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-762 (DEC 1989).\n!\n! Original name: CWRSK\n!\n! DESS17 COMPUTES THE I BESSEL function FOR RE(Z) >= 0.0 BY\n! NORMALIZING THE I function RATIOS FROM DERS17 BY THE WRONSKIAN\n!\n! .. Scalar Arguments ..\n COMPLEX ZR\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX CW(2), Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CINU, CSCL, CT, RCT, ST\n REAL ACT, ACW, ASCLE, S1, S2, YY\n INTEGER I, NW\n! .. External functions ..\n REAL X02AME\n EXTERNAL X02AME\n! .. External subroutines ..\n EXTERNAL DERS17, DGXS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, SIN\n! .. Executable Statements ..\n! ------------------------------------------------------------------\n! I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS\n! Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM DERS17 NORMALIZED BY THE\n! WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM DGXS17.\n! ------------------------------------------------------------------\n NZ = 0\n CALL DGXS17(ZR,FNU,KODE,2,CW,NW,TOL,ELIM,ALIM)\n if (NW /= 0) then\n NZ = -1\n if (NW == (-2)) NZ = -2\n if (NW == (-3)) NZ = -3\n ELSE\n CALL DERS17(ZR,FNU,N,Y,TOL)\n! ---------------------------------------------------------------\n! RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z),\n! R(FNU+J-1,Z)=Y(J), J=1,...,N\n! ---------------------------------------------------------------\n CINU = CMPLX(1.0E0,0.0E0)\n if (KODE /= 1) then\n YY = AIMAG(ZR)\n S1 = COS(YY)\n S2 = SIN(YY)\n CINU = CMPLX(S1,S2)\n endif\n! ---------------------------------------------------------------\n! ON LOW EXPONENT MACHINES THE K functionS CAN BE CLOSE TO BOTH\n! THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE\n! SCALED TO PREVENT OVER OR UNDERFLOW. DEVS17 HAS DETERMINED THAT\n! THE RESULT IS ON SCALE.\n! ---------------------------------------------------------------\n ACW = ABS(CW(2))\n ASCLE = (1.0E+3*X02AME())/TOL\n CSCL = CMPLX(1.0E0,0.0E0)\n if (ACW > ASCLE) then\n ASCLE = 1.0E0/ASCLE\n if (ACW >= ASCLE) CSCL = CMPLX(TOL,0.0E0)\n ELSE\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n endif\n C1 = CW(1)*CSCL\n C2 = CW(2)*CSCL\n ST = Y(1)\n! ---------------------------------------------------------------\n! CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0E0/CABS(CT) PREVENTS\n! UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT)\n! ---------------------------------------------------------------\n CT = ZR*(C2+ST*C1)\n ACT = ABS(CT)\n RCT = CMPLX(1.0E0/ACT,0.0E0)\n CT = CONJG(CT)*RCT\n CINU = CINU*RCT*CT\n Y(1) = CINU*CSCL\n if (N /= 1) then\n DO 20 I = 2, N\n CINU = ST*CINU\n ST = Y(I)\n Y(I) = CINU*CSCL\n 20 continue\n endif\n endif\n return\n END\n subroutine DETS17(Z,FNU,KODE,N,Y,NZ,NLAST,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-763 (DEC 1989).\n!\n! Original name: CUNI2\n!\n! DETS17 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF\n! UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I\n! OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO.\n!\n! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC\n! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.\n! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER\n! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL.\n! Y(I)=CZERO FOR I=NLAST+1,N\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, TOL\n INTEGER KODE, N, NLAST, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX AI, ARG, ASUM, BSUM, C1, C2, CFN, CI, CID, CONE, &\n CRSC, CSCL, CZERO, DAI, PHI, RZ, S1, S2, ZB, &\n ZETA1, ZETA2, ZN\n REAL AARG, AIC, ANG, APHI, ASCLE, AY, C2I, C2M, C2R, &\n CAR, FN, HPI, RS1, SAR, YY\n INTEGER I, IDUM, IFLAG, IN, INU, J, K, NAI, ND, NDAI, &\n NN, NUF, NW\n! .. Local Arrays ..\n COMPLEX CIP(4), CSR(3), CSS(3), CY(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEUS17, DEVS17, S17DGE, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, INT, LOG, &\n MAX, MIN, MOD, REAL, SIN\n! .. Data statements ..\n DATA CZERO, CONE, CI/(0.0E0,0.0E0), (1.0E0,0.0E0), &\n (0.0E0,1.0E0)/\n DATA CIP(1), CIP(2), CIP(3), CIP(4)/(1.0E0,0.0E0), &\n (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0)/\n DATA HPI, AIC/1.57079632679489662E+00, &\n 1.265512123484645396E+00/\n! .. Executable Statements ..\n!\n NZ = 0\n ND = N\n NLAST = 0\n! ------------------------------------------------------------------\n! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-\n! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,\n! EXP(ALIM)=EXP(ELIM)*TOL\n! ------------------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n YY = AIMAG(Z)\n! ------------------------------------------------------------------\n! ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI\n! ------------------------------------------------------------------\n ZN = -Z*CI\n ZB = Z\n CID = -CI\n INU = INT(FNU)\n ANG = HPI*(FNU-INU)\n CAR = COS(ANG)\n SAR = SIN(ANG)\n C2 = CMPLX(CAR,SAR)\n IN = INU + N - 1\n IN = MOD(IN,4)\n C2 = C2*CIP(IN+1)\n if (YY <= 0.0E0) then\n ZN = CONJG(-ZN)\n ZB = CONJG(ZB)\n CID = -CID\n C2 = CONJG(C2)\n endif\n! ------------------------------------------------------------------\n! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER\n! ------------------------------------------------------------------\n FN = MAX(FNU,1.0E0)\n CALL DEUS17(ZN,FN,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM)\n if (KODE == 1) then\n S1 = -ZETA1 + ZETA2\n ELSE\n CFN = CMPLX(FNU,0.0E0)\n S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2))\n endif\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n 20 continue\n NN = MIN(2,ND)\n DO 40 I = 1, NN\n FN = FNU + ND - I\n CALL DEUS17(ZN,FN,0,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM)\n if (KODE == 1) then\n S1 = -ZETA1 + ZETA2\n ELSE\n CFN = CMPLX(FN,0.0E0)\n AY = ABS(YY)\n S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + CMPLX(0.0E0,AY)\n endif\n! ------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) > ELIM) then\n goto 60\n ELSE\n if (I == 1) IFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ------------------------------------------------------\n! REFINE TEST AND SCALE\n! ------------------------------------------------------\n! ------------------------------------------------------\n APHI = ABS(PHI)\n AARG = ABS(ARG)\n RS1 = RS1 + LOG(APHI) - 0.25E0*LOG(AARG) - AIC\n if (ABS(RS1) > ELIM) then\n goto 60\n ELSE\n if (I == 1) IFLAG = 1\n if (RS1 >= 0.0E0) then\n if (I == 1) IFLAG = 3\n endif\n endif\n endif\n! ---------------------------------------------------------\n! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR\n! EXPONENT EXTREMES\n! ---------------------------------------------------------\n IDUM = 1\n! S17DGE assumed not to fail, therefore IDUM set to one.\n CALL S17DGE('F',ARG,'S',AI,NAI,IDUM)\n IDUM = 1\n CALL S17DGE('D',ARG,'S',DAI,NDAI,IDUM)\n S2 = PHI*(AI*ASUM+DAI*BSUM)\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(IFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (IFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) goto 60\n endif\n if (YY <= 0.0E0) S2 = CONJG(S2)\n J = ND - I + 1\n S2 = S2*C2\n CY(I) = S2\n Y(J) = S2*CSR(IFLAG)\n C2 = C2*CID\n endif\n 40 continue\n goto 80\n 60 if (RS1 > 0.0E0) then\n goto 160\n ELSE\n! ------------------------------------------------------------\n! SET UNDERFLOW AND UPDATE PARAMETERS\n! ------------------------------------------------------------\n Y(ND) = CZERO\n NZ = NZ + 1\n ND = ND - 1\n if (ND == 0) then\n return\n ELSE\n CALL DEVS17(Z,FNU,KODE,1,ND,Y,NUF,TOL,ELIM,ALIM)\n if (NUF < 0) then\n goto 160\n ELSE\n ND = ND - NUF\n NZ = NZ + NUF\n if (ND == 0) then\n return\n ELSE\n FN = FNU + ND - 1\n if (FN < FNUL) then\n goto 120\n ELSE\n! FN = AIMAG(CID)\n! J = NUF + 1\n! K = MOD(J,4) + 1\n! S1 = CIP(K)\n! if (FN < 0.0E0) S1 = CONJG(S1)\n! C2 = C2*S1\n! The above 6 lines were replaced by the 5 below\n! to fix a bug discovered during implementation\n! on a Multics machine, whereby some results\n! were returned wrongly scaled by sqrt(-1.0). MWP.\n C2 = CMPLX(CAR,SAR)\n IN = INU + ND - 1\n IN = MOD(IN,4) + 1\n C2 = C2*CIP(IN)\n if (YY <= 0.0E0) C2 = CONJG(C2)\n goto 20\n endif\n endif\n endif\n endif\n endif\n 80 if (ND > 2) then\n RZ = CMPLX(2.0E0,0.0E0)/Z\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n S1 = CY(1)\n S2 = CY(2)\n C1 = CSR(IFLAG)\n ASCLE = BRY(IFLAG)\n K = ND - 2\n FN = K\n DO 100 I = 3, ND\n C2 = S2\n S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2\n S1 = C2\n C2 = S2*C1\n Y(K) = C2\n K = K - 1\n FN = FN - 1.0E0\n if (IFLAG < 3) then\n C2R = REAL(C2)\n C2I = AIMAG(C2)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*C1\n S2 = C2\n S1 = S1*CSS(IFLAG)\n S2 = S2*CSS(IFLAG)\n C1 = CSR(IFLAG)\n endif\n endif\n 100 continue\n endif\n return\n 120 NLAST = ND\n return\n else if (RS1 <= 0.0E0) then\n NZ = N\n DO 140 I = 1, N\n Y(I) = CZERO\n 140 continue\n return\n endif\n 160 NZ = -1\n return\n END\n subroutine DEUS17(Z,FNU,IPMTR,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM, &\n ELIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-764 (DEC 1989).\n!\n! Original name: CUNHJ\n!\n! REFERENCES\n! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ AND I.A.\n! STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9.\n!\n! ASYMPTOTICS AND SPECIAL functionS BY F.W.J. OLVER, ACADEMIC\n! PRESS, N.Y., 1974, PAGE 420\n!\n! ABSTRACT\n! DEUS17 COMPUTES PARAMETERS FOR BESSEL functionS C(FNU,Z) =\n! J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU\n! BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION\n!\n! C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) )\n!\n! FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS\n! AN AIRY function AND DAIRY IS ITS DERIVATIVE.\n!\n! (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2,\n!\n! ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING\n! PURPOSES IN AIRY functionS FROM S17DGE OR S17DHE.\n!\n! MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND\n! MUST BE SPECIFIED. IPMTR=0 returnS ALL PARAMETERS. IPMTR=\n! 1 COMPUTES ALL EXCEPT ASUM AND BSUM.\n!\n! .. Scalar Arguments ..\n COMPLEX ARG, ASUM, BSUM, PHI, Z, ZETA1, ZETA2\n REAL ELIM, FNU, TOL\n INTEGER IPMTR\n! .. Local Scalars ..\n COMPLEX CFNU, CONE, CZERO, PRZTH, PTFN, RFN13, RTZTA, &\n RZTH, SUMA, SUMB, T2, TFN, W, W2, ZA, ZB, ZC, &\n ZETA, ZTH\n REAL ANG, ASUMI, ASUMR, ATOL, AW2, AZTH, BSUMI, &\n BSUMR, BTOL, EX1, EX2, FN13, FN23, HPI, PI, PP, &\n RFNU, RFNU2, TEST, THPI, TSTI, TSTR, WI, WR, &\n ZCI, ZCR, ZETAI, ZETAR, ZTHI, ZTHR\n INTEGER IAS, IBS, IS, J, JR, JU, K, KMAX, KP1, KS, L, &\n L1, L2, LR, LRP1, M\n! .. Local Arrays ..\n COMPLEX CR(14), DR(14), P(30), UP(14)\n REAL ALFA(180), AP(30), AR(14), BETA(210), BR(14), &\n C(105), GAMA(30)\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, ATAN, CMPLX, COS, EXP, LOG, REAL, &\n SIN, SQRT\n! .. Data statements ..\n DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), &\n AR(8), AR(9), AR(10), AR(11), AR(12), AR(13), &\n AR(14)/1.00000000000000000E+00, &\n 1.04166666666666667E-01, &\n 8.35503472222222222E-02, &\n 1.28226574556327160E-01, &\n 2.91849026464140464E-01, &\n 8.81627267443757652E-01, &\n 3.32140828186276754E+00, &\n 1.49957629868625547E+01, &\n 7.89230130115865181E+01, &\n 4.74451538868264323E+02, &\n 3.20749009089066193E+03, &\n 2.40865496408740049E+04, &\n 1.98923119169509794E+05, &\n 1.79190200777534383E+06/\n DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), &\n BR(8), BR(9), BR(10), BR(11), BR(12), BR(13), &\n BR(14)/1.00000000000000000E+00, &\n -1.45833333333333333E-01, &\n -9.87413194444444444E-02, &\n -1.43312053915895062E-01, &\n -3.17227202678413548E-01, &\n -9.42429147957120249E-01, &\n -3.51120304082635426E+00, &\n -1.57272636203680451E+01, &\n -8.22814390971859444E+01, &\n -4.92355370523670524E+02, &\n -3.31621856854797251E+03, &\n -2.48276742452085896E+04, &\n -2.04526587315129788E+05, &\n -1.83844491706820990E+06/\n DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), &\n C(9), C(10), C(11), C(12), C(13), C(14), C(15), &\n C(16)/1.00000000000000000E+00, &\n -2.08333333333333333E-01, &\n 1.25000000000000000E-01, &\n 3.34201388888888889E-01, &\n -4.01041666666666667E-01, &\n 7.03125000000000000E-02, &\n -1.02581259645061728E+00, &\n 1.84646267361111111E+00, &\n -8.91210937500000000E-01, &\n 7.32421875000000000E-02, &\n 4.66958442342624743E+00, &\n -1.12070026162229938E+01, &\n 8.78912353515625000E+00, &\n -2.36408691406250000E+00, &\n 1.12152099609375000E-01, &\n -2.82120725582002449E+01/\n DATA C(17), C(18), C(19), C(20), C(21), C(22), C(23), &\n C(24)/8.46362176746007346E+01, &\n -9.18182415432400174E+01, &\n 4.25349987453884549E+01, &\n -7.36879435947963170E+00, &\n 2.27108001708984375E-01, &\n 2.12570130039217123E+02, &\n -7.65252468141181642E+02, &\n 1.05999045252799988E+03/\n DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), &\n C(32), C(33), C(34), C(35), C(36), C(37), C(38), &\n C(39), C(40)/-6.99579627376132541E+02, &\n 2.18190511744211590E+02, &\n -2.64914304869515555E+01, &\n 5.72501420974731445E-01, &\n -1.91945766231840700E+03, &\n 8.06172218173730938E+03, &\n -1.35865500064341374E+04, &\n 1.16553933368645332E+04, &\n -5.30564697861340311E+03, &\n 1.20090291321635246E+03, &\n -1.08090919788394656E+02, &\n 1.72772750258445740E+00, &\n 2.02042913309661486E+04, &\n -9.69805983886375135E+04, &\n 1.92547001232531532E+05, &\n -2.03400177280415534E+05/\n DATA C(41), C(42), C(43), C(44), C(45), C(46), C(47), &\n C(48)/1.22200464983017460E+05, &\n -4.11926549688975513E+04, &\n 7.10951430248936372E+03, &\n -4.93915304773088012E+02, &\n 6.07404200127348304E+00, &\n -2.42919187900551333E+05, &\n 1.31176361466297720E+06, &\n -2.99801591853810675E+06/\n DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), &\n C(56), C(57), C(58), C(59), C(60), C(61), C(62), &\n C(63), C(64)/3.76327129765640400E+06, &\n -2.81356322658653411E+06, &\n 1.26836527332162478E+06, &\n -3.31645172484563578E+05, &\n 4.52187689813627263E+04, &\n -2.49983048181120962E+03, &\n 2.43805296995560639E+01, &\n 3.28446985307203782E+06, &\n -1.97068191184322269E+07, &\n 5.09526024926646422E+07, &\n -7.41051482115326577E+07, &\n 6.63445122747290267E+07, &\n -3.75671766607633513E+07, &\n 1.32887671664218183E+07, &\n -2.78561812808645469E+06, &\n 3.08186404612662398E+05/\n DATA C(65), C(66), C(67), C(68), C(69), C(70), C(71), &\n C(72)/-1.38860897537170405E+04, &\n 1.10017140269246738E+02, &\n -4.93292536645099620E+07, &\n 3.25573074185765749E+08, &\n -9.39462359681578403E+08, &\n 1.55359689957058006E+09, &\n -1.62108055210833708E+09, &\n 1.10684281682301447E+09/\n DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), &\n C(80), C(81), C(82), C(83), C(84), C(85), C(86), &\n C(87), C(88)/-4.95889784275030309E+08, &\n 1.42062907797533095E+08, &\n -2.44740627257387285E+07, &\n 2.24376817792244943E+06, &\n -8.40054336030240853E+04, &\n 5.51335896122020586E+02, &\n 8.14789096118312115E+08, &\n -5.86648149205184723E+09, &\n 1.86882075092958249E+10, &\n -3.46320433881587779E+10, &\n 4.12801855797539740E+10, &\n -3.30265997498007231E+10, &\n 1.79542137311556001E+10, &\n -6.56329379261928433E+09, &\n 1.55927986487925751E+09, &\n -2.25105661889415278E+08/\n DATA C(89), C(90), C(91), C(92), C(93), C(94), C(95), &\n C(96)/1.73951075539781645E+07, &\n -5.49842327572288687E+05, &\n 3.03809051092238427E+03, &\n -1.46792612476956167E+10, &\n 1.14498237732025810E+11, &\n -3.99096175224466498E+11, &\n 8.19218669548577329E+11, &\n -1.09837515608122331E+12/\n DATA C(97), C(98), C(99), C(100), C(101), C(102), &\n C(103), C(104), C(105)/1.00815810686538209E+12, &\n -6.45364869245376503E+11, &\n 2.87900649906150589E+11, &\n -8.78670721780232657E+10, &\n 1.76347306068349694E+10, &\n -2.16716498322379509E+09, &\n 1.43157876718888981E+08, &\n -3.87183344257261262E+06, &\n 1.82577554742931747E+04/\n DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), &\n ALFA(6), ALFA(7), ALFA(8), ALFA(9), ALFA(10), &\n ALFA(11), ALFA(12), ALFA(13), &\n ALFA(14)/-4.44444444444444444E-03, &\n -9.22077922077922078E-04, &\n -8.84892884892884893E-05, &\n 1.65927687832449737E-04, &\n 2.46691372741792910E-04, &\n 2.65995589346254780E-04, &\n 2.61824297061500945E-04, &\n 2.48730437344655609E-04, &\n 2.32721040083232098E-04, &\n 2.16362485712365082E-04, &\n 2.00738858762752355E-04, &\n 1.86267636637545172E-04, &\n 1.73060775917876493E-04, &\n 1.61091705929015752E-04/\n DATA ALFA(15), ALFA(16), ALFA(17), ALFA(18), &\n ALFA(19), ALFA(20), ALFA(21), &\n ALFA(22)/1.50274774160908134E-04, &\n 1.40503497391269794E-04, &\n 1.31668816545922806E-04, &\n 1.23667445598253261E-04, &\n 1.16405271474737902E-04, &\n 1.09798298372713369E-04, &\n 1.03772410422992823E-04, &\n 9.82626078369363448E-05/\n DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), &\n ALFA(27), ALFA(28), ALFA(29), ALFA(30), &\n ALFA(31), ALFA(32), ALFA(33), ALFA(34), &\n ALFA(35), ALFA(36)/9.32120517249503256E-05, &\n 8.85710852478711718E-05, &\n 8.42963105715700223E-05, &\n 8.03497548407791151E-05, &\n 7.66981345359207388E-05, &\n 7.33122157481777809E-05, &\n 7.01662625163141333E-05, &\n 6.72375633790160292E-05, &\n 6.93735541354588974E-04, &\n 2.32241745182921654E-04, &\n -1.41986273556691197E-05, &\n -1.16444931672048640E-04, &\n -1.50803558053048762E-04, &\n -1.55121924918096223E-04/\n DATA ALFA(37), ALFA(38), ALFA(39), ALFA(40), &\n ALFA(41), ALFA(42), ALFA(43), &\n ALFA(44)/-1.46809756646465549E-04, &\n -1.33815503867491367E-04, &\n -1.19744975684254051E-04, &\n -1.06184319207974020E-04, &\n -9.37699549891194492E-05, &\n -8.26923045588193274E-05, &\n -7.29374348155221211E-05, &\n -6.44042357721016283E-05/\n DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), &\n ALFA(49), ALFA(50), ALFA(51), ALFA(52), &\n ALFA(53), ALFA(54), ALFA(55), ALFA(56), &\n ALFA(57), ALFA(58)/-5.69611566009369048E-05, &\n -5.04731044303561628E-05, &\n -4.48134868008882786E-05, &\n -3.98688727717598864E-05, &\n -3.55400532972042498E-05, &\n -3.17414256609022480E-05, &\n -2.83996793904174811E-05, &\n -2.54522720634870566E-05, &\n -2.28459297164724555E-05, &\n -2.05352753106480604E-05, &\n -1.84816217627666085E-05, &\n -1.66519330021393806E-05, &\n -1.50179412980119482E-05, &\n -1.35554031379040526E-05/\n DATA ALFA(59), ALFA(60), ALFA(61), ALFA(62), &\n ALFA(63), ALFA(64), ALFA(65), &\n ALFA(66)/-1.22434746473858131E-05, &\n -1.10641884811308169E-05, &\n -3.54211971457743841E-04, &\n -1.56161263945159416E-04, &\n 3.04465503594936410E-05, &\n 1.30198655773242693E-04, &\n 1.67471106699712269E-04, &\n 1.70222587683592569E-04/\n DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), &\n ALFA(71), ALFA(72), ALFA(73), ALFA(74), &\n ALFA(75), ALFA(76), ALFA(77), ALFA(78), &\n ALFA(79), ALFA(80)/1.56501427608594704E-04, &\n 1.36339170977445120E-04, &\n 1.14886692029825128E-04, &\n 9.45869093034688111E-05, &\n 7.64498419250898258E-05, &\n 6.07570334965197354E-05, &\n 4.74394299290508799E-05, &\n 3.62757512005344297E-05, &\n 2.69939714979224901E-05, &\n 1.93210938247939253E-05, &\n 1.30056674793963203E-05, &\n 7.82620866744496661E-06, &\n 3.59257485819351583E-06, &\n 1.44040049814251817E-07/\n DATA ALFA(81), ALFA(82), ALFA(83), ALFA(84), &\n ALFA(85), ALFA(86), ALFA(87), &\n ALFA(88)/-2.65396769697939116E-06, &\n -4.91346867098485910E-06, &\n -6.72739296091248287E-06, &\n -8.17269379678657923E-06, &\n -9.31304715093561232E-06, &\n -1.02011418798016441E-05, &\n -1.08805962510592880E-05, &\n -1.13875481509603555E-05/\n DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), &\n ALFA(93), ALFA(94), ALFA(95), ALFA(96), &\n ALFA(97), ALFA(98), ALFA(99), ALFA(100), &\n ALFA(101), ALFA(102)/-1.17519675674556414E-05, &\n -1.19987364870944141E-05, &\n 3.78194199201772914E-04, &\n 2.02471952761816167E-04, &\n -6.37938506318862408E-05, &\n -2.38598230603005903E-04, &\n -3.10916256027361568E-04, &\n -3.13680115247576316E-04, &\n -2.78950273791323387E-04, &\n -2.28564082619141374E-04, &\n -1.75245280340846749E-04, &\n -1.25544063060690348E-04, &\n -8.22982872820208365E-05, &\n -4.62860730588116458E-05/\n DATA ALFA(103), ALFA(104), ALFA(105), ALFA(106), &\n ALFA(107), ALFA(108), ALFA(109), &\n ALFA(110)/-1.72334302366962267E-05, &\n 5.60690482304602267E-06, &\n 2.31395443148286800E-05, &\n 3.62642745856793957E-05, &\n 4.58006124490188752E-05, &\n 5.24595294959114050E-05, &\n 5.68396208545815266E-05, &\n 5.94349820393104052E-05/\n DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), &\n ALFA(115), ALFA(116), ALFA(117), ALFA(118), &\n ALFA(119), ALFA(120), ALFA(121), &\n ALFA(122)/6.06478527578421742E-05, &\n 6.08023907788436497E-05, &\n 6.01577894539460388E-05, &\n 5.89199657344698500E-05, &\n 5.72515823777593053E-05, &\n 5.52804375585852577E-05, &\n 5.31063773802880170E-05, &\n 5.08069302012325706E-05, &\n 4.84418647620094842E-05, &\n 4.60568581607475370E-05, &\n -6.91141397288294174E-04, &\n -4.29976633058871912E-04/\n DATA ALFA(123), ALFA(124), ALFA(125), ALFA(126), &\n ALFA(127), ALFA(128), ALFA(129), &\n ALFA(130)/1.83067735980039018E-04, &\n 6.60088147542014144E-04, &\n 8.75964969951185931E-04, &\n 8.77335235958235514E-04, &\n 7.49369585378990637E-04, &\n 5.63832329756980918E-04, &\n 3.68059319971443156E-04, &\n 1.88464535514455599E-04/\n DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), &\n ALFA(135), ALFA(136), ALFA(137), ALFA(138), &\n ALFA(139), ALFA(140), ALFA(141), &\n ALFA(142)/3.70663057664904149E-05, &\n -8.28520220232137023E-05, &\n -1.72751952869172998E-04, &\n -2.36314873605872983E-04, &\n -2.77966150694906658E-04, &\n -3.02079514155456919E-04, &\n -3.12594712643820127E-04, &\n -3.12872558758067163E-04, &\n -3.05678038466324377E-04, &\n -2.93226470614557331E-04, &\n -2.77255655582934777E-04, &\n -2.59103928467031709E-04/\n DATA ALFA(143), ALFA(144), ALFA(145), ALFA(146), &\n ALFA(147), ALFA(148), ALFA(149), &\n ALFA(150)/-2.39784014396480342E-04, &\n -2.20048260045422848E-04, &\n -2.00443911094971498E-04, &\n -1.81358692210970687E-04, &\n -1.63057674478657464E-04, &\n -1.45712672175205844E-04, &\n -1.29425421983924587E-04, &\n -1.14245691942445952E-04/\n DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), &\n ALFA(155), ALFA(156), ALFA(157), ALFA(158), &\n ALFA(159), ALFA(160), ALFA(161), &\n ALFA(162)/1.92821964248775885E-03, &\n 1.35592576302022234E-03, &\n -7.17858090421302995E-04, &\n -2.58084802575270346E-03, &\n -3.49271130826168475E-03, &\n -3.46986299340960628E-03, &\n -2.82285233351310182E-03, &\n -1.88103076404891354E-03, &\n -8.89531718383947600E-04, &\n 3.87912102631035228E-06, &\n 7.28688540119691412E-04, &\n 1.26566373053457758E-03/\n DATA ALFA(163), ALFA(164), ALFA(165), ALFA(166), &\n ALFA(167), ALFA(168), ALFA(169), &\n ALFA(170)/1.62518158372674427E-03, &\n 1.83203153216373172E-03, &\n 1.91588388990527909E-03, &\n 1.90588846755546138E-03, &\n 1.82798982421825727E-03, &\n 1.70389506421121530E-03, &\n 1.55097127171097686E-03, &\n 1.38261421852276159E-03/\n DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), &\n ALFA(175), ALFA(176), ALFA(177), ALFA(178), &\n ALFA(179), ALFA(180)/1.20881424230064774E-03, &\n 1.03676532638344962E-03, &\n 8.71437918068619115E-04, &\n 7.16080155297701002E-04, &\n 5.72637002558129372E-04, &\n 4.42089819465802277E-04, &\n 3.24724948503090564E-04, &\n 2.20342042730246599E-04, &\n 1.28412898401353882E-04, &\n 4.82005924552095464E-05/\n DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), &\n BETA(6), BETA(7), BETA(8), BETA(9), BETA(10), &\n BETA(11), BETA(12), BETA(13), &\n BETA(14)/1.79988721413553309E-02, &\n 5.59964911064388073E-03, &\n 2.88501402231132779E-03, &\n 1.80096606761053941E-03, &\n 1.24753110589199202E-03, &\n 9.22878876572938311E-04, &\n 7.14430421727287357E-04, &\n 5.71787281789704872E-04, &\n 4.69431007606481533E-04, &\n 3.93232835462916638E-04, &\n 3.34818889318297664E-04, &\n 2.88952148495751517E-04, &\n 2.52211615549573284E-04, &\n 2.22280580798883327E-04/\n DATA BETA(15), BETA(16), BETA(17), BETA(18), &\n BETA(19), BETA(20), BETA(21), &\n BETA(22)/1.97541838033062524E-04, &\n 1.76836855019718004E-04, &\n 1.59316899661821081E-04, &\n 1.44347930197333986E-04, &\n 1.31448068119965379E-04, &\n 1.20245444949302884E-04, &\n 1.10449144504599392E-04, &\n 1.01828770740567258E-04/\n DATA BETA(23), BETA(24), BETA(25), BETA(26), &\n BETA(27), BETA(28), BETA(29), BETA(30), &\n BETA(31), BETA(32), BETA(33), BETA(34), &\n BETA(35), BETA(36)/9.41998224204237509E-05, &\n 8.74130545753834437E-05, &\n 8.13466262162801467E-05, &\n 7.59002269646219339E-05, &\n 7.09906300634153481E-05, &\n 6.65482874842468183E-05, &\n 6.25146958969275078E-05, &\n 5.88403394426251749E-05, &\n -1.49282953213429172E-03, &\n -8.78204709546389328E-04, &\n -5.02916549572034614E-04, &\n -2.94822138512746025E-04, &\n -1.75463996970782828E-04, &\n -1.04008550460816434E-04/\n DATA BETA(37), BETA(38), BETA(39), BETA(40), &\n BETA(41), BETA(42), BETA(43), &\n BETA(44)/-5.96141953046457895E-05, &\n -3.12038929076098340E-05, &\n -1.26089735980230047E-05, &\n -2.42892608575730389E-07, &\n 8.05996165414273571E-06, &\n 1.36507009262147391E-05, &\n 1.73964125472926261E-05, &\n 1.98672978842133780E-05/\n DATA BETA(45), BETA(46), BETA(47), BETA(48), &\n BETA(49), BETA(50), BETA(51), BETA(52), &\n BETA(53), BETA(54), BETA(55), BETA(56), &\n BETA(57), BETA(58)/2.14463263790822639E-05, &\n 2.23954659232456514E-05, &\n 2.28967783814712629E-05, &\n 2.30785389811177817E-05, &\n 2.30321976080909144E-05, &\n 2.28236073720348722E-05, &\n 2.25005881105292418E-05, &\n 2.20981015361991429E-05, &\n 2.16418427448103905E-05, &\n 2.11507649256220843E-05, &\n 2.06388749782170737E-05, &\n 2.01165241997081666E-05, &\n 1.95913450141179244E-05, &\n 1.90689367910436740E-05/\n DATA BETA(59), BETA(60), BETA(61), BETA(62), &\n BETA(63), BETA(64), BETA(65), &\n BETA(66)/1.85533719641636667E-05, &\n 1.80475722259674218E-05, &\n 5.52213076721292790E-04, &\n 4.47932581552384646E-04, &\n 2.79520653992020589E-04, &\n 1.52468156198446602E-04, &\n 6.93271105657043598E-05, &\n 1.76258683069991397E-05/\n DATA BETA(67), BETA(68), BETA(69), BETA(70), &\n BETA(71), BETA(72), BETA(73), BETA(74), &\n BETA(75), BETA(76), BETA(77), BETA(78), &\n BETA(79), BETA(80)/-1.35744996343269136E-05, &\n -3.17972413350427135E-05, &\n -4.18861861696693365E-05, &\n -4.69004889379141029E-05, &\n -4.87665447413787352E-05, &\n -4.87010031186735069E-05, &\n -4.74755620890086638E-05, &\n -4.55813058138628452E-05, &\n -4.33309644511266036E-05, &\n -4.09230193157750364E-05, &\n -3.84822638603221274E-05, &\n -3.60857167535410501E-05, &\n -3.37793306123367417E-05, &\n -3.15888560772109621E-05/\n DATA BETA(81), BETA(82), BETA(83), BETA(84), &\n BETA(85), BETA(86), BETA(87), &\n BETA(88)/-2.95269561750807315E-05, &\n -2.75978914828335759E-05, &\n -2.58006174666883713E-05, &\n -2.41308356761280200E-05, &\n -2.25823509518346033E-05, &\n -2.11479656768912971E-05, &\n -1.98200638885294927E-05, &\n -1.85909870801065077E-05/\n DATA BETA(89), BETA(90), BETA(91), BETA(92), &\n BETA(93), BETA(94), BETA(95), BETA(96), &\n BETA(97), BETA(98), BETA(99), BETA(100), &\n BETA(101), BETA(102)/-1.74532699844210224E-05, &\n -1.63997823854497997E-05, &\n -4.74617796559959808E-04, &\n -4.77864567147321487E-04, &\n -3.20390228067037603E-04, &\n -1.61105016119962282E-04, &\n -4.25778101285435204E-05, &\n 3.44571294294967503E-05, &\n 7.97092684075674924E-05, &\n 1.03138236708272200E-04, &\n 1.12466775262204158E-04, &\n 1.13103642108481389E-04, &\n 1.08651634848774268E-04, &\n 1.01437951597661973E-04/\n DATA BETA(103), BETA(104), BETA(105), BETA(106), &\n BETA(107), BETA(108), BETA(109), &\n BETA(110)/9.29298396593363896E-05, &\n 8.40293133016089978E-05, &\n 7.52727991349134062E-05, &\n 6.69632521975730872E-05, &\n 5.92564547323194704E-05, &\n 5.22169308826975567E-05, &\n 4.58539485165360646E-05, &\n 4.01445513891486808E-05/\n DATA BETA(111), BETA(112), BETA(113), BETA(114), &\n BETA(115), BETA(116), BETA(117), BETA(118), &\n BETA(119), BETA(120), BETA(121), &\n BETA(122)/3.50481730031328081E-05, &\n 3.05157995034346659E-05, &\n 2.64956119950516039E-05, &\n 2.29363633690998152E-05, &\n 1.97893056664021636E-05, &\n 1.70091984636412623E-05, &\n 1.45547428261524004E-05, &\n 1.23886640995878413E-05, &\n 1.04775876076583236E-05, &\n 8.79179954978479373E-06, &\n 7.36465810572578444E-04, &\n 8.72790805146193976E-04/\n DATA BETA(123), BETA(124), BETA(125), BETA(126), &\n BETA(127), BETA(128), BETA(129), &\n BETA(130)/6.22614862573135066E-04, &\n 2.85998154194304147E-04, &\n 3.84737672879366102E-06, &\n -1.87906003636971558E-04, &\n -2.97603646594554535E-04, &\n -3.45998126832656348E-04, &\n -3.53382470916037712E-04, &\n -3.35715635775048757E-04/\n DATA BETA(131), BETA(132), BETA(133), BETA(134), &\n BETA(135), BETA(136), BETA(137), BETA(138), &\n BETA(139), BETA(140), BETA(141), &\n BETA(142)/-3.04321124789039809E-04, &\n -2.66722723047612821E-04, &\n -2.27654214122819527E-04, &\n -1.89922611854562356E-04, &\n -1.55058918599093870E-04, &\n -1.23778240761873630E-04, &\n -9.62926147717644187E-05, &\n -7.25178327714425337E-05, &\n -5.22070028895633801E-05, &\n -3.50347750511900522E-05, &\n -2.06489761035551757E-05, &\n -8.70106096849767054E-06/\n DATA BETA(143), BETA(144), BETA(145), BETA(146), &\n BETA(147), BETA(148), BETA(149), &\n BETA(150)/1.13698686675100290E-06, &\n 9.16426474122778849E-06, &\n 1.56477785428872620E-05, &\n 2.08223629482466847E-05, &\n 2.48923381004595156E-05, &\n 2.80340509574146325E-05, &\n 3.03987774629861915E-05, &\n 3.21156731406700616E-05/\n DATA BETA(151), BETA(152), BETA(153), BETA(154), &\n BETA(155), BETA(156), BETA(157), BETA(158), &\n BETA(159), BETA(160), BETA(161), &\n BETA(162)/-1.80182191963885708E-03, &\n -2.43402962938042533E-03, &\n -1.83422663549856802E-03, &\n -7.62204596354009765E-04, &\n 2.39079475256927218E-04, &\n 9.49266117176881141E-04, &\n 1.34467449701540359E-03, &\n 1.48457495259449178E-03, &\n 1.44732339830617591E-03, &\n 1.30268261285657186E-03, &\n 1.10351597375642682E-03, &\n 8.86047440419791759E-04/\n DATA BETA(163), BETA(164), BETA(165), BETA(166), &\n BETA(167), BETA(168), BETA(169), &\n BETA(170)/6.73073208165665473E-04, &\n 4.77603872856582378E-04, &\n 3.05991926358789362E-04, &\n 1.60315694594721630E-04, &\n 4.00749555270613286E-05, &\n -5.66607461635251611E-05, &\n -1.32506186772982638E-04, &\n -1.90296187989614057E-04/\n DATA BETA(171), BETA(172), BETA(173), BETA(174), &\n BETA(175), BETA(176), BETA(177), BETA(178), &\n BETA(179), BETA(180), BETA(181), &\n BETA(182)/-2.32811450376937408E-04, &\n -2.62628811464668841E-04, &\n -2.82050469867598672E-04, &\n -2.93081563192861167E-04, &\n -2.97435962176316616E-04, &\n -2.96557334239348078E-04, &\n -2.91647363312090861E-04, &\n -2.83696203837734166E-04, &\n -2.73512317095673346E-04, &\n -2.61750155806768580E-04, &\n 6.38585891212050914E-03, &\n 9.62374215806377941E-03/\n DATA BETA(183), BETA(184), BETA(185), BETA(186), &\n BETA(187), BETA(188), BETA(189), &\n BETA(190)/7.61878061207001043E-03, &\n 2.83219055545628054E-03, &\n -2.09841352012720090E-03, &\n -5.73826764216626498E-03, &\n -7.70804244495414620E-03, &\n -8.21011692264844401E-03, &\n -7.65824520346905413E-03, &\n -6.47209729391045177E-03/\n DATA BETA(191), BETA(192), BETA(193), BETA(194), &\n BETA(195), BETA(196), BETA(197), BETA(198), &\n BETA(199), BETA(200), BETA(201), &\n BETA(202)/-4.99132412004966473E-03, &\n -3.45612289713133280E-03, &\n -2.01785580014170775E-03, &\n -7.59430686781961401E-04, &\n 2.84173631523859138E-04, &\n 1.10891667586337403E-03, &\n 1.72901493872728771E-03, &\n 2.16812590802684701E-03, &\n 2.45357710494539735E-03, &\n 2.61281821058334862E-03, &\n 2.67141039656276912E-03, &\n 2.65203073395980430E-03/\n DATA BETA(203), BETA(204), BETA(205), BETA(206), &\n BETA(207), BETA(208), BETA(209), &\n BETA(210)/2.57411652877287315E-03, &\n 2.45389126236094427E-03, &\n 2.30460058071795494E-03, &\n 2.13684837686712662E-03, &\n 1.95896528478870911E-03, &\n 1.77737008679454412E-03, &\n 1.59690280765839059E-03, &\n 1.42111975664438546E-03/\n DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), &\n GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), &\n GAMA(11), GAMA(12), GAMA(13), &\n GAMA(14)/6.29960524947436582E-01, &\n 2.51984209978974633E-01, &\n 1.54790300415655846E-01, &\n 1.10713062416159013E-01, &\n 8.57309395527394825E-02, &\n 6.97161316958684292E-02, &\n 5.86085671893713576E-02, &\n 5.04698873536310685E-02, &\n 4.42600580689154809E-02, &\n 3.93720661543509966E-02, &\n 3.54283195924455368E-02, &\n 3.21818857502098231E-02, &\n 2.94646240791157679E-02, &\n 2.71581677112934479E-02/\n DATA GAMA(15), GAMA(16), GAMA(17), GAMA(18), &\n GAMA(19), GAMA(20), GAMA(21), &\n GAMA(22)/2.51768272973861779E-02, &\n 2.34570755306078891E-02, &\n 2.19508390134907203E-02, &\n 2.06210828235646240E-02, &\n 1.94388240897880846E-02, &\n 1.83810633800683158E-02, &\n 1.74293213231963172E-02, &\n 1.65685837786612353E-02/\n DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), &\n GAMA(27), GAMA(28), GAMA(29), &\n GAMA(30)/1.57865285987918445E-02, &\n 1.50729501494095594E-02, &\n 1.44193250839954639E-02, &\n 1.38184805735341786E-02, &\n 1.32643378994276568E-02, &\n 1.27517121970498651E-02, &\n 1.22761545318762767E-02, &\n 1.18338262398482403E-02/\n DATA EX1, EX2, HPI, PI, THPI/3.33333333333333333E-01, &\n 6.66666666666666667E-01, &\n 1.57079632679489662E+00, &\n 3.14159265358979324E+00, &\n 4.71238898038468986E+00/\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n RFNU = 1.0E0/FNU\n TSTR = REAL(Z)\n TSTI = AIMAG(Z)\n TEST = FNU*EXP(-ELIM)\n if (ABS(TSTR) < TEST) TSTR = 0.0E0\n if (ABS(TSTI) < TEST) TSTI = 0.0E0\n if (TSTR == 0.0E0 .and. TSTI == 0.0E0) then\n ZETA1 = CMPLX(ELIM+ELIM+FNU,0.0E0)\n ZETA2 = CMPLX(FNU,0.0E0)\n PHI = CONE\n ARG = CONE\n return\n endif\n ZB = CMPLX(TSTR,TSTI)*CMPLX(RFNU,0.0E0)\n RFNU2 = RFNU*RFNU\n! ------------------------------------------------------------------\n! COMPUTE IN THE FOURTH QUADRANT\n! ------------------------------------------------------------------\n FN13 = FNU**EX1\n FN23 = FN13*FN13\n RFN13 = CMPLX(1.0E0/FN13,0.0E0)\n W2 = CONE - ZB*ZB\n AW2 = ABS(W2)\n if (AW2 > 0.25E0) then\n! ---------------------------------------------------------------\n! CABS(W2)>0.25E0\n! ---------------------------------------------------------------\n W = SQRT(W2)\n WR = REAL(W)\n WI = AIMAG(W)\n if (WR < 0.0E0) WR = 0.0E0\n if (WI < 0.0E0) WI = 0.0E0\n W = CMPLX(WR,WI)\n ZA = (CONE+W)/ZB\n ZC = LOG(ZA)\n ZCR = REAL(ZC)\n ZCI = AIMAG(ZC)\n if (ZCI < 0.0E0) ZCI = 0.0E0\n if (ZCI > HPI) ZCI = HPI\n if (ZCR < 0.0E0) ZCR = 0.0E0\n ZC = CMPLX(ZCR,ZCI)\n ZTH = (ZC-W)*CMPLX(1.5E0,0.0E0)\n CFNU = CMPLX(FNU,0.0E0)\n ZETA1 = ZC*CFNU\n ZETA2 = W*CFNU\n AZTH = ABS(ZTH)\n ZTHR = REAL(ZTH)\n ZTHI = AIMAG(ZTH)\n ANG = THPI\n if (ZTHR < 0.0E0 .or. ZTHI >= 0.0E0) then\n ANG = HPI\n if (ZTHR /= 0.0E0) then\n ANG = ATAN(ZTHI/ZTHR)\n if (ZTHR < 0.0E0) ANG = ANG + PI\n endif\n endif\n PP = AZTH**EX2\n ANG = ANG*EX2\n ZETAR = PP*COS(ANG)\n ZETAI = PP*SIN(ANG)\n if (ZETAI < 0.0E0) ZETAI = 0.0E0\n ZETA = CMPLX(ZETAR,ZETAI)\n ARG = ZETA*CMPLX(FN23,0.0E0)\n RTZTA = ZTH/ZETA\n ZA = RTZTA/W\n PHI = SQRT(ZA+ZA)*RFN13\n if (IPMTR /= 1) then\n TFN = CMPLX(RFNU,0.0E0)/W\n RZTH = CMPLX(RFNU,0.0E0)/ZTH\n ZC = RZTH*CMPLX(AR(2),0.0E0)\n T2 = CONE/W2\n UP(2) = (T2*CMPLX(C(2),0.0E0)+CMPLX(C(3),0.0E0))*TFN\n BSUM = UP(2) + ZC\n ASUM = CZERO\n if (RFNU >= TOL) then\n PRZTH = RZTH\n PTFN = TFN\n UP(1) = CONE\n PP = 1.0E0\n BSUMR = REAL(BSUM)\n BSUMI = AIMAG(BSUM)\n BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI))\n KS = 0\n KP1 = 2\n L = 3\n IAS = 0\n IBS = 0\n DO 100 LR = 2, 12, 2\n LRP1 = LR + 1\n! ------------------------------------------------------\n! COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE\n! TERMS IN NEXT SUMA AND SUMB\n! ------------------------------------------------------\n DO 40 K = LR, LRP1\n KS = KS + 1\n KP1 = KP1 + 1\n L = L + 1\n ZA = CMPLX(C(L),0.0E0)\n DO 20 J = 2, KP1\n L = L + 1\n ZA = ZA*T2 + CMPLX(C(L),0.0E0)\n 20 continue\n PTFN = PTFN*TFN\n UP(KP1) = PTFN*ZA\n CR(KS) = PRZTH*CMPLX(BR(KS+1),0.0E0)\n PRZTH = PRZTH*RZTH\n DR(KS) = PRZTH*CMPLX(AR(KS+2),0.0E0)\n 40 continue\n PP = PP*RFNU2\n if (IAS /= 1) then\n SUMA = UP(LRP1)\n JU = LRP1\n DO 60 JR = 1, LR\n JU = JU - 1\n SUMA = SUMA + CR(JR)*UP(JU)\n 60 continue\n ASUM = ASUM + SUMA\n ASUMR = REAL(ASUM)\n ASUMI = AIMAG(ASUM)\n TEST = ABS(ASUMR) + ABS(ASUMI)\n if (PP < TOL .and. TEST < TOL) IAS = 1\n endif\n if (IBS /= 1) then\n SUMB = UP(LR+2) + UP(LRP1)*ZC\n JU = LRP1\n DO 80 JR = 1, LR\n JU = JU - 1\n SUMB = SUMB + DR(JR)*UP(JU)\n 80 continue\n BSUM = BSUM + SUMB\n BSUMR = REAL(BSUM)\n BSUMI = AIMAG(BSUM)\n TEST = ABS(BSUMR) + ABS(BSUMI)\n if (PP < BTOL .and. TEST < TOL) IBS = 1\n endif\n if (IAS == 1 .and. IBS == 1) goto 120\n 100 continue\n endif\n 120 ASUM = ASUM + CONE\n BSUM = -BSUM*RFN13/RTZTA\n endif\n ELSE\n! ---------------------------------------------------------------\n! POWER SERIES FOR CABS(W2) <= 0.25E0\n! ---------------------------------------------------------------\n K = 1\n P(1) = CONE\n SUMA = CMPLX(GAMA(1),0.0E0)\n AP(1) = 1.0E0\n if (AW2 >= TOL) then\n DO 140 K = 2, 30\n P(K) = P(K-1)*W2\n SUMA = SUMA + P(K)*CMPLX(GAMA(K),0.0E0)\n AP(K) = AP(K-1)*AW2\n if (AP(K) < TOL) goto 160\n 140 continue\n K = 30\n endif\n 160 KMAX = K\n ZETA = W2*SUMA\n ARG = ZETA*CMPLX(FN23,0.0E0)\n ZA = SQRT(SUMA)\n ZETA2 = SQRT(W2)*CMPLX(FNU,0.0E0)\n ZETA1 = ZETA2*(CONE+ZETA*ZA*CMPLX(EX2,0.0E0))\n ZA = ZA + ZA\n PHI = SQRT(ZA)*RFN13\n if (IPMTR /= 1) then\n! ------------------------------------------------------------\n! SUM SERIES FOR ASUM AND BSUM\n! ------------------------------------------------------------\n SUMB = CZERO\n DO 180 K = 1, KMAX\n SUMB = SUMB + P(K)*CMPLX(BETA(K),0.0E0)\n 180 continue\n ASUM = CZERO\n BSUM = SUMB\n L1 = 0\n L2 = 30\n BTOL = TOL*ABS(BSUM)\n ATOL = TOL\n PP = 1.0E0\n IAS = 0\n IBS = 0\n if (RFNU2 >= TOL) then\n DO 280 IS = 2, 7\n ATOL = ATOL/RFNU2\n PP = PP*RFNU2\n if (IAS /= 1) then\n SUMA = CZERO\n DO 200 K = 1, KMAX\n M = L1 + K\n SUMA = SUMA + P(K)*CMPLX(ALFA(M),0.0E0)\n if (AP(K) < ATOL) goto 220\n 200 continue\n 220 ASUM = ASUM + SUMA*CMPLX(PP,0.0E0)\n if (PP < TOL) IAS = 1\n endif\n if (IBS /= 1) then\n SUMB = CZERO\n DO 240 K = 1, KMAX\n M = L2 + K\n SUMB = SUMB + P(K)*CMPLX(BETA(M),0.0E0)\n if (AP(K) < ATOL) goto 260\n 240 continue\n 260 BSUM = BSUM + SUMB*CMPLX(PP,0.0E0)\n if (PP < BTOL) IBS = 1\n endif\n if (IAS == 1 .and. IBS == 1) then\n goto 300\n ELSE\n L1 = L1 + 30\n L2 = L2 + 30\n endif\n 280 continue\n endif\n 300 ASUM = ASUM + CONE\n PP = RFNU*REAL(RFN13)\n BSUM = BSUM*CMPLX(PP,0.0E0)\n endif\n endif\n return\n END\n subroutine DEVS17(Z,FNU,KODE,IKFLG,N,Y,NUF,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-765 (DEC 1989).\n!\n! Original name: CUOIK\n!\n! DEVS17 COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC\n! EXPANSIONS FOR THE I AND K functionS AND COMPARES THEM\n! (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW\n! WHERE ALIM < ELIM. IF THE MAGNITUDE, BASED ON THE LEADING\n! EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN\n! THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER\n! MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE\n! EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)=\n! EXP(-ELIM)/TOL\n!\n! IKFLG=1 MEANS THE I SEQUENCE IS TESTED\n! =2 MEANS THE K SEQUENCE IS TESTED\n! NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE\n! =-1 MEANS AN OVERFLOW WOULD OCCUR\n! IKFLG=1 AND NUF>0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO\n! THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE\n! IKFLG=2 AND NUF==N MEANS ALL Y VALUES WERE SET TO ZERO\n! IKFLG=2 AND 0 < NUF < N NOT CONSIDERED. Y MUST BE SET BY\n! ANOTHER ROUTINE\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER IKFLG, KODE, N, NUF\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX ARG, ASUM, BSUM, CZ, CZERO, PHI, SUM, ZB, ZETA1, &\n ZETA2, ZN, ZR\n REAL AARG, AIC, APHI, ASCLE, AX, AY, FNN, GNN, GNU, &\n RCZ, X, YY\n INTEGER I, IFORM, INIT, NN, NW\n! .. Local Arrays ..\n COMPLEX CWRK(16)\n! .. External functions ..\n REAL X02AME\n EXTERNAL X02AME\n! .. External subroutines ..\n EXTERNAL DEUS17, DEWS17, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, CONJG, COS, EXP, LOG, MAX, &\n REAL, SIN\n! .. Data statements ..\n DATA CZERO/(0.0E0,0.0E0)/\n DATA AIC/1.265512123484645396E+00/\n! .. Executable Statements ..\n!\n NUF = 0\n NN = N\n X = REAL(Z)\n ZR = Z\n if (X < 0.0E0) ZR = -Z\n ZB = ZR\n YY = AIMAG(ZR)\n AX = ABS(X)*1.7321E0\n AY = ABS(YY)\n IFORM = 1\n if (AY > AX) IFORM = 2\n GNU = MAX(FNU,1.0E0)\n if (IKFLG /= 1) then\n FNN = NN\n GNN = FNU + FNN - 1.0E0\n GNU = MAX(GNN,FNN)\n endif\n! ------------------------------------------------------------------\n! ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE\n! REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET\n! THE SIGN OF THE IMAGINARY PART CORRECT.\n! ------------------------------------------------------------------\n if (IFORM == 2) then\n ZN = -ZR*CMPLX(0.0E0,1.0E0)\n if (YY <= 0.0E0) ZN = CONJG(-ZN)\n CALL DEUS17(ZN,GNU,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM,BSUM,ELIM)\n CZ = -ZETA1 + ZETA2\n AARG = ABS(ARG)\n ELSE\n INIT = 0\n CALL DEWS17(ZR,GNU,IKFLG,1,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK, &\n ELIM)\n CZ = -ZETA1 + ZETA2\n endif\n if (KODE == 2) CZ = CZ - ZB\n if (IKFLG == 2) CZ = -CZ\n APHI = ABS(PHI)\n RCZ = REAL(CZ)\n! ------------------------------------------------------------------\n! OVERFLOW TEST\n! ------------------------------------------------------------------\n if (RCZ <= ELIM) then\n if (RCZ < ALIM) then\n! ------------------------------------------------------------\n! UNDERFLOW TEST\n! ------------------------------------------------------------\n if (RCZ >= (-ELIM)) then\n if (RCZ > (-ALIM)) then\n goto 40\n ELSE\n RCZ = RCZ + LOG(APHI)\n if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC\n if (RCZ > (-ELIM)) then\n ASCLE = (1.0E+3*X02AME())/TOL\n CZ = CZ + LOG(PHI)\n if (IFORM /= 1) CZ = CZ - CMPLX(0.25E0,0.0E0) &\n *LOG(ARG) - CMPLX(AIC,0.0E0)\n AX = EXP(RCZ)/TOL\n AY = AIMAG(CZ)\n CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY))\n CALL DGVS17(CZ,NW,ASCLE,TOL)\n if (NW /= 1) goto 40\n endif\n endif\n endif\n DO 20 I = 1, NN\n Y(I) = CZERO\n 20 continue\n NUF = NN\n return\n ELSE\n RCZ = RCZ + LOG(APHI)\n if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC\n if (RCZ > ELIM) goto 80\n endif\n 40 if (IKFLG /= 2) then\n if (N /= 1) then\n 60 continue\n! ---------------------------------------------------------\n! SET UNDERFLOWS ON I SEQUENCE\n! ---------------------------------------------------------\n GNU = FNU + NN - 1\n if (IFORM == 2) then\n CALL DEUS17(ZN,GNU,1,TOL,PHI,ARG,ZETA1,ZETA2,ASUM, &\n BSUM,ELIM)\n CZ = -ZETA1 + ZETA2\n AARG = ABS(ARG)\n ELSE\n INIT = 0\n CALL DEWS17(ZR,GNU,IKFLG,1,TOL,INIT,PHI,ZETA1,ZETA2, &\n SUM,CWRK,ELIM)\n CZ = -ZETA1 + ZETA2\n endif\n if (KODE == 2) CZ = CZ - ZB\n APHI = ABS(PHI)\n RCZ = REAL(CZ)\n if (RCZ >= (-ELIM)) then\n if (RCZ > (-ALIM)) then\n return\n ELSE\n RCZ = RCZ + LOG(APHI)\n if (IFORM == 2) RCZ = RCZ - 0.25E0*LOG(AARG) - AIC\n if (RCZ > (-ELIM)) then\n ASCLE = (1.0E+3*X02AME())/TOL\n CZ = CZ + LOG(PHI)\n if (IFORM /= 1) CZ = CZ - CMPLX(0.25E0,0.0E0) &\n *LOG(ARG) - CMPLX(AIC, &\n 0.0E0)\n AX = EXP(RCZ)/TOL\n AY = AIMAG(CZ)\n CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY))\n CALL DGVS17(CZ,NW,ASCLE,TOL)\n if (NW /= 1) return\n endif\n endif\n endif\n Y(NN) = CZERO\n NN = NN - 1\n NUF = NUF + 1\n if (NN /= 0) goto 60\n endif\n endif\n return\n endif\n 80 NUF = -1\n return\n END\n subroutine DEWS17(ZR,FNU,IKFLG,IPMTR,TOL,INIT,PHI,ZETA1,ZETA2,SUM, &\n CWRK,ELIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-766 (DEC 1989).\n!\n! Original name: CUNIK\n!\n! DEWS17 COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC\n! EXPANSIONS OF THE I AND K functionS ON IKFLG= 1 OR 2\n! RESPECTIVELY BY\n!\n! W(FNU,ZR) = PHI*EXP(ZETA)*SUM\n!\n! WHERE ZETA=-ZETA1 + ZETA2 OR\n! ZETA1 - ZETA2\n!\n! THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE\n! SAME ZR AND FNU WILL return THE I OR K function ON IKFLG=\n! 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK\n! ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI,\n! ZETA1,ZETA2.\n!\n! .. Scalar Arguments ..\n COMPLEX PHI, SUM, ZETA1, ZETA2, ZR\n REAL ELIM, FNU, TOL\n INTEGER IKFLG, INIT, IPMTR\n! .. Array Arguments ..\n COMPLEX CWRK(16)\n! .. Local Scalars ..\n COMPLEX CFN, CONE, CRFN, CZERO, S, SR, T, T2, ZN\n REAL AC, RFN, TEST, TSTI, TSTR\n INTEGER I, J, K, L\n! .. Local Arrays ..\n COMPLEX CON(2)\n REAL C(120)\n!bc\n! .. external functions ..\n real x02ane\n external x02ane\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, EXP, LOG, REAL, SQRT\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n DATA CON(1), CON(2)/(3.98942280401432678E-01,0.0E0), &\n (1.25331413731550025E+00,0.0E0)/\n DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), &\n C(9), C(10), C(11), C(12), C(13), C(14), C(15), &\n C(16)/1.00000000000000000E+00, &\n -2.08333333333333333E-01, &\n 1.25000000000000000E-01, &\n 3.34201388888888889E-01, &\n -4.01041666666666667E-01, &\n 7.03125000000000000E-02, &\n -1.02581259645061728E+00, &\n 1.84646267361111111E+00, &\n -8.91210937500000000E-01, &\n 7.32421875000000000E-02, &\n 4.66958442342624743E+00, &\n -1.12070026162229938E+01, &\n 8.78912353515625000E+00, &\n -2.36408691406250000E+00, &\n 1.12152099609375000E-01, &\n -2.82120725582002449E+01/\n DATA C(17), C(18), C(19), C(20), C(21), C(22), C(23), &\n C(24)/8.46362176746007346E+01, &\n -9.18182415432400174E+01, &\n 4.25349987453884549E+01, &\n -7.36879435947963170E+00, &\n 2.27108001708984375E-01, &\n 2.12570130039217123E+02, &\n -7.65252468141181642E+02, &\n 1.05999045252799988E+03/\n DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), &\n C(32), C(33), C(34), C(35), C(36), C(37), C(38), &\n C(39), C(40)/-6.99579627376132541E+02, &\n 2.18190511744211590E+02, &\n -2.64914304869515555E+01, &\n 5.72501420974731445E-01, &\n -1.91945766231840700E+03, &\n 8.06172218173730938E+03, &\n -1.35865500064341374E+04, &\n 1.16553933368645332E+04, &\n -5.30564697861340311E+03, &\n 1.20090291321635246E+03, &\n -1.08090919788394656E+02, &\n 1.72772750258445740E+00, &\n 2.02042913309661486E+04, &\n -9.69805983886375135E+04, &\n 1.92547001232531532E+05, &\n -2.03400177280415534E+05/\n DATA C(41), C(42), C(43), C(44), C(45), C(46), C(47), &\n C(48)/1.22200464983017460E+05, &\n -4.11926549688975513E+04, &\n 7.10951430248936372E+03, &\n -4.93915304773088012E+02, &\n 6.07404200127348304E+00, &\n -2.42919187900551333E+05, &\n 1.31176361466297720E+06, &\n -2.99801591853810675E+06/\n DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), &\n C(56), C(57), C(58), C(59), C(60), C(61), C(62), &\n C(63), C(64)/3.76327129765640400E+06, &\n -2.81356322658653411E+06, &\n 1.26836527332162478E+06, &\n -3.31645172484563578E+05, &\n 4.52187689813627263E+04, &\n -2.49983048181120962E+03, &\n 2.43805296995560639E+01, &\n 3.28446985307203782E+06, &\n -1.97068191184322269E+07, &\n 5.09526024926646422E+07, &\n -7.41051482115326577E+07, &\n 6.63445122747290267E+07, &\n -3.75671766607633513E+07, &\n 1.32887671664218183E+07, &\n -2.78561812808645469E+06, &\n 3.08186404612662398E+05/\n DATA C(65), C(66), C(67), C(68), C(69), C(70), C(71), &\n C(72)/-1.38860897537170405E+04, &\n 1.10017140269246738E+02, &\n -4.93292536645099620E+07, &\n 3.25573074185765749E+08, &\n -9.39462359681578403E+08, &\n 1.55359689957058006E+09, &\n -1.62108055210833708E+09, &\n 1.10684281682301447E+09/\n DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), &\n C(80), C(81), C(82), C(83), C(84), C(85), C(86), &\n C(87), C(88)/-4.95889784275030309E+08, &\n 1.42062907797533095E+08, &\n -2.44740627257387285E+07, &\n 2.24376817792244943E+06, &\n -8.40054336030240853E+04, &\n 5.51335896122020586E+02, &\n 8.14789096118312115E+08, &\n -5.86648149205184723E+09, &\n 1.86882075092958249E+10, &\n -3.46320433881587779E+10, &\n 4.12801855797539740E+10, &\n -3.30265997498007231E+10, &\n 1.79542137311556001E+10, &\n -6.56329379261928433E+09, &\n 1.55927986487925751E+09, &\n -2.25105661889415278E+08/\n DATA C(89), C(90), C(91), C(92), C(93), C(94), C(95), &\n C(96)/1.73951075539781645E+07, &\n -5.49842327572288687E+05, &\n 3.03809051092238427E+03, &\n -1.46792612476956167E+10, &\n 1.14498237732025810E+11, &\n -3.99096175224466498E+11, &\n 8.19218669548577329E+11, &\n -1.09837515608122331E+12/\n DATA C(97), C(98), C(99), C(100), C(101), C(102), &\n C(103), C(104), C(105), C(106), C(107), C(108), &\n C(109), C(110)/1.00815810686538209E+12, &\n -6.45364869245376503E+11, &\n 2.87900649906150589E+11, &\n -8.78670721780232657E+10, &\n 1.76347306068349694E+10, &\n -2.16716498322379509E+09, &\n 1.43157876718888981E+08, &\n -3.87183344257261262E+06, &\n 1.82577554742931747E+04, &\n 2.86464035717679043E+11, &\n -2.40629790002850396E+12, &\n 9.10934118523989896E+12, &\n -2.05168994109344374E+13, &\n 3.05651255199353206E+13/\n DATA C(111), C(112), C(113), C(114), C(115), C(116), &\n C(117), C(118), C(119), &\n C(120)/-3.16670885847851584E+13, &\n 2.33483640445818409E+13, &\n -1.23204913055982872E+13, &\n 4.61272578084913197E+12, &\n -1.19655288019618160E+12, &\n 2.05914503232410016E+11, &\n -2.18229277575292237E+10, &\n 1.24700929351271032E+09, &\n -2.91883881222208134E+07, &\n 1.18838426256783253E+05/\n! .. Executable Statements ..\n!\n if (INIT == 0) then\n! ---------------------------------------------------------------\n! INITIALIZE ALL VARIABLES\n! ---------------------------------------------------------------\n RFN = 1.0E0/FNU\n CRFN = CMPLX(RFN,0.0E0)\n TSTR = REAL(ZR)\n TSTI = AIMAG(ZR)\n TEST = FNU*EXP(-ELIM)\n if (ABS(TSTR) < TEST) TSTR = 0.0E0\n if (ABS(TSTI) < TEST) TSTI = 0.0E0\n!bc if (TSTR==0.0E0 .and. TSTI==0.0E0) then\n if (abs(tstr) <= x02ane() .and. abs(tsti) <= x02ane()) then\n ZETA1 = CMPLX(ELIM+ELIM+FNU,0.0E0)\n ZETA2 = CMPLX(FNU,0.0E0)\n PHI = CONE\n return\n endif\n T = CMPLX(TSTR,TSTI)*CRFN\n S = CONE + T*T\n SR = SQRT(S)\n CFN = CMPLX(FNU,0.0E0)\n ZN = (CONE+SR)/T\n ZETA1 = CFN*LOG(ZN)\n ZETA2 = CFN*SR\n T = CONE/SR\n SR = T*CRFN\n CWRK(16) = SQRT(SR)\n PHI = CWRK(16)*CON(IKFLG)\n if (IPMTR /= 0) then\n return\n ELSE\n T2 = CONE/S\n CWRK(1) = CONE\n CRFN = CONE\n AC = 1.0E0\n L = 1\n DO 40 K = 2, 15\n S = CZERO\n DO 20 J = 1, K\n L = L + 1\n S = S*T2 + CMPLX(C(L),0.0E0)\n 20 continue\n CRFN = CRFN*SR\n CWRK(K) = CRFN*S\n AC = AC*RFN\n TSTR = REAL(CWRK(K))\n TSTI = AIMAG(CWRK(K))\n TEST = ABS(TSTR) + ABS(TSTI)\n if (AC < TOL .and. TEST < TOL) goto 60\n 40 continue\n K = 15\n 60 INIT = K\n endif\n endif\n if (IKFLG == 2) then\n! ---------------------------------------------------------------\n! COMPUTE SUM FOR THE K function\n! ---------------------------------------------------------------\n S = CZERO\n T = CONE\n DO 80 I = 1, INIT\n S = S + T*CWRK(I)\n T = -T\n 80 continue\n SUM = S\n PHI = CWRK(16)*CON(2)\n ELSE\n! ---------------------------------------------------------------\n! COMPUTE SUM FOR THE I function\n! ---------------------------------------------------------------\n S = CZERO\n DO 100 I = 1, INIT\n S = S + CWRK(I)\n 100 continue\n SUM = S\n PHI = CWRK(16)*CON(1)\n endif\n return\n END\n subroutine DEXS17(Z,FNU,KODE,N,Y,NZ,NLAST,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-767 (DEC 1989).\n!\n! Original name: CUNI1\n!\n! DEXS17 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC\n! EXPANSION FOR I(FNU,Z) IN -PI/3 <= ARG Z <= PI/3.\n!\n! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC\n! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.\n! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER\n! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL.\n! Y(I)=CZERO FOR I=NLAST+1,N\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, TOL\n INTEGER KODE, N, NLAST, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CFN, CONE, CRSC, CSCL, CZERO, PHI, RZ, &\n S1, S2, SUM, ZETA1, ZETA2\n REAL APHI, ASCLE, C2I, C2M, C2R, FN, RS1, YY\n INTEGER I, IFLAG, INIT, K, M, ND, NN, NUF, NW\n! .. Local Arrays ..\n COMPLEX CSR(3), CSS(3), CWRK(16), CY(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEVS17, DEWS17, DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MAX, MIN, &\n REAL, SIN\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n ND = N\n NLAST = 0\n! ------------------------------------------------------------------\n! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-\n! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,\n! EXP(ALIM)=EXP(ELIM)*TOL\n! ------------------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n! ------------------------------------------------------------------\n! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER\n! ------------------------------------------------------------------\n FN = MAX(FNU,1.0E0)\n INIT = 0\n CALL DEWS17(Z,FN,1,1,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK,ELIM)\n if (KODE == 1) then\n S1 = -ZETA1 + ZETA2\n ELSE\n CFN = CMPLX(FN,0.0E0)\n S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2))\n endif\n RS1 = REAL(S1)\n if (ABS(RS1) <= ELIM) then\n 20 continue\n NN = MIN(2,ND)\n DO 40 I = 1, NN\n FN = FNU + ND - I\n INIT = 0\n CALL DEWS17(Z,FN,1,0,TOL,INIT,PHI,ZETA1,ZETA2,SUM,CWRK,ELIM)\n if (KODE == 1) then\n S1 = -ZETA1 + ZETA2\n ELSE\n CFN = CMPLX(FN,0.0E0)\n YY = AIMAG(Z)\n S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + CMPLX(0.0E0,YY)\n endif\n! ------------------------------------------------------------\n! TEST FOR UNDERFLOW AND OVERFLOW\n! ------------------------------------------------------------\n RS1 = REAL(S1)\n if (ABS(RS1) > ELIM) then\n goto 60\n ELSE\n if (I == 1) IFLAG = 2\n if (ABS(RS1) >= ALIM) then\n! ------------------------------------------------------\n! REFINE TEST AND SCALE\n! ------------------------------------------------------\n APHI = ABS(PHI)\n RS1 = RS1 + LOG(APHI)\n if (ABS(RS1) > ELIM) then\n goto 60\n ELSE\n if (I == 1) IFLAG = 1\n if (RS1 >= 0.0E0) then\n if (I == 1) IFLAG = 3\n endif\n endif\n endif\n! ---------------------------------------------------------\n! SCALE S1 IF CABS(S1) < ASCLE\n! ---------------------------------------------------------\n S2 = PHI*SUM\n C2R = REAL(S1)\n C2I = AIMAG(S1)\n C2M = EXP(C2R)*REAL(CSS(IFLAG))\n S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I))\n S2 = S2*S1\n if (IFLAG == 1) then\n CALL DGVS17(S2,NW,BRY(1),TOL)\n if (NW /= 0) goto 60\n endif\n M = ND - I + 1\n CY(I) = S2\n Y(M) = S2*CSR(IFLAG)\n endif\n 40 continue\n goto 80\n! ---------------------------------------------------------------\n! SET UNDERFLOW AND UPDATE PARAMETERS\n! ---------------------------------------------------------------\n 60 continue\n if (RS1 > 0.0E0) then\n goto 160\n ELSE\n Y(ND) = CZERO\n NZ = NZ + 1\n ND = ND - 1\n if (ND == 0) then\n return\n ELSE\n CALL DEVS17(Z,FNU,KODE,1,ND,Y,NUF,TOL,ELIM,ALIM)\n if (NUF < 0) then\n goto 160\n ELSE\n ND = ND - NUF\n NZ = NZ + NUF\n if (ND == 0) then\n return\n ELSE\n FN = FNU + ND - 1\n if (FN >= FNUL) then\n goto 20\n ELSE\n goto 120\n endif\n endif\n endif\n endif\n endif\n 80 if (ND > 2) then\n RZ = CMPLX(2.0E0,0.0E0)/Z\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n S1 = CY(1)\n S2 = CY(2)\n C1 = CSR(IFLAG)\n ASCLE = BRY(IFLAG)\n K = ND - 2\n FN = K\n DO 100 I = 3, ND\n C2 = S2\n S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2\n S1 = C2\n C2 = S2*C1\n Y(K) = C2\n K = K - 1\n FN = FN - 1.0E0\n if (IFLAG < 3) then\n C2R = REAL(C2)\n C2I = AIMAG(C2)\n C2R = ABS(C2R)\n C2I = ABS(C2I)\n C2M = MAX(C2R,C2I)\n if (C2M > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*C1\n S2 = C2\n S1 = S1*CSS(IFLAG)\n S2 = S2*CSS(IFLAG)\n C1 = CSR(IFLAG)\n endif\n endif\n 100 continue\n endif\n return\n 120 NLAST = ND\n return\n else if (RS1 <= 0.0E0) then\n NZ = N\n DO 140 I = 1, N\n Y(I) = CZERO\n 140 continue\n return\n endif\n 160 NZ = -1\n return\n END\n subroutine DEYS17(Z,FNU,KODE,N,Y,NZ,NUI,NLAST,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-768 (DEC 1989).\n!\n! Original name: CBUNI\n!\n! DEYS17 COMPUTES THE I BESSEL function FOR LARGE CABS(Z)>\n! FNUL AND FNU+N-1 < FNUL. THE ORDER IS INCREASED FROM\n! FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING\n! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z)\n! ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, TOL\n INTEGER KODE, N, NLAST, NUI, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX CSCL, CSCR, RZ, S1, S2, ST\n REAL ASCLE, AX, AY, DFNU, FNUI, GNU, STI, STM, STR, &\n XX, YY\n INTEGER I, IFLAG, IFORM, K, NL, NW\n! .. Local Arrays ..\n COMPLEX CY(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME\n EXTERNAL X02AME\n! .. External subroutines ..\n EXTERNAL DETS17, DEXS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, MAX, REAL\n! .. Executable Statements ..\n!\n NZ = 0\n XX = REAL(Z)\n YY = AIMAG(Z)\n AX = ABS(XX)*1.7321E0\n AY = ABS(YY)\n IFORM = 1\n if (AY > AX) IFORM = 2\n if (NUI == 0) then\n if (IFORM == 2) then\n! ------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU\n! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I\n! AND HPI=PI/2\n! ------------------------------------------------------------\n CALL DETS17(Z,FNU,KODE,N,Y,NW,NLAST,FNUL,TOL,ELIM,ALIM)\n ELSE\n! ------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN\n! -PI/3 <= ARG(Z) <= PI/3\n! ------------------------------------------------------------\n CALL DEXS17(Z,FNU,KODE,N,Y,NW,NLAST,FNUL,TOL,ELIM,ALIM)\n endif\n if (NW >= 0) then\n NZ = NW\n return\n endif\n ELSE\n FNUI = NUI\n DFNU = FNU + N - 1\n GNU = DFNU + FNUI\n if (IFORM == 2) then\n! ------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU\n! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I\n! AND HPI=PI/2\n! ------------------------------------------------------------\n CALL DETS17(Z,GNU,KODE,2,CY,NW,NLAST,FNUL,TOL,ELIM,ALIM)\n ELSE\n! ------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN\n! -PI/3 <= ARG(Z) <= PI/3\n! ------------------------------------------------------------\n CALL DEXS17(Z,GNU,KODE,2,CY,NW,NLAST,FNUL,TOL,ELIM,ALIM)\n endif\n if (NW >= 0) then\n if (NW /= 0) then\n NLAST = N\n ELSE\n AY = ABS(CY(1))\n! ---------------------------------------------------------\n! SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER\n! USED\n! ---------------------------------------------------------\n BRY(1) = (1.0E+3*X02AME())/TOL\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = BRY(2)\n IFLAG = 2\n ASCLE = BRY(2)\n AX = 1.0E0\n CSCL = CMPLX(AX,0.0E0)\n if (AY <= BRY(1)) then\n IFLAG = 1\n ASCLE = BRY(1)\n AX = 1.0E0/TOL\n CSCL = CMPLX(AX,0.0E0)\n else if (AY >= BRY(2)) then\n IFLAG = 3\n ASCLE = BRY(3)\n AX = TOL\n CSCL = CMPLX(AX,0.0E0)\n endif\n AY = 1.0E0/AX\n CSCR = CMPLX(AY,0.0E0)\n S1 = CY(2)*CSCL\n S2 = CY(1)*CSCL\n RZ = CMPLX(2.0E0,0.0E0)/Z\n DO 20 I = 1, NUI\n ST = S2\n S2 = CMPLX(DFNU+FNUI,0.0E0)*RZ*S2 + S1\n S1 = ST\n FNUI = FNUI - 1.0E0\n if (IFLAG < 3) then\n ST = S2*CSCR\n STR = REAL(ST)\n STI = AIMAG(ST)\n STR = ABS(STR)\n STI = ABS(STI)\n STM = MAX(STR,STI)\n if (STM > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*CSCR\n S2 = ST\n AX = AX*TOL\n AY = 1.0E0/AX\n CSCL = CMPLX(AX,0.0E0)\n CSCR = CMPLX(AY,0.0E0)\n S1 = S1*CSCL\n S2 = S2*CSCL\n endif\n endif\n 20 continue\n Y(N) = S2*CSCR\n if (N /= 1) then\n NL = N - 1\n FNUI = NL\n K = NL\n DO 40 I = 1, NL\n ST = S2\n S2 = CMPLX(FNU+FNUI,0.0E0)*RZ*S2 + S1\n S1 = ST\n ST = S2*CSCR\n Y(K) = ST\n FNUI = FNUI - 1.0E0\n K = K - 1\n if (IFLAG < 3) then\n STR = REAL(ST)\n STI = AIMAG(ST)\n STR = ABS(STR)\n STI = ABS(STI)\n STM = MAX(STR,STI)\n if (STM > ASCLE) then\n IFLAG = IFLAG + 1\n ASCLE = BRY(IFLAG)\n S1 = S1*CSCR\n S2 = ST\n AX = AX*TOL\n AY = 1.0E0/AX\n CSCL = CMPLX(AX,0.0E0)\n CSCR = CMPLX(AY,0.0E0)\n S1 = S1*CSCL\n S2 = S2*CSCL\n endif\n endif\n 40 continue\n endif\n endif\n return\n endif\n endif\n NZ = -1\n if (NW == (-2)) NZ = -2\n return\n END\n subroutine DEZS17(Z,FNU,KODE,N,CY,NZ,RL,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-769 (DEC 1989).\n!\n! Original name: CBINU\n!\n! DEZS17 COMPUTES THE I function IN THE RIGHT HALF Z PLANE\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, RL, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX CY(N)\n! .. Local Scalars ..\n COMPLEX CZERO\n REAL AZ, DFNU\n INTEGER I, INW, NLAST, NN, NUI, NW\n! .. Local Arrays ..\n COMPLEX CW(2)\n! .. External subroutines ..\n EXTERNAL DESS17, DEVS17, DEYS17, DGRS17, DGTS17, DGYS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, INT, MAX\n! .. Data statements ..\n DATA CZERO/(0.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n AZ = ABS(Z)\n NN = N\n DFNU = FNU + N - 1\n if (AZ > 2.0E0) then\n if (AZ*AZ*0.25E0 > DFNU+1.0E0) goto 20\n endif\n! ------------------------------------------------------------------\n! POWER SERIES\n! ------------------------------------------------------------------\n CALL DGRS17(Z,FNU,KODE,NN,CY,NW,TOL,ELIM,ALIM)\n INW = ABS(NW)\n NZ = NZ + INW\n NN = NN - INW\n if (NN == 0) then\n return\n else if (NW >= 0) then\n return\n ELSE\n DFNU = FNU + NN - 1\n endif\n 20 if (AZ >= RL) then\n if (DFNU > 1.0E0) then\n if (AZ+AZ < DFNU*DFNU) goto 40\n endif\n! ---------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR LARGE Z\n! ---------------------------------------------------------------\n CALL DGYS17(Z,FNU,KODE,NN,CY,NW,RL,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 120\n ELSE\n return\n endif\n else if (DFNU <= 1.0E0) then\n goto 100\n endif\n! ------------------------------------------------------------------\n! OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM\n! ------------------------------------------------------------------\n 40 CALL DEVS17(Z,FNU,KODE,1,NN,CY,NW,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 120\n ELSE\n NZ = NZ + NW\n NN = NN - NW\n if (NN == 0) then\n return\n ELSE\n DFNU = FNU + NN - 1\n if (DFNU <= FNUL) then\n if (AZ <= FNUL) goto 60\n endif\n! ------------------------------------------------------------\n! INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD\n! ------------------------------------------------------------\n NUI = INT(FNUL-DFNU) + 1\n NUI = MAX(NUI,0)\n CALL DEYS17(Z,FNU,KODE,NN,CY,NW,NUI,NLAST,FNUL,TOL,ELIM, &\n ALIM)\n if (NW < 0) then\n goto 120\n ELSE\n NZ = NZ + NW\n if (NLAST == 0) then\n return\n ELSE\n NN = NLAST\n endif\n endif\n 60 if (AZ > RL) then\n! ---------------------------------------------------------\n! MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN\n! ---------------------------------------------------------\n! ---------------------------------------------------------\n! OVERFLOW TEST ON K functionS USED IN WRONSKIAN\n! ---------------------------------------------------------\n CALL DEVS17(Z,FNU,KODE,2,2,CW,NW,TOL,ELIM,ALIM)\n if (NW < 0) then\n NZ = NN\n DO 80 I = 1, NN\n CY(I) = CZERO\n 80 continue\n return\n else if (NW > 0) then\n goto 120\n ELSE\n CALL DESS17(Z,FNU,KODE,NN,CY,NW,CW,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 120\n ELSE\n return\n endif\n endif\n endif\n endif\n endif\n! ------------------------------------------------------------------\n! MILLER ALGORITHM NORMALIZED BY THE SERIES\n! ------------------------------------------------------------------\n 100 CALL DGTS17(Z,FNU,KODE,NN,CY,NW,TOL)\n if (NW >= 0) return\n 120 NZ = -1\n if (NW == (-2)) NZ = -2\n if (NW == (-3)) NZ = -3\n return\n END\n subroutine DGRS17(Z,FNU,KODE,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-771 (DEC 1989).\n!\n! Original name: CSERI\n!\n! DGRS17 COMPUTES THE I BESSEL function FOR REAL(Z) >= 0.0 BY\n! MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE\n! REGION CABS(Z) <= 2*SQRT(FNU+1). NZ=0 IS A NORMAL return.\n! NZ>0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO\n! DUE TO UNDERFLOW. NZ < 0 MEANS UNDERFLOW OCCURRED, BUT THE\n! CONDITION CABS(Z) <= 2*SQRT(FNU+1) WAS VIOLATED AND THE\n! COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ).\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX AK1, CK, COEF, CONE, CRSC, CZ, CZERO, HZ, RZ, &\n S1, S2\n REAL AA, ACZ, AK, ARM, ASCLE, ATOL, AZ, DFNU, FNUP, &\n RAK1, RS, RTR1, S, SS, X\n INTEGER I, IB, IDUM, IFLAG, IL, K, L, M, NN, NW\n! .. Local Arrays ..\n COMPLEX W(2)\n! .. External functions ..\n REAL S14ABE, X02AME\n EXTERNAL S14ABE, X02AME\n! .. External subroutines ..\n EXTERNAL DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, REAL, &\n SIN, SQRT\n! .. Data statements ..\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n AZ = ABS(Z)\n if (AZ /= 0.0E0) then\n X = REAL(Z)\n ARM = 1.0E+3*X02AME()\n RTR1 = SQRT(ARM)\n CRSC = CMPLX(1.0E0,0.0E0)\n IFLAG = 0\n if (AZ < ARM) then\n NZ = N\n if (FNU == 0.0E0) NZ = NZ - 1\n ELSE\n HZ = Z*CMPLX(0.5E0,0.0E0)\n CZ = CZERO\n if (AZ > RTR1) CZ = HZ*HZ\n ACZ = ABS(CZ)\n NN = N\n CK = LOG(HZ)\n 20 continue\n DFNU = FNU + NN - 1\n FNUP = DFNU + 1.0E0\n! ------------------------------------------------------------\n! UNDERFLOW TEST\n! ------------------------------------------------------------\n AK1 = CK*CMPLX(DFNU,0.0E0)\n IDUM = 0\n! S14ABE assumed not to fail, therefore IDUM set to zero.\n AK = S14ABE(FNUP,IDUM)\n AK1 = AK1 - CMPLX(AK,0.0E0)\n if (KODE == 2) AK1 = AK1 - CMPLX(X,0.0E0)\n RAK1 = REAL(AK1)\n if (RAK1 > (-ELIM)) then\n if (RAK1 <= (-ALIM)) then\n IFLAG = 1\n SS = 1.0E0/TOL\n CRSC = CMPLX(TOL,0.0E0)\n ASCLE = ARM*SS\n endif\n AK = AIMAG(AK1)\n AA = EXP(RAK1)\n if (IFLAG == 1) AA = AA*SS\n COEF = CMPLX(AA,0.0E0)*CMPLX(COS(AK),SIN(AK))\n ATOL = TOL*ACZ/FNUP\n IL = MIN(2,NN)\n DO 60 I = 1, IL\n DFNU = FNU + NN - I\n FNUP = DFNU + 1.0E0\n S1 = CONE\n if (ACZ >= TOL*FNUP) then\n AK1 = CONE\n AK = FNUP + 2.0E0\n S = FNUP\n AA = 2.0E0\n 40 continue\n RS = 1.0E0/S\n AK1 = AK1*CZ*CMPLX(RS,0.0E0)\n S1 = S1 + AK1\n S = S + AK\n AK = AK + 2.0E0\n AA = AA*ACZ*RS\n if (AA > ATOL) goto 40\n endif\n M = NN - I + 1\n S2 = S1*COEF\n W(I) = S2\n if (IFLAG /= 0) then\n CALL DGVS17(S2,NW,ASCLE,TOL)\n if (NW /= 0) goto 80\n endif\n Y(M) = S2*CRSC\n if (I /= IL) COEF = COEF*CMPLX(DFNU,0.0E0)/HZ\n 60 continue\n goto 100\n endif\n 80 NZ = NZ + 1\n Y(NN) = CZERO\n if (ACZ > DFNU) then\n goto 180\n ELSE\n NN = NN - 1\n if (NN == 0) then\n return\n ELSE\n goto 20\n endif\n endif\n 100 if (NN > 2) then\n K = NN - 2\n AK = K\n RZ = (CONE+CONE)/Z\n if (IFLAG == 1) then\n! ------------------------------------------------------\n! RECUR BACKWARD WITH SCALED VALUES\n! ------------------------------------------------------\n! ------------------------------------------------------\n! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE\n! THE UNDERFLOW LIMIT = ASCLE = X02AME()*CSCL*1.0E+3\n! ------------------------------------------------------\n S1 = W(1)\n S2 = W(2)\n DO 120 L = 3, NN\n CK = S2\n S2 = S1 + CMPLX(AK+FNU,0.0E0)*RZ*S2\n S1 = CK\n CK = S2*CRSC\n Y(K) = CK\n AK = AK - 1.0E0\n K = K - 1\n if (ABS(CK) > ASCLE) goto 140\n 120 continue\n return\n 140 IB = L + 1\n if (IB > NN) return\n ELSE\n IB = 3\n endif\n DO 160 I = IB, NN\n Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2)\n AK = AK - 1.0E0\n K = K - 1\n 160 continue\n endif\n return\n! ------------------------------------------------------------\n! return WITH NZ < 0 IF CABS(Z*Z/4)>FNU+N-NZ-1 COMPLETE\n! THE CALCULATION IN DEZS17 WITH N=N-IABS(NZ)\n! ------------------------------------------------------------\n 180 continue\n NZ = -NZ\n return\n endif\n endif\n Y(1) = CZERO\n if (FNU == 0.0E0) Y(1) = CONE\n if (N /= 1) then\n DO 200 I = 2, N\n Y(I) = CZERO\n 200 continue\n endif\n return\n END\n subroutine DGSS17(ZR,S1,S2,NZ,ASCLE,ALIM,IUF)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-772 (DEC 1989).\n!\n! Original name: CS1S2\n!\n! DGSS17 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE\n! ADDITION OF THE I AND K functionS IN THE ANALYTIC CON-\n! TINUATION FORMULA WHERE S1=K function AND S2=I function.\n! ON KODE=1 THE I AND K functionS ARE DIFFERENT ORDERS OF\n! MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER\n! OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE\n! PRECISION ABOVE THE UNDERFLOW LIMIT.\n!\n! .. Scalar Arguments ..\n COMPLEX S1, S2, ZR\n REAL ALIM, ASCLE\n INTEGER IUF, NZ\n! .. Local Scalars ..\n COMPLEX C1, CZERO, S1D\n REAL AA, ALN, AS1, AS2, XX\n INTEGER IF1\n! .. External functions ..\n COMPLEX S01EAE\n EXTERNAL S01EAE\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, LOG, MAX, REAL\n! .. Data statements ..\n DATA CZERO/(0.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n AS1 = ABS(S1)\n AS2 = ABS(S2)\n AA = REAL(S1)\n ALN = AIMAG(S1)\n if (AA /= 0.0E0 .or. ALN /= 0.0E0) then\n if (AS1 /= 0.0E0) then\n XX = REAL(ZR)\n ALN = -XX - XX + LOG(AS1)\n S1D = S1\n S1 = CZERO\n AS1 = 0.0E0\n if (ALN >= (-ALIM)) then\n C1 = LOG(S1D) - ZR - ZR\n! S1 = EXP(C1)\n IF1 = 1\n S1 = S01EAE(C1,IF1)\n AS1 = ABS(S1)\n IUF = IUF + 1\n endif\n endif\n endif\n AA = MAX(AS1,AS2)\n if (AA <= ASCLE) then\n S1 = CZERO\n S2 = CZERO\n NZ = 1\n IUF = 0\n endif\n return\n END\n subroutine DGTS17(Z,FNU,KODE,N,Y,NZ,TOL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-773 (DEC 1989).\n! Mark 17 REVISED. IER-1703 (JUN 1995).\n!\n! Original name: CMLRI\n!\n! DGTS17 COMPUTES THE I BESSEL function FOR RE(Z) >= 0.0 BY THE\n! MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES.\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL FNU, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX CK, CNORM, CONE, CTWO, CZERO, P1, P2, PT, RZ, &\n SUM\n REAL ACK, AK, AP, AT, AZ, BK, FKAP, FKK, FLAM, FNF, &\n RHO, RHO2, SCLE, TFNF, TST, X\n INTEGER I, IAZ, IDUM, IFL, IFNU, INU, ITIME, K, KK, KM, &\n M\n! .. External functions ..\n COMPLEX S01EAE\n REAL S14ABE, X02ANE\n EXTERNAL S14ABE, S01EAE, X02ANE\n! .. Intrinsic functions ..\n INTRINSIC ABS, CMPLX, CONJG, EXP, INT, LOG, MAX, MIN, &\n REAL, SQRT\n! .. Data statements ..\n DATA CZERO, CONE, CTWO/(0.0E0,0.0E0), (1.0E0,0.0E0), &\n (2.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n SCLE = (1.0E+3*X02ANE())/TOL\n NZ = 0\n AZ = ABS(Z)\n X = REAL(Z)\n IAZ = INT(AZ)\n IFNU = INT(FNU)\n INU = IFNU + N - 1\n AT = IAZ + 1.0E0\n CK = CMPLX(AT,0.0E0)/Z\n RZ = CTWO/Z\n P1 = CZERO\n P2 = CONE\n ACK = (AT+1.0E0)/AZ\n RHO = ACK + SQRT(ACK*ACK-1.0E0)\n RHO2 = RHO*RHO\n TST = (RHO2+RHO2)/((RHO2-1.0E0)*(RHO-1.0E0))\n TST = TST/TOL\n! ------------------------------------------------------------------\n! COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES\n! ------------------------------------------------------------------\n AK = AT\n DO 20 I = 1, 80\n PT = P2\n P2 = P1 - CK*P2\n P1 = PT\n CK = CK + RZ\n AP = ABS(P2)\n if (AP > TST*AK*AK) then\n goto 40\n ELSE\n AK = AK + 1.0E0\n endif\n 20 continue\n goto 180\n 40 I = I + 1\n K = 0\n if (INU >= IAZ) then\n! ---------------------------------------------------------------\n! COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS\n! ---------------------------------------------------------------\n P1 = CZERO\n P2 = CONE\n AT = INU + 1.0E0\n CK = CMPLX(AT,0.0E0)/Z\n ACK = AT/AZ\n TST = SQRT(ACK/TOL)\n ITIME = 1\n DO 60 K = 1, 80\n PT = P2\n P2 = P1 - CK*P2\n P1 = PT\n CK = CK + RZ\n AP = ABS(P2)\n if (AP >= TST) then\n if (ITIME == 2) then\n goto 80\n ELSE\n ACK = ABS(CK)\n FLAM = ACK + SQRT(ACK*ACK-1.0E0)\n FKAP = AP/ABS(P1)\n RHO = MIN(FLAM,FKAP)\n TST = TST*SQRT(RHO/(RHO*RHO-1.0E0))\n ITIME = 2\n endif\n endif\n 60 continue\n goto 180\n endif\n! ------------------------------------------------------------------\n! BACKWARD RECURRENCE AND SUM NORMALIZING RELATION\n! ------------------------------------------------------------------\n 80 K = K + 1\n KK = MAX(I+IAZ,K+INU)\n FKK = KK\n P1 = CZERO\n! ------------------------------------------------------------------\n! SCALE P2 AND SUM BY SCLE\n! ------------------------------------------------------------------\n P2 = CMPLX(SCLE,0.0E0)\n FNF = FNU - IFNU\n TFNF = FNF + FNF\n IDUM = 0\n! S14ABE assumed not to fail, therefore IDUM set to zero.\n BK = S14ABE(FKK+TFNF+1.0E0,IDUM) - S14ABE(FKK+1.0E0,IDUM) - &\n S14ABE(TFNF+1.0E0,IDUM)\n BK = EXP(BK)\n SUM = CZERO\n KM = KK - INU\n DO 100 I = 1, KM\n PT = P2\n P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2\n P1 = PT\n AK = 1.0E0 - TFNF/(FKK+TFNF)\n ACK = BK*AK\n SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1\n BK = ACK\n FKK = FKK - 1.0E0\n 100 continue\n Y(N) = P2\n if (N /= 1) then\n DO 120 I = 2, N\n PT = P2\n P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2\n P1 = PT\n AK = 1.0E0 - TFNF/(FKK+TFNF)\n ACK = BK*AK\n SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1\n BK = ACK\n FKK = FKK - 1.0E0\n M = N - I + 1\n Y(M) = P2\n 120 continue\n endif\n if (IFNU > 0) then\n DO 140 I = 1, IFNU\n PT = P2\n P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2\n P1 = PT\n AK = 1.0E0 - TFNF/(FKK+TFNF)\n ACK = BK*AK\n SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1\n BK = ACK\n FKK = FKK - 1.0E0\n 140 continue\n endif\n PT = Z\n if (KODE == 2) PT = PT - CMPLX(X,0.0E0)\n P1 = -CMPLX(FNF,0.0E0)*LOG(RZ) + PT\n IDUM = 0\n! S14ABE assumed not to fail, therefore IDUM set to zero.\n AP = S14ABE(1.0E0+FNF,IDUM)\n PT = P1 - CMPLX(AP,0.0E0)\n! ------------------------------------------------------------------\n! THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW\n! IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES\n! ------------------------------------------------------------------\n P2 = P2 + SUM\n AP = ABS(P2)\n P1 = CMPLX(1.0E0/AP,0.0E0)\n! CK = EXP(PT)*P1\n IFL = 1\n CK = S01EAE(PT,IFL)*P1\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 200\n PT = CONJG(P2)*P1\n CNORM = CK*PT\n DO 160 I = 1, N\n Y(I) = Y(I)*CNORM\n 160 continue\n return\n 180 NZ = -2\n return\n 200 NZ = -3\n return\n END\n subroutine DGUS17(Z,CSH,CCH)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-774 (DEC 1989).\n!\n! Original name: CSHCH\n!\n! DGUS17 COMPUTES THE COMPLEX HYPERBOLIC functionS CSH=SINH(X+I*Y)\n! AND CCH=COSH(X+I*Y), WHERE I**2=-1.\n!\n! .. Scalar Arguments ..\n COMPLEX CCH, CSH, Z\n! .. Local Scalars ..\n REAL CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y\n! .. Intrinsic functions ..\n INTRINSIC AIMAG, CMPLX, COS, COSH, REAL, SIN, SINH\n! .. Executable Statements ..\n!\n X = REAL(Z)\n Y = AIMAG(Z)\n SH = SINH(X)\n CH = COSH(X)\n SN = SIN(Y)\n CN = COS(Y)\n CSHR = SH*CN\n CSHI = CH*SN\n CSH = CMPLX(CSHR,CSHI)\n CCHR = CH*CN\n CCHI = SH*SN\n CCH = CMPLX(CCHR,CCHI)\n return\n END\n subroutine DGVS17(Y,NZ,ASCLE,TOL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-775 (DEC 1989).\n!\n! Original name: CUCHK\n!\n! Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN\n! EXP(-ALIM)=ASCLE=1.0E+3*X02AME()/TOL. THE TEST IS MADE TO SEE\n! IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW\n! WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED\n! IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE\n! OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE\n! ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED.\n!\n! .. Scalar Arguments ..\n COMPLEX Y\n REAL ASCLE, TOL\n INTEGER NZ\n! .. Local Scalars ..\n REAL SS, ST, YI, YR\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, MAX, MIN, REAL\n! .. Executable Statements ..\n!\n NZ = 0\n YR = REAL(Y)\n YI = AIMAG(Y)\n YR = ABS(YR)\n YI = ABS(YI)\n ST = MIN(YR,YI)\n if (ST <= ASCLE) then\n SS = MAX(YR,YI)\n ST = ST/TOL\n if (SS < ST) NZ = 1\n endif\n return\n END\n subroutine DGWS17(ZR,FNU,N,Y,NZ,RZ,ASCLE,TOL,ELIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-776 (DEC 1989).\n!\n! Original name: CKSCL\n!\n! SET K functionS TO ZERO ON UNDERFLOW, continue RECURRENCE\n! ON SCALED functionS UNTIL TWO MEMBERS COME ON SCALE, THEN\n! return WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL.\n!\n! .. Scalar Arguments ..\n COMPLEX RZ, ZR\n REAL ASCLE, ELIM, FNU, TOL\n INTEGER N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX CELM, CK, CS, CZERO, S1, S2, ZD\n REAL AA, ACS, ALAS, AS, CSI, CSR, ELM, FN, HELIM, XX, &\n ZRI\n INTEGER I, IC, K, KK, NN, NW\n! .. Local Arrays ..\n COMPLEX CY(2)\n! .. External subroutines ..\n EXTERNAL DGVS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, REAL, SIN\n! .. Data statements ..\n DATA CZERO/(0.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n IC = 0\n XX = REAL(ZR)\n NN = MIN(2,N)\n DO 20 I = 1, NN\n S1 = Y(I)\n CY(I) = S1\n AS = ABS(S1)\n ACS = -XX + LOG(AS)\n NZ = NZ + 1\n Y(I) = CZERO\n if (ACS >= (-ELIM)) then\n CS = -ZR + LOG(S1)\n CSR = REAL(CS)\n CSI = AIMAG(CS)\n AA = EXP(CSR)/TOL\n CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI))\n CALL DGVS17(CS,NW,ASCLE,TOL)\n if (NW == 0) then\n Y(I) = CS\n NZ = NZ - 1\n IC = I\n endif\n endif\n 20 continue\n if (N /= 1) then\n if (IC <= 1) then\n Y(1) = CZERO\n NZ = 2\n endif\n if (N /= 2) then\n if (NZ /= 0) then\n FN = FNU + 1.0E0\n CK = CMPLX(FN,0.0E0)*RZ\n S1 = CY(1)\n S2 = CY(2)\n HELIM = 0.5E0*ELIM\n ELM = EXP(-ELIM)\n CELM = CMPLX(ELM,0.0E0)\n ZRI = AIMAG(ZR)\n ZD = ZR\n!\n! FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE\n! RECURRENCE IF S2 GETS LARGER THAN EXP(ELIM/2)\n!\n DO 40 I = 3, N\n KK = I\n CS = S2\n S2 = CK*S2 + S1\n S1 = CS\n CK = CK + RZ\n AS = ABS(S2)\n ALAS = LOG(AS)\n ACS = -XX + ALAS\n NZ = NZ + 1\n Y(I) = CZERO\n if (ACS >= (-ELIM)) then\n CS = -ZD + LOG(S2)\n CSR = REAL(CS)\n CSI = AIMAG(CS)\n AA = EXP(CSR)/TOL\n CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI))\n CALL DGVS17(CS,NW,ASCLE,TOL)\n if (NW == 0) then\n Y(I) = CS\n NZ = NZ - 1\n if (IC == (KK-1)) then\n goto 60\n ELSE\n IC = KK\n goto 40\n endif\n endif\n endif\n if (ALAS >= HELIM) then\n XX = XX - ELIM\n S1 = S1*CELM\n S2 = S2*CELM\n ZD = CMPLX(XX,ZRI)\n endif\n 40 continue\n NZ = N\n if (IC == N) NZ = N - 1\n goto 80\n 60 NZ = KK - 2\n 80 DO 100 K = 1, NZ\n Y(K) = CZERO\n 100 continue\n endif\n endif\n endif\n return\n END\n subroutine DGXS17(Z,FNU,KODE,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-777 (DEC 1989).\n!\n! Original name: CBKNU\n!\n! DGXS17 COMPUTES THE K BESSEL function IN THE RIGHT HALF Z PLANE\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX CCH, CELM, CK, COEF, CONE, CRSC, CS, CSCL, CSH, &\n CTWO, CZ, CZERO, F, FMU, P, P1, P2, PT, Q, RZ, &\n S1, S2, SMU, ST, ZD\n REAL A1, A2, AA, AK, ALAS, AS, ASCLE, BB, BK, CAZ, &\n DNU, DNU2, ELM, ETEST, FC, FHS, FK, FKS, FPI, &\n G1, G2, HELIM, HPI, P2I, P2M, P2R, PI, R1, RK, &\n RTHPI, S, SPI, T1, T2, TM, TTH, XD, XX, YD, YY\n INTEGER I, IC, IDUM, IFL, IFLAG, INU, INUB, J, K, KFLAG, &\n KK, KMAX, KODED, NW\n! .. Local Arrays ..\n COMPLEX CSR(3), CSS(3), CY(2)\n REAL BRY(3), CC(8)\n! .. External functions ..\n COMPLEX S01EAE\n REAL S14ABE, X02AME, X02ALE\n INTEGER X02BHE, X02BJE\n EXTERNAL S14ABE, S01EAE, X02AME, X02ALE, X02BHE, X02BJE\n! .. External subroutines ..\n EXTERNAL DGUS17, DGVS17, DGWS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, ATAN, CMPLX, CONJG, COS, EXP, INT, &\n LOG, LOG10, MAX, MIN, REAL, SIN, SQRT\n! .. Data statements ..\n!\n!\n!\n DATA KMAX/30/\n DATA R1/2.0E0/\n DATA CZERO, CONE, CTWO/(0.0E0,0.0E0), (1.0E0,0.0E0), &\n (2.0E0,0.0E0)/\n DATA PI, RTHPI, SPI, HPI, FPI, &\n TTH/3.14159265358979324E0, &\n 1.25331413731550025E0, 1.90985931710274403E0, &\n 1.57079632679489662E0, 1.89769999331517738E0, &\n 6.66666666666666666E-01/\n DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), &\n CC(8)/5.77215664901532861E-01, &\n -4.20026350340952355E-02, &\n -4.21977345555443367E-02, &\n 7.21894324666309954E-03, &\n -2.15241674114950973E-04, &\n -2.01348547807882387E-05, &\n 1.13302723198169588E-06, &\n 6.11609510448141582E-09/\n! .. Executable Statements ..\n!\n XX = REAL(Z)\n YY = AIMAG(Z)\n CAZ = ABS(Z)\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CRSC = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CRSC\n CSR(1) = CRSC\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = (1.0E+3*X02AME())/TOL\n BRY(2) = 1.0E0/BRY(1)\n BRY(3) = X02ALE()\n NZ = 0\n IFLAG = 0\n KODED = KODE\n RZ = CTWO/Z\n INU = INT(FNU+0.5E0)\n DNU = FNU - INU\n if (ABS(DNU) /= 0.5E0) then\n DNU2 = 0.0E0\n if (ABS(DNU) > TOL) DNU2 = DNU*DNU\n if (CAZ <= R1) then\n! ------------------------------------------------------------\n! SERIES FOR CABS(Z) <= R1\n! ------------------------------------------------------------\n FC = 1.0E0\n SMU = LOG(RZ)\n FMU = SMU*CMPLX(DNU,0.0E0)\n CALL DGUS17(FMU,CSH,CCH)\n if (DNU /= 0.0E0) then\n FC = DNU*PI\n FC = FC/SIN(FC)\n SMU = CSH*CMPLX(1.0E0/DNU,0.0E0)\n endif\n A2 = 1.0E0 + DNU\n! ------------------------------------------------------------\n! GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU),\n! T2=1/GAM(1+DNU)\n! ------------------------------------------------------------\n IDUM = 0\n! S14ABE assumed not to fail, therefore IDUM set to zero.\n T2 = EXP(-S14ABE(A2,IDUM))\n T1 = 1.0E0/(T2*FC)\n if (ABS(DNU) > 0.1E0) then\n G1 = (T1-T2)/(DNU+DNU)\n ELSE\n! ---------------------------------------------------------\n! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)\n! ---------------------------------------------------------\n AK = 1.0E0\n S = CC(1)\n DO 20 K = 2, 8\n AK = AK*DNU2\n TM = CC(K)*AK\n S = S + TM\n if (ABS(TM) < TOL) goto 40\n 20 continue\n 40 G1 = -S\n endif\n G2 = 0.5E0*(T1+T2)*FC\n G1 = G1*FC\n F = CMPLX(G1,0.0E0)*CCH + SMU*CMPLX(G2,0.0E0)\n IFL = 1\n PT = S01EAE(FMU,IFL)\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320\n P = CMPLX(0.5E0/T2,0.0E0)*PT\n Q = CMPLX(0.5E0/T1,0.0E0)/PT\n S1 = F\n S2 = P\n AK = 1.0E0\n A1 = 1.0E0\n CK = CONE\n BK = 1.0E0 - DNU2\n if (INU > 0 .or. N > 1) then\n! ---------------------------------------------------------\n! GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE\n! ---------------------------------------------------------\n if (CAZ >= TOL) then\n CZ = Z*Z*CMPLX(0.25E0,0.0E0)\n T1 = 0.25E0*CAZ*CAZ\n 60 continue\n F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0)\n P = P*CMPLX(1.0E0/(AK-DNU),0.0E0)\n Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0)\n RK = 1.0E0/AK\n CK = CK*CZ*CMPLX(RK,0.0E0)\n S1 = S1 + CK*F\n S2 = S2 + CK*(P-F*CMPLX(AK,0.0E0))\n A1 = A1*T1*RK\n BK = BK + AK + AK + 1.0E0\n AK = AK + 1.0E0\n if (A1 > TOL) goto 60\n endif\n KFLAG = 2\n BK = REAL(SMU)\n A1 = FNU + 1.0E0\n AK = A1*ABS(BK)\n if (AK > ALIM) KFLAG = 3\n P2 = S2*CSS(KFLAG)\n S2 = P2*RZ\n S1 = S1*CSS(KFLAG)\n if (KODED /= 1) then\n! F = EXP(Z)\n IFL = 1\n F = S01EAE(Z,IFL)\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320\n S1 = S1*F\n S2 = S2*F\n endif\n goto 160\n ELSE\n! ---------------------------------------------------------\n! GENERATE K(FNU,Z), 0.0D0 <= FNU < 0.5D0 AND N=1\n! ---------------------------------------------------------\n if (CAZ >= TOL) then\n CZ = Z*Z*CMPLX(0.25E0,0.0E0)\n T1 = 0.25E0*CAZ*CAZ\n 80 continue\n F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0)\n P = P*CMPLX(1.0E0/(AK-DNU),0.0E0)\n Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0)\n RK = 1.0E0/AK\n CK = CK*CZ*CMPLX(RK,0.0E0)\n S1 = S1 + CK*F\n A1 = A1*T1*RK\n BK = BK + AK + AK + 1.0E0\n AK = AK + 1.0E0\n if (A1 > TOL) goto 80\n endif\n Y(1) = S1\n! if (KODED /= 1) Y(1) = S1*EXP(Z)\n if (KODED /= 1) then\n IFL = 1\n Y(1) = S01EAE(Z,IFL)\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320\n Y(1) = S1*Y(1)\n endif\n return\n endif\n endif\n endif\n! ------------------------------------------------------------------\n! IFLAG=0 MEANS NO UNDERFLOW OCCURRED\n! IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH\n! KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD\n! RECURSION\n! ------------------------------------------------------------------\n COEF = CMPLX(RTHPI,0.0E0)/SQRT(Z)\n KFLAG = 2\n if (KODED /= 2) then\n if (XX > ALIM) then\n! ------------------------------------------------------------\n! SCALE BY EXP(Z), IFLAG = 1 CASES\n! ------------------------------------------------------------\n KODED = 2\n IFLAG = 1\n KFLAG = 2\n ELSE\n! BLANK LINE\n! A1 = EXP(-XX)*REAL(CSS(KFLAG))\n! PT = CMPLX(A1,0.0E0)*CMPLX(COS(YY),-SIN(YY))\n IFL = 1\n PT = S01EAE(CMPLX(-XX,-YY),IFL)\n if ((IFL >= 1 .and. IFL <= 3) .or. IFL == 5) goto 320\n PT = PT*REAL(CSS(KFLAG))\n COEF = COEF*PT\n endif\n endif\n if (ABS(DNU) /= 0.5E0) then\n! ---------------------------------------------------------------\n! MILLER ALGORITHM FOR CABS(Z)>R1\n! ---------------------------------------------------------------\n AK = COS(PI*DNU)\n AK = ABS(AK)\n if (AK /= 0.0E0) then\n FHS = ABS(0.25E0-DNU2)\n if (FHS /= 0.0E0) then\n! ---------------------------------------------------------\n! COMPUTE R2=F(E). IF CABS(Z) >= R2, USE FORWARD RECURRENCE\n! TO DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT\n! LINE ON 12 <= E <= 60. E IS COMPUTED FROM\n! 2**(-E)=B**(1-X02BJE())=TOL WHERE B IS THE BASE OF THE\n! ARITHMETIC.\n! ---------------------------------------------------------\n T1 = (X02BJE()-1)*LOG10(REAL(X02BHE()))*3.321928094E0\n T1 = MAX(T1,12.0E0)\n T1 = MIN(T1,60.0E0)\n T2 = TTH*T1 - 6.0E0\n if (XX /= 0.0E0) then\n T1 = ATAN(YY/XX)\n T1 = ABS(T1)\n ELSE\n T1 = HPI\n endif\n if (T2 > CAZ) then\n! ------------------------------------------------------\n! COMPUTE BACKWARD INDEX K FOR CABS(Z) < R2\n! ------------------------------------------------------\n A2 = SQRT(CAZ)\n AK = FPI*AK/(TOL*SQRT(A2))\n AA = 3.0E0*T1/(1.0E0+CAZ)\n BB = 14.7E0*T1/(28.0E0+CAZ)\n AK = (LOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB)\n FK = 0.12125E0*AK*AK/CAZ + 1.5E0\n ELSE\n! ------------------------------------------------------\n! FORWARD RECURRENCE LOOP WHEN CABS(Z) >= R2\n! ------------------------------------------------------\n ETEST = AK/(PI*CAZ*TOL)\n FK = 1.0E0\n if (ETEST >= 1.0E0) then\n FKS = 2.0E0\n RK = CAZ + CAZ + 2.0E0\n A1 = 0.0E0\n A2 = 1.0E0\n DO 100 I = 1, KMAX\n AK = FHS/FKS\n BK = RK/(FK+1.0E0)\n TM = A2\n A2 = BK*A2 - AK*A1\n A1 = TM\n RK = RK + 2.0E0\n FKS = FKS + FK + FK + 2.0E0\n FHS = FHS + FK + FK\n FK = FK + 1.0E0\n TM = ABS(A2)*FK\n if (ETEST < TM) goto 120\n 100 continue\n NZ = -2\n return\n 120 FK = FK + SPI*T1*SQRT(T2/CAZ)\n FHS = ABS(0.25E0-DNU2)\n endif\n endif\n K = INT(FK)\n! ---------------------------------------------------------\n! BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM\n! ---------------------------------------------------------\n FK = K\n FKS = FK*FK\n P1 = CZERO\n P2 = CMPLX(TOL,0.0E0)\n CS = P2\n DO 140 I = 1, K\n A1 = FKS - FK\n A2 = (FKS+FK)/(A1+FHS)\n RK = 2.0E0/(FK+1.0E0)\n T1 = (FK+XX)*RK\n T2 = YY*RK\n PT = P2\n P2 = (P2*CMPLX(T1,T2)-P1)*CMPLX(A2,0.0E0)\n P1 = PT\n CS = CS + P2\n FKS = A1 - FK + 1.0E0\n FK = FK - 1.0E0\n 140 continue\n! ---------------------------------------------------------\n! COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR\n! BETTER SCALING\n! ---------------------------------------------------------\n TM = ABS(CS)\n PT = CMPLX(1.0E0/TM,0.0E0)\n S1 = PT*P2\n CS = CONJG(CS)*PT\n S1 = COEF*S1*CS\n if (INU > 0 .or. N > 1) then\n! ------------------------------------------------------\n! COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR\n! SCALING\n! ------------------------------------------------------\n TM = ABS(P2)\n PT = CMPLX(1.0E0/TM,0.0E0)\n P1 = PT*P1\n P2 = CONJG(P2)*PT\n PT = P1*P2\n S2 = S1*(CONE+(CMPLX(DNU+0.5E0,0.0E0)-PT)/Z)\n goto 160\n ELSE\n ZD = Z\n if (IFLAG == 1) then\n goto 240\n ELSE\n goto 260\n endif\n endif\n endif\n endif\n endif\n! ------------------------------------------------------------------\n! FNU=HALF ODD INTEGER CASE, DNU=-0.5\n! ------------------------------------------------------------------\n S1 = COEF\n S2 = COEF\n! ------------------------------------------------------------------\n! FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH\n! SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3\n! ------------------------------------------------------------------\n 160 continue\n CK = CMPLX(DNU+1.0E0,0.0E0)*RZ\n if (N == 1) INU = INU - 1\n if (INU > 0) then\n INUB = 1\n if (IFLAG == 1) then\n! ------------------------------------------------------------\n! IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON\n! UNDERFLOW\n! ------------------------------------------------------------\n HELIM = 0.5E0*ELIM\n ELM = EXP(-ELIM)\n CELM = CMPLX(ELM,0.0E0)\n ASCLE = BRY(1)\n ZD = Z\n XD = XX\n YD = YY\n IC = -1\n J = 2\n DO 180 I = 1, INU\n ST = S2\n S2 = CK*S2 + S1\n S1 = ST\n CK = CK + RZ\n AS = ABS(S2)\n ALAS = LOG(AS)\n P2R = -XD + ALAS\n if (P2R >= (-ELIM)) then\n P2 = -ZD + LOG(S2)\n P2R = REAL(P2)\n P2I = AIMAG(P2)\n P2M = EXP(P2R)/TOL\n P1 = CMPLX(P2M,0.0E0)*CMPLX(COS(P2I),SIN(P2I))\n CALL DGVS17(P1,NW,ASCLE,TOL)\n if (NW == 0) then\n J = 3 - J\n CY(J) = P1\n if (IC == (I-1)) then\n goto 200\n ELSE\n IC = I\n goto 180\n endif\n endif\n endif\n if (ALAS >= HELIM) then\n XD = XD - ELIM\n S1 = S1*CELM\n S2 = S2*CELM\n ZD = CMPLX(XD,YD)\n endif\n 180 continue\n if (N == 1) S1 = S2\n goto 240\n 200 KFLAG = 1\n INUB = I + 1\n S2 = CY(J)\n J = 3 - J\n S1 = CY(J)\n if (INUB > INU) then\n if (N == 1) S1 = S2\n goto 260\n endif\n endif\n P1 = CSR(KFLAG)\n ASCLE = BRY(KFLAG)\n DO 220 I = INUB, INU\n ST = S2\n S2 = CK*S2 + S1\n S1 = ST\n CK = CK + RZ\n if (KFLAG < 3) then\n P2 = S2*P1\n P2R = REAL(P2)\n P2I = AIMAG(P2)\n P2R = ABS(P2R)\n P2I = ABS(P2I)\n P2M = MAX(P2R,P2I)\n if (P2M > ASCLE) then\n KFLAG = KFLAG + 1\n ASCLE = BRY(KFLAG)\n S1 = S1*P1\n S2 = P2\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n P1 = CSR(KFLAG)\n endif\n endif\n 220 continue\n if (N == 1) S1 = S2\n goto 260\n ELSE\n if (N == 1) S1 = S2\n ZD = Z\n if (IFLAG /= 1) goto 260\n endif\n 240 Y(1) = S1\n if (N /= 1) Y(2) = S2\n ASCLE = BRY(1)\n CALL DGWS17(ZD,FNU,N,Y,NZ,RZ,ASCLE,TOL,ELIM)\n INU = N - NZ\n if (INU <= 0) then\n return\n ELSE\n KK = NZ + 1\n S1 = Y(KK)\n Y(KK) = S1*CSR(1)\n if (INU == 1) then\n return\n ELSE\n KK = NZ + 2\n S2 = Y(KK)\n Y(KK) = S2*CSR(1)\n if (INU == 2) then\n return\n ELSE\n T2 = FNU + KK - 1\n CK = CMPLX(T2,0.0E0)*RZ\n KFLAG = 1\n goto 280\n endif\n endif\n endif\n 260 Y(1) = S1*CSR(KFLAG)\n if (N == 1) then\n return\n ELSE\n Y(2) = S2*CSR(KFLAG)\n if (N == 2) then\n return\n ELSE\n KK = 2\n endif\n endif\n 280 KK = KK + 1\n if (KK <= N) then\n P1 = CSR(KFLAG)\n ASCLE = BRY(KFLAG)\n DO 300 I = KK, N\n P2 = S2\n S2 = CK*S2 + S1\n S1 = P2\n CK = CK + RZ\n P2 = S2*P1\n Y(I) = P2\n if (KFLAG < 3) then\n P2R = REAL(P2)\n P2I = AIMAG(P2)\n P2R = ABS(P2R)\n P2I = ABS(P2I)\n P2M = MAX(P2R,P2I)\n if (P2M > ASCLE) then\n KFLAG = KFLAG + 1\n ASCLE = BRY(KFLAG)\n S1 = S1*P1\n S2 = P2\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n P1 = CSR(KFLAG)\n endif\n endif\n 300 continue\n endif\n return\n 320 NZ = -3\n return\n END\n subroutine DGYS17(Z,FNU,KODE,N,Y,NZ,RL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-778 (DEC 1989).\n!\n! Original name: CASYI\n!\n! DGYS17 COMPUTES THE I BESSEL function FOR REAL(Z) >= 0.0 BY\n! MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE\n! REGION CABS(Z)>MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL return.\n! NZ < 0 INDICATES AN OVERFLOW ON KODE=1.\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, RL, TOL\n INTEGER KODE, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, &\n RZ, S2\n REAL AA, ACZ, AEZ, AK, ARG, ARM, ATOL, AZ, BB, BK, &\n DFNU, DNU2, FDN, PI, RTPI, RTR1, S, SGN, SQK, X, &\n YY\n INTEGER I, IB, IERR1, IL, INU, J, JL, K, KODED, M, NN\n! .. External functions ..\n COMPLEX S01EAE\n REAL X02AME\n EXTERNAL S01EAE, X02AME\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, MIN, MOD, &\n REAL, SIN, SQRT\n! .. Data statements ..\n DATA PI, RTPI/3.14159265358979324E0, &\n 0.159154943091895336E0/\n DATA CZERO, CONE/(0.0E0,0.0E0), (1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n AZ = ABS(Z)\n X = REAL(Z)\n ARM = 1.0E+3*X02AME()\n RTR1 = SQRT(ARM)\n IL = MIN(2,N)\n DFNU = FNU + N - IL\n! ------------------------------------------------------------------\n! OVERFLOW TEST\n! ------------------------------------------------------------------\n AK1 = CMPLX(RTPI,0.0E0)/Z\n AK1 = SQRT(AK1)\n CZ = Z\n if (KODE == 2) CZ = Z - CMPLX(X,0.0E0)\n ACZ = REAL(CZ)\n if (ABS(ACZ) > ELIM) then\n NZ = -1\n ELSE\n DNU2 = DFNU + DFNU\n KODED = 1\n if ((ABS(ACZ) <= ALIM) .or. (N <= 2)) then\n KODED = 0\n IERR1 = 1\n AK1 = AK1*S01EAE(CZ,IERR1)\n! Allow reduced precision from S01EAE, but disallow other errors.\n if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) goto 140\n endif\n FDN = 0.0E0\n if (DNU2 > RTR1) FDN = DNU2*DNU2\n EZ = Z*CMPLX(8.0E0,0.0E0)\n! ---------------------------------------------------------------\n! WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO\n! THE FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF\n! THE EXPANSION FOR THE IMAGINARY PART.\n! ---------------------------------------------------------------\n AEZ = 8.0E0*AZ\n S = TOL/AEZ\n JL = INT(RL+RL) + 2\n YY = AIMAG(Z)\n P1 = CZERO\n if (YY /= 0.0E0) then\n! ------------------------------------------------------------\n! CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF\n! SIGNIFICANCE WHEN FNU OR N IS LARGE\n! ------------------------------------------------------------\n INU = INT(FNU)\n ARG = (FNU-INU)*PI\n INU = INU + N - IL\n AK = -SIN(ARG)\n BK = COS(ARG)\n if (YY < 0.0E0) BK = -BK\n P1 = CMPLX(AK,BK)\n if (MOD(INU,2) == 1) P1 = -P1\n endif\n DO 60 K = 1, IL\n SQK = FDN - 1.0E0\n ATOL = S*ABS(SQK)\n SGN = 1.0E0\n CS1 = CONE\n CS2 = CONE\n CK = CONE\n AK = 0.0E0\n AA = 1.0E0\n BB = AEZ\n DK = EZ\n DO 20 J = 1, JL\n CK = CK*CMPLX(SQK,0.0E0)/DK\n CS2 = CS2 + CK\n SGN = -SGN\n CS1 = CS1 + CK*CMPLX(SGN,0.0E0)\n DK = DK + EZ\n AA = AA*ABS(SQK)/BB\n BB = BB + AEZ\n AK = AK + 8.0E0\n SQK = SQK - AK\n if (AA <= ATOL) goto 40\n 20 continue\n goto 120\n 40 S2 = CS1\n if (X+X < ELIM) then\n IERR1 = 1\n S2 = S2 + P1*CS2*S01EAE(-Z-Z,IERR1)\n if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) &\n goto 140\n endif\n FDN = FDN + 8.0E0*DFNU + 4.0E0\n P1 = -P1\n M = N - IL + K\n Y(M) = S2*AK1\n 60 continue\n if (N > 2) then\n NN = N\n K = NN - 2\n AK = K\n RZ = (CONE+CONE)/Z\n IB = 3\n DO 80 I = IB, NN\n Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2)\n AK = AK - 1.0E0\n K = K - 1\n 80 continue\n if (KODED /= 0) then\n IERR1 = 1\n CK = S01EAE(CZ,IERR1)\n if ((IERR1 >= 1 .and. IERR1 <= 3) .or. IERR1 == 5) &\n goto 140\n DO 100 I = 1, NN\n Y(I) = Y(I)*CK\n 100 continue\n endif\n endif\n return\n 120 NZ = -2\n return\n 140 NZ = -3\n endif\n return\n END\n subroutine DGZS17(Z,FNU,KODE,MR,N,Y,NZ,RL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-779 (DEC 1989).\n!\n! Original name: CACAI\n!\n! DGZS17 APPLIES THE ANALYTIC CONTINUATION FORMULA\n!\n! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)\n! MP=PI*MR*CMPLX(0.0,1.0)\n!\n! TO continue THE K function FROM THE RIGHT HALF TO THE LEFT\n! HALF Z PLANE FOR USE WITH S17DGE WHERE FNU=1/3 OR 2/3 AND N=1.\n! DGZS17 IS THE SAME AS DLZS17 WITH THE PARTS FOR LARGER ORDERS AND\n! RECURRENCE REMOVED. A RECURSIVE CALL TO DLZS17 CAN RESULT IF S17DL\n! IS CALLED FROM S17DGE.\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, RL, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CSGN, CSPN, ZN\n REAL ARG, ASCLE, AZ, CPN, DFNU, FMR, PI, SGN, SPN, YY\n INTEGER INU, IUF, NN, NW\n! .. Local Arrays ..\n COMPLEX CY(2)\n! .. External functions ..\n REAL X02AME\n EXTERNAL X02AME\n! .. External subroutines ..\n EXTERNAL DGRS17, DGSS17, DGTS17, DGXS17, DGYS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, INT, MOD, SIGN, SIN\n! .. Data statements ..\n DATA PI/3.14159265358979324E0/\n! .. Executable Statements ..\n!\n NZ = 0\n ZN = -Z\n AZ = ABS(Z)\n NN = N\n DFNU = FNU + N - 1\n if (AZ > 2.0E0) then\n if (AZ*AZ*0.25E0 > DFNU+1.0E0) then\n if (AZ < RL) then\n! ---------------------------------------------------------\n! MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I\n! function\n! ---------------------------------------------------------\n CALL DGTS17(ZN,FNU,KODE,NN,Y,NW,TOL)\n if (NW < 0) then\n goto 40\n ELSE\n goto 20\n endif\n ELSE\n! ---------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I function\n! ---------------------------------------------------------\n CALL DGYS17(ZN,FNU,KODE,NN,Y,NW,RL,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 40\n ELSE\n goto 20\n endif\n endif\n endif\n endif\n! ------------------------------------------------------------------\n! POWER SERIES FOR THE I function\n! ------------------------------------------------------------------\n CALL DGRS17(ZN,FNU,KODE,NN,Y,NW,TOL,ELIM,ALIM)\n! ------------------------------------------------------------------\n! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K function\n! ------------------------------------------------------------------\n 20 CALL DGXS17(ZN,FNU,KODE,1,CY,NW,TOL,ELIM,ALIM)\n if (NW == 0) then\n FMR = MR\n SGN = -SIGN(PI,FMR)\n CSGN = CMPLX(0.0E0,SGN)\n if (KODE /= 1) then\n YY = -AIMAG(ZN)\n CPN = COS(YY)\n SPN = SIN(YY)\n CSGN = CSGN*CMPLX(CPN,SPN)\n endif\n! ---------------------------------------------------------------\n! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE\n! WHEN FNU IS LARGE\n! ---------------------------------------------------------------\n INU = INT(FNU)\n ARG = (FNU-INU)*SGN\n CPN = COS(ARG)\n SPN = SIN(ARG)\n CSPN = CMPLX(CPN,SPN)\n if (MOD(INU,2) == 1) CSPN = -CSPN\n C1 = CY(1)\n C2 = Y(1)\n if (KODE /= 1) then\n IUF = 0\n ASCLE = (1.0E+3*X02AME())/TOL\n CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF)\n NZ = NZ + NW\n endif\n Y(1) = CSPN*C1 + CSGN*C2\n return\n endif\n 40 NZ = -1\n if (NW == (-2)) NZ = -2\n if (NW == (-3)) NZ = -3\n return\n END\n subroutine DLYS17(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-782 (DEC 1989).\n!\n! Original name: CBUNK\n!\n! DLYS17 COMPUTES THE K BESSEL function FOR FNU>FNUL.\n! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z)\n! IN DCZS18 AND THE EXPANSION FOR H(2,FNU,Z) IN DCYS18\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n REAL AX, AY, XX, YY\n! .. External subroutines ..\n EXTERNAL DCYS18, DCZS18\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, REAL\n! .. Executable Statements ..\n!\n NZ = 0\n XX = REAL(Z)\n YY = AIMAG(Z)\n AX = ABS(XX)*1.7321E0\n AY = ABS(YY)\n if (AY > AX) then\n! ---------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU\n! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I\n! AND HPI=PI/2\n! ---------------------------------------------------------------\n CALL DCYS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n ELSE\n! ---------------------------------------------------------------\n! ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN\n! -PI/3 <= ARG(Z) <= PI/3\n! ---------------------------------------------------------------\n CALL DCZS18(Z,FNU,KODE,MR,N,Y,NZ,TOL,ELIM,ALIM)\n endif\n return\n END\n subroutine DLZS17(Z,FNU,KODE,MR,N,Y,NZ,RL,FNUL,TOL,ELIM,ALIM)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-783 (DEC 1989).\n!\n! Original name: CACON\n!\n! DLZS17 APPLIES THE ANALYTIC CONTINUATION FORMULA\n!\n! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)\n! MP=PI*MR*CMPLX(0.0,1.0)\n!\n! TO continue THE K function FROM THE RIGHT HALF TO THE LEFT\n! HALF Z PLANE\n!\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL ALIM, ELIM, FNU, FNUL, RL, TOL\n INTEGER KODE, MR, N, NZ\n! .. Array Arguments ..\n COMPLEX Y(N)\n! .. Local Scalars ..\n COMPLEX C1, C2, CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, &\n RZ, S1, S2, SC1, SC2, ST, ZN\n REAL ARG, AS2, ASCLE, BSCLE, C1I, C1M, C1R, CPN, FMR, &\n PI, SGN, SPN, YY\n INTEGER I, INU, IUF, KFLAG, NN, NW\n! .. Local Arrays ..\n COMPLEX CSR(3), CSS(3), CY(2)\n REAL BRY(3)\n! .. External functions ..\n REAL X02AME, X02ALE\n EXTERNAL X02AME, X02ALE\n! .. External subroutines ..\n EXTERNAL DEZS17, DGSS17, DGXS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, INT, MAX, MIN, MOD, &\n REAL, SIGN, SIN\n! .. Data statements ..\n DATA PI/3.14159265358979324E0/\n DATA CONE/(1.0E0,0.0E0)/\n! .. Executable Statements ..\n!\n NZ = 0\n ZN = -Z\n NN = N\n CALL DEZS17(ZN,FNU,KODE,NN,Y,NW,RL,FNUL,TOL,ELIM,ALIM)\n if (NW >= 0) then\n! ---------------------------------------------------------------\n! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K function\n! ---------------------------------------------------------------\n NN = MIN(2,N)\n CALL DGXS17(ZN,FNU,KODE,NN,CY,NW,TOL,ELIM,ALIM)\n if (NW == 0) then\n S1 = CY(1)\n FMR = MR\n SGN = -SIGN(PI,FMR)\n CSGN = CMPLX(0.0E0,SGN)\n if (KODE /= 1) then\n YY = -AIMAG(ZN)\n CPN = COS(YY)\n SPN = SIN(YY)\n CSGN = CSGN*CMPLX(CPN,SPN)\n endif\n! ------------------------------------------------------------\n! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF\n! SIGNIFICANCE WHEN FNU IS LARGE\n! ------------------------------------------------------------\n INU = INT(FNU)\n ARG = (FNU-INU)*SGN\n CPN = COS(ARG)\n SPN = SIN(ARG)\n CSPN = CMPLX(CPN,SPN)\n if (MOD(INU,2) == 1) CSPN = -CSPN\n IUF = 0\n C1 = S1\n C2 = Y(1)\n ASCLE = (1.0E+3*X02AME())/TOL\n if (KODE /= 1) then\n CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF)\n NZ = NZ + NW\n SC1 = C1\n endif\n Y(1) = CSPN*C1 + CSGN*C2\n if (N /= 1) then\n CSPN = -CSPN\n S2 = CY(2)\n C1 = S2\n C2 = Y(2)\n if (KODE /= 1) then\n CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF)\n NZ = NZ + NW\n SC2 = C1\n endif\n Y(2) = CSPN*C1 + CSGN*C2\n if (N /= 2) then\n CSPN = -CSPN\n RZ = CMPLX(2.0E0,0.0E0)/ZN\n CK = CMPLX(FNU+1.0E0,0.0E0)*RZ\n! ------------------------------------------------------\n! SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON\n! K functionS\n! ------------------------------------------------------\n CSCL = CMPLX(1.0E0/TOL,0.0E0)\n CSCR = CMPLX(TOL,0.0E0)\n CSS(1) = CSCL\n CSS(2) = CONE\n CSS(3) = CSCR\n CSR(1) = CSCR\n CSR(2) = CONE\n CSR(3) = CSCL\n BRY(1) = ASCLE\n BRY(2) = 1.0E0/ASCLE\n BRY(3) = X02ALE()\n AS2 = ABS(S2)\n KFLAG = 2\n if (AS2 <= BRY(1)) then\n KFLAG = 1\n else if (AS2 >= BRY(2)) then\n KFLAG = 3\n endif\n BSCLE = BRY(KFLAG)\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n CS = CSR(KFLAG)\n DO 20 I = 3, N\n ST = S2\n S2 = CK*S2 + S1\n S1 = ST\n C1 = S2*CS\n ST = C1\n C2 = Y(I)\n if (KODE /= 1) then\n if (IUF >= 0) then\n CALL DGSS17(ZN,C1,C2,NW,ASCLE,ALIM,IUF)\n NZ = NZ + NW\n SC1 = SC2\n SC2 = C1\n if (IUF == 3) then\n IUF = -4\n S1 = SC1*CSS(KFLAG)\n S2 = SC2*CSS(KFLAG)\n ST = SC2\n endif\n endif\n endif\n Y(I) = CSPN*C1 + CSGN*C2\n CK = CK + RZ\n CSPN = -CSPN\n if (KFLAG < 3) then\n C1R = REAL(C1)\n C1I = AIMAG(C1)\n C1R = ABS(C1R)\n C1I = ABS(C1I)\n C1M = MAX(C1R,C1I)\n if (C1M > BSCLE) then\n KFLAG = KFLAG + 1\n BSCLE = BRY(KFLAG)\n S1 = S1*CS\n S2 = ST\n S1 = S1*CSS(KFLAG)\n S2 = S2*CSS(KFLAG)\n CS = CSR(KFLAG)\n endif\n endif\n 20 continue\n endif\n endif\n return\n endif\n endif\n NZ = -1\n if (NW == (-2)) NZ = -2\n if (NW == (-3)) NZ = -3\n return\n END\n INTEGER function P01ABE(IFAIL,IERROR,SRNAME,NREC,REC)\n! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986.\n! MARK 13 REVISED. IER-621 (APR 1988).\n! MARK 13B REVISED. IER-668 (AUG 1988).\n!\n! P01ABE is the error-handling routine for the NAG Library.\n!\n! P01ABE either returns the value of IERROR through the routine\n! name (soft failure), or terminates execution of the program\n! (hard failure). Diagnostic messages may be output.\n!\n! If IERROR = 0 (successful exit from the calling routine),\n! the value 0 is returned through the routine name, and no\n! message is output\n!\n! If IERROR is non-zero (abnormal exit from the calling routine),\n! the action taken depends on the value of IFAIL.\n!\n! IFAIL = 1: soft failure, silent exit (i.e. no messages are\n! output)\n! IFAIL = -1: soft failure, noisy exit (i.e. messages are output)\n! IFAIL =-13: soft failure, noisy exit but standard messages from\n! P01ABE are suppressed\n! IFAIL = 0: hard failure, noisy exit\n!\n! For compatibility with certain routines included before Mark 12\n! P01ABE also allows an alternative specification of IFAIL in which\n! it is regarded as a decimal integer with least significant digits\n! cba. Then\n!\n! a = 0: hard failure a = 1: soft failure\n! b = 0: silent exit b = 1: noisy exit\n!\n! except that hard failure now always implies a noisy exit.\n!\n! S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office.\n!\n! .. Scalar Arguments ..\n INTEGER IERROR, IFAIL, NREC\n CHARACTER*(*) SRNAME\n! .. Array Arguments ..\n CHARACTER*(*) REC(*)\n! .. Local Scalars ..\n INTEGER I, NERR\n CHARACTER*72 MESS\n! .. External subroutines ..\n EXTERNAL ABZP01, X04AAE, X04BAE\n! .. Intrinsic functions ..\n INTRINSIC ABS, MOD\n! .. Executable Statements ..\n if (IERROR /= 0) then\n! Abnormal exit from calling routine\n if (IFAIL == -1 .or. IFAIL == 0 .or. IFAIL == -13 .or. &\n (IFAIL > 0 .and. MOD(IFAIL/10,10) /= 0)) then\n! Noisy exit\n CALL X04AAE(0,NERR)\n DO 20 I = 1, NREC\n CALL X04BAE(NERR,REC(I))\n 20 continue\n if (IFAIL /= -13) then\n WRITE (MESS,FMT=99999) SRNAME, IERROR\n CALL X04BAE(NERR,MESS)\n if (ABS(MOD(IFAIL,10)) /= 1) then\n! Hard failure\n CALL X04BAE(NERR, &\n ' ** NAG hard failure - execution terminated' &\n )\n CALL ABZP01\n ELSE\n! Soft failure\n CALL X04BAE(NERR, &\n ' ** NAG soft failure - control returned')\n endif\n endif\n endif\n endif\n P01ABE = IERROR\n return\n!\n 99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', &\n ' =',I6)\n END\n COMPLEX function S01EAE(Z,IFAIL)\n! MARK 14 RELEASE. NAG COPYRIGHT 1989.\n! returns exp(Z) for complex Z.\n! .. Parameters ..\n REAL ONE, ZERO\n PARAMETER (ONE=1.0E0,ZERO=0.0E0)\n CHARACTER*6 SRNAME\n PARAMETER (SRNAME='S01EAE')\n! .. Scalar Arguments ..\n COMPLEX Z\n INTEGER IFAIL\n! .. Local Scalars ..\n REAL COSY, EXPX, LNSAFE, RECEPS, RESI, RESR, &\n RTSAFS, SAFE, SAFSIN, SINY, X, XPLNCY, &\n XPLNSY, Y\n INTEGER IER, NREC\n LOGICAL FIRST\n! .. Local Arrays ..\n CHARACTER*80 REC(2)\n! .. External functions ..\n REAL X02AHE, X02AJE, X02AME\n INTEGER P01ABE\n EXTERNAL X02AHE, X02AJE, X02AME, P01ABE\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, LOG, MIN, &\n REAL, SIGN, SIN, SQRT\n! .. Save statement ..\n SAVE SAFE, LNSAFE, SAFSIN, RTSAFS, FIRST\n! .. Data statements ..\n DATA FIRST/.true./\n! .. Executable Statements ..\n if (FIRST) then\n FIRST = .false.\n SAFE = ONE/X02AME()\n LNSAFE = LOG(SAFE)\n RECEPS = ONE/X02AJE()\n SAFSIN = MIN(X02AHE(ONE),RECEPS)\n if (SAFSIN < RECEPS**0.75E0) then\n! Assume that SAFSIN is approximately sqrt(RECEPS), in which\n! case IFAIL=4 cannot occur.\n RTSAFS = SAFSIN\n ELSE\n! Set RTSAFS to the argument above which SINE and COSINE will\n! return results of less than half precision, assuming that\n! SAFSIN is approximately equal to RECEPS.\n RTSAFS = SQRT(SAFSIN)\n endif\n endif\n NREC = 0\n IER = 0\n X = REAL(Z)\n Y = AIMAG(Z)\n if (ABS(Y) > SAFSIN) then\n IER = 5\n NREC = 2\n WRITE (REC,FMT=99995) Z\n S01EAE = ZERO\n ELSE\n COSY = COS(Y)\n SINY = SIN(Y)\n if (X > LNSAFE) then\n if (COSY == ZERO) then\n RESR = ZERO\n ELSE\n XPLNCY = X + LOG(ABS(COSY))\n if (XPLNCY > LNSAFE) then\n IER = 1\n RESR = SIGN(SAFE,COSY)\n ELSE\n RESR = SIGN(EXP(XPLNCY),COSY)\n endif\n endif\n if (SINY == ZERO) then\n RESI = ZERO\n ELSE\n XPLNSY = X + LOG(ABS(SINY))\n if (XPLNSY > LNSAFE) then\n IER = IER + 2\n RESI = SIGN(SAFE,SINY)\n ELSE\n RESI = SIGN(EXP(XPLNSY),SINY)\n endif\n endif\n ELSE\n EXPX = EXP(X)\n RESR = EXPX*COSY\n RESI = EXPX*SINY\n endif\n S01EAE = CMPLX(RESR,RESI)\n if (IER == 3) then\n NREC = 2\n WRITE (REC,FMT=99997) Z\n else if (ABS(Y) > RTSAFS) then\n IER = 4\n NREC = 2\n WRITE (REC,FMT=99996) Z\n else if (IER == 1) then\n NREC = 2\n WRITE (REC,FMT=99999) Z\n else if (IER == 2) then\n NREC = 2\n WRITE (REC,FMT=99998) Z\n endif\n endif\n IFAIL = P01ABE(IFAIL,IER,SRNAME,NREC,REC)\n return\n!\n 99999 FORMAT (1X,'** Argument Z causes overflow in real part of result:' &\n ,/4X,'Z = (',1P,E13.5,',',E13.5,')')\n 99998 FORMAT (1X,'** Argument Z causes overflow in imaginary part of r', &\n 'esult:',/4X,'Z = (',1P,E13.5,',',E13.5,')')\n 99997 FORMAT (1X,'** Argument Z causes overflow in both real and imagi', &\n 'nary parts of result:',/4X,'Z = (',1P,E13.5,',',E13.5,')')\n 99996 FORMAT (1X,'** The imaginary part of argument Z is so large that', &\n ' the result is',/4X,'accurate to less than half precisio', &\n 'n: Z = (',1P,E13.5,',',E13.5,')')\n 99995 FORMAT (1X,'** The imaginary part of argument Z is so large that', &\n ' the result has no',/4X,'precision: Z = (',1P,E13.5,',', &\n E13.5,')')\n END\n REAL function S14ABE(X,IFAIL)\n! MARK 8 RELEASE. NAG COPYRIGHT 1979.\n! MARK 11.5(F77) REVISED. (SEPT 1985.)\n! LNGAMMA(X) function\n! ABRAMOWITZ AND STEGUN CH.6\n!\n! **************************************************************\n!\n! TO EXTRACT THE CORRECT CODE FOR A PARTICULAR MACHINE-RANGE,\n! ACTIVATE THE STATEMENTS CONTAINED IN COMMENTS BEGINNING CDD ,\n! WHERE DD IS THE APPROXIMATE NUMBER OF SIGNIFICANT DECIMAL\n! DIGITS REPRESENTED BY THE MACHINE\n! DELETE THE ILLEGAL DUMMY STATEMENTS OF THE FORM\n! * EXPANSION (NNNN) *\n!\n! ALSO INSERT APPROPRIATE DATA STATEMENTS TO DEFINE CONSTANTS\n! WHICH DEPEND ON THE RANGE OF NUMBERS REPRESENTED BY THE\n! MACHINE, RATHER THAN THE PRECISION (SUITABLE STATEMENTS FOR\n! SOME MACHINES ARE CONTAINED IN COMMENTS BEGINNING CRD WHERE\n! D IS A DIGIT WHICH SIMPLY DISTINGUISHES A GROUP OF MACHINES).\n! DELETE THE ILLEGAL DUMMY DATA STATEMENTS WITH VALUES WRITTEN\n! *VALUE*\n!\n! **************************************************************\n!\n! IMPLEMENTATION DEPENDENT CONSTANTS\n!\n! if (X < XSMALL)GAMMA(X)=1/X\n! I.E. XSMALL*EULGAM <= XRELPR\n! LNGAM(XVBIG)=GBIG <= XOVFLO\n! LNR2PI=LN(SQRT(2*PI))\n! if (X>XBIG)LNGAM(X)=(X-0.5)LN(X)-X+LNR2PI\n!\n! .. Parameters ..\n CHARACTER*6 SRNAME\n PARAMETER (SRNAME='S14ABE')\n! .. Scalar Arguments ..\n REAL X\n INTEGER IFAIL\n! .. Local Scalars ..\n REAL G, GBIG, LNR2PI, T, XBIG, XSMALL, XVBIG, Y\n INTEGER I, M\n! .. Local Arrays ..\n CHARACTER*1 P01REC(1)\n! .. External functions ..\n INTEGER P01ABE\n EXTERNAL P01ABE\n! .. Intrinsic functions ..\n INTRINSIC LOG, REAL\n! .. Data statements ..\n!08 DATA XSMALL,XBIG,LNR2PI/\n!08 *1.0E-8,1.2E+3,9.18938533E-1/\n!09 DATA XSMALL,XBIG,LNR2PI/\n!09 *1.0E-9,4.8E+3,9.189385332E-1/\n!12 DATA XSMALL,XBIG,LNR2PI/\n!12 *1.0E-12,3.7E+5,9.189385332047E-1/\n DATA XSMALL,XBIG,LNR2PI/ &\n 1.0E-15,6.8E+6,9.189385332046727E-1/\n!17 DATA XSMALL,XBIG,LNR2PI/\n!17 *1.0E-17,7.7E+7,9.18938533204672742E-1/\n!19 DATA XSMALL,XBIG,LNR2PI/\n!19 *1.0E-19,3.1E+8,9.189385332046727418E-1/\n!\n! RANGE DEPENDENT CONSTANTS\n! DK DK DATA XVBIG,GBIG/4.81E+2461,2.72E+2465/\n DATA XVBIG,GBIG/4.08E+36,3.40E+38/\n! FOR IEEE SINGLE PRECISION\n!R0 DATA XVBIG,GBIG/4.08E+36,3.40E+38/\n! FOR IBM 360/370 AND SIMILAR MACHINES\n!R1 DATA XVBIG,GBIG/4.29E+73,7.231E+75/\n! FOR DEC10, HONEYWELL, UNIVAC 1100 (S.P.)\n!R2 DATA XVBIG,GBIG/2.05E36,1.69E38/\n! FOR ICL 1900\n!R3 DATA XVBIG,GBIG/3.39E+74,5.784E+76/\n! FOR CDC 7600/CYBER\n!R4 DATA XVBIG,GBIG/1.72E+319,1.26E+322/\n! FOR UNIVAC 1100 (D.P.)\n!R5 DATA XVBIG,GBIG/1.28E305,8.98E+307/\n! FOR IEEE DOUBLE PRECISION\n!R7 DATA XVBIG,GBIG/2.54D+305,1.79D+308/\n! .. Executable Statements ..\n if (X > XSMALL) goto 20\n! VERY SMALL RANGE\n if (X <= 0.0) goto 160\n IFAIL = 0\n S14ABE = -LOG(X)\n goto 200\n!\n 20 if (X > 15.0) goto 120\n! MAIN SMALL X RANGE\n M = X\n T = X - FLOAT(M)\n M = M - 1\n G = 1.0\n if (M) 40, 100, 60\n 40 G = G/X\n goto 100\n 60 DO 80 I = 1, M\n G = (X-FLOAT(I))*G\n 80 continue\n 100 T = 2.0*T - 1.0\n!\n! * EXPANSION (0026) *\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 08E.09\n!08 Y = (((((((((((+1.88278283E-6*T-5.48272091E-6)*T+1.03144033E-5)\n!08 * *T-3.13088821E-5)*T+1.01593694E-4)*T-2.98340924E-4)\n!08 * *T+9.15547391E-4)*T-2.42216251E-3)*T+9.04037536E-3)\n!08 * *T-1.34119055E-2)*T+1.03703361E-1)*T+1.61692007E-2)*T +\n!08 * 8.86226925E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 09E.10\n!09 Y = ((((((((((((-6.463247484E-7*T+1.882782826E-6)\n!09 * *T-3.382165478E-6)*T+1.031440334E-5)*T-3.393457634E-5)\n!09 * *T+1.015936944E-4)*T-2.967655076E-4)*T+9.155473906E-4)\n!09 * *T-2.422622002E-3)*T+9.040375355E-3)*T-1.341184808E-2)\n!09 * *T+1.037033609E-1)*T+1.616919866E-2)*T + 8.862269255E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 12E.13\n!12 Y = ((((((((((((((((-8.965837291520E-9*T+2.612707393536E-8)\n!12 * *T-3.802866827264E-8)*T+1.173294768947E-7)\n!12 * *T-4.275076254106E-7)*T+1.276176602829E-6)\n!12 * *T-3.748495971011E-6)*T+1.123829871408E-5)\n!12 * *T-3.364018663166E-5)*T+1.009331480887E-4)\n!12 * *T-2.968895120407E-4)*T+9.157850115110E-4)\n!12 * *T-2.422595461409E-3)*T+9.040335037321E-3)\n!12 * *T-1.341185056618E-2)*T+1.037033634184E-1)\n!12 * *T+1.616919872437E-2)*T + 8.862269254528E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 15E.16\n Y = (((((((((((((((-1.243191705600000E-10*T+ &\n 3.622882508800000E-10)*T-4.030909644800000E-10) &\n *T+1.265236705280000E-9)*T-5.419466096640000E-9) &\n *T+1.613133578240000E-8)*T-4.620920340480000E-8) &\n *T+1.387603440435200E-7)*T-4.179652784537600E-7) &\n *T+1.253148247777280E-6)*T-3.754930502328320E-6) &\n *T+1.125234962812416E-5)*T-3.363759801664768E-5) &\n *T+1.009281733953869E-4)*T-2.968901194293069E-4) &\n *T+9.157859942174304E-4)*T-2.422595384546340E-3\n Y = ((((Y*T+9.040334940477911E-3)*T-1.341185057058971E-2) &\n *T+1.037033634220705E-1)*T+1.616919872444243E-2)*T + &\n 8.862269254527580E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 17E.18\n!17 Y = (((((((((((((((-1.46381209600000000E-11*T+\n!17 * 4.26560716800000000E-11)*T-4.01499750400000000E-11)\n!17 * *T+1.27679856640000000E-10)*T-6.13513953280000000E-10)\n!17 * *T+1.82243164160000000E-9)*T-5.11961333760000000E-9)\n!17 * *T+1.53835215257600000E-8)*T-4.64774927155200000E-8)\n!17 * *T+1.39383522590720000E-7)*T-4.17808776355840000E-7)\n!17 * *T+1.25281466396672000E-6)*T-3.75499034136576000E-6)\n!17 * *T+1.12524642975590400E-5)*T-3.36375833240268800E-5)\n!17 * *T+1.00928148823365120E-4)*T-2.96890121633200000E-4\n!17 Y = ((((((Y*T+9.15785997288933120E-4)*T-2.42259538436268176E-3)\n!17 * *T+9.04033494028101968E-3)*T-1.34118505705967765E-2)\n!17 * *T+1.03703363422075456E-1)*T+1.61691987244425092E-2)*T +\n!17 * 8.86226925452758013E-1\n!\n! EXPANSION (0026) EVALUATED AS Y(T) --PRECISION 19E.19\n!19 Y = (((((((((((((((+6.710886400000000000E-13*T-\n!19 * 1.677721600000000000E-12)*T+6.710886400000000000E-13)\n!19 * *T-4.152360960000000000E-12)*T+2.499805184000000000E-11)\n!19 * *T-6.898581504000000000E-11)*T+1.859597107200000000E-10)\n!19 * *T-5.676387532800000000E-10)*T+1.725556326400000000E-9)\n!19 * *T-5.166307737600000000E-9)*T+1.548131827712000000E-8)\n!19 * *T-4.644574052352000000E-8)*T+1.393195837030400000E-7)\n!19 * *T-4.178233990758400000E-7)*T+1.252842254950400000E-6)\n!19 * *T-3.754985815285760000E-6)*T+1.125245651030528000E-5\n!19 Y = (((((((((Y*T-3.363758423922688000E-5)\n!19 * *T+1.009281502108083200E-4)\n!19 * *T-2.968901215188000000E-4)*T+9.157859971435078400E-4)\n!19 * *T-2.422595384370689760E-3)*T+9.040334940288877920E-3)\n!19 * *T-1.341185057059651648E-2)*T+1.037033634220752902E-1)\n!19 * *T+1.616919872444250674E-2)*T + 8.862269254527580137E-1\n!\n S14ABE = LOG(Y*G)\n IFAIL = 0\n goto 200\n!\n 120 if (X > XBIG) goto 140\n! MAIN LARGE X RANGE\n T = 450.0/(X*X) - 1.0\n!\n! * EXPANSION (0059) *\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 08E.09\n!08 Y = (+3.89980902E-9*T-6.16502533E-6)*T + 8.33271644E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 09E.10\n!09 Y = (+3.899809019E-9*T-6.165025333E-6)*T + 8.332716441E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 12E.13\n!12 Y = ((-6.451144077930E-12*T+3.899809018958E-9)\n!12 * *T-6.165020494506E-6)*T + 8.332716440658E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 15E.16\n Y = (((+2.002019273379824E-14*T-6.451144077929628E-12) &\n *T+3.899788998764847E-9)*T-6.165020494506090E-6)*T + &\n 8.332716440657866E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 17E.18\n!17 Y = ((((-9.94561064728159347E-17*T+2.00201927337982364E-14)\n!17 * *T-6.45101975779653651E-12)*T+3.89978899876484712E-9)\n!17 * *T-6.16502049453716986E-6)*T + 8.33271644065786580E-2\n!\n! EXPANSION (0059) EVALUATED AS Y(T) --PRECISION 19E.19\n!19 Y = (((((+7.196406678180202240E-19*T-9.945610647281593472E-17)\n!19 * *T+2.001911327279650935E-14)*T-6.451019757796536510E-12)\n!19 * *T+3.899788999169644998E-9)*T-6.165020494537169862E-6)*T +\n!19 * 8.332716440657865795E-2\n!\n S14ABE = (X-0.5)*LOG(X) - X + LNR2PI + Y/X\n IFAIL = 0\n goto 200\n!\n 140 if (X > XVBIG) goto 180\n! ASYMPTOTIC LARGE X RANGE\n S14ABE = (X-0.5)*LOG(X) - X + LNR2PI\n IFAIL = 0\n goto 200\n!\n! FAILURE EXITS\n 160 IFAIL = P01ABE(IFAIL,1,SRNAME,0,P01REC)\n S14ABE = 0.0\n goto 200\n 180 IFAIL = P01ABE(IFAIL,2,SRNAME,0,P01REC)\n S14ABE = GBIG\n!\n 200 return\n!\n END\n subroutine S17DGE(DERIV,Z,SCALE,AI,NZ,IFAIL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-770 (DEC 1989).\n!\n! Original name: CAIRY\n!\n! PURPOSE TO COMPUTE AIRY functionS AI(Z) AND DAI(Z) FOR COMPLEX Z\n!\n! DESCRIPTION\n! ===========\n!\n! ON SCALE='U', S17DGE COMPUTES THE COMPLEX AIRY function AI(Z)\n! OR ITS DERIVATIVE DAI(Z)/DZ ON DERIV='F' OR DERIV='D'\n! RESPECTIVELY. ON SCALE='S', A SCALING OPTION\n! CEXP(ZTA)*AI(Z) OR CEXP(ZTA)*DAI(Z)/DZ IS PROVIDED TO REMOVE\n! THE EXPONENTIAL DECAY IN -PI/3 < ARG(Z) < PI/3 AND THE\n! EXPONENTIAL GROWTH IN PI/3 < ABS(ARG(Z)) < PI WHERE\n! ZTA=(2/3)*Z*CSQRT(Z)\n!\n! WHILE THE AIRY functionS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN\n! THE WHOLE Z PLANE, THE CORRESPONDING SCALED functionS DEFINED\n! FOR SCALE='S' HAVE A CUT ALONG THE NEGATIVE REAL AXIS.\n! DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF\n! MATHEMATICAL functionS (REF. 1).\n!\n! INPUT\n! Z - Z=CMPLX(X,Y)\n! DERIV - return function (DERIV='F') OR DERIVATIVE\n! (DERIV='D')\n! SCALE - A PARAMETER TO INDICATE THE SCALING OPTION\n! SCALE = 'U' OR 'u' returnS\n! AI=AI(Z) ON DERIV='F' OR\n! AI=DAI(Z)/DZ ON DERIV='D'\n! SCALE = 'S' OR 's' returnS\n! AI=CEXP(ZTA)*AI(Z) ON DERIV='F' OR\n! AI=CEXP(ZTA)*DAI(Z)/DZ ON DERIV='D' WHERE\n! ZTA=(2/3)*Z*CSQRT(Z)\n!\n! OUTPUT\n! AI - COMPLEX ANSWER DEPENDING ON THE CHOICES FOR DERIV\n! AND SCALE\n! NZ - UNDERFLOW INDICATOR\n! NZ= 0 , NORMAL return\n! NZ= 1 , AI=CMPLX(0.0,0.0) DUE TO UNDERFLOW IN\n! -PI/3 < ARG(Z) < PI/3 ON SCALE='U'\n! IFAIL - ERROR FLAG\n! IFAIL=0, NORMAL return - COMPUTATION COMPLETED\n! IFAIL=1, INPUT ERROR - NO COMPUTATION\n! IFAIL=2, OVERFLOW - NO COMPUTATION, REAL(ZTA)\n! TOO LARGE WITH SCALE = 'U'\n! IFAIL=3, CABS(Z) LARGE - COMPUTATION COMPLETED\n! LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION\n! PRODUCE LESS THAN HALF OF MACHINE ACCURACY\n! IFAIL=4, CABS(Z) TOO LARGE - NO COMPUTATION\n! COMPLETE LOSS OF ACCURACY BY ARGUMENT\n! REDUCTION\n! IFAIL=5, ERROR - NO COMPUTATION,\n! ALGORITHM TERMINATION CONDITION NOT MET\n!\n! LONG DESCRIPTION\n! ================\n!\n! AI AND DAI ARE COMPUTED FOR CABS(Z)>1.0 FROM THE K BESSEL\n! functionS BY\n!\n! AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA)\n! C=1.0/(PI*SQRT(3.0))\n! ZTA=(2/3)*Z**(3/2)\n!\n! WITH THE POWER SERIES FOR CABS(Z) <= 1.0.\n!\n! IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-\n! MENTARY functionS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES\n! OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF\n! THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),\n! THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR\n! FLAG IFAIL=3 IS TRIGGERED WHERE UR=X02AJE()=UNIT ROUNDOFF.\n! ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN\n! ALL SIGNIFICANCE IS LOST AND IFAIL=4. IN ORDER TO USE THE INT\n! function, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE\n! LARGEST INTEGER, U3=X02BBE(). THUS, THE MAGNITUDE OF ZETA\n! MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,\n! AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE\n! PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE\n! PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-\n! ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-\n! NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN\n! DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN\n! EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,\n! NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE\n! PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER\n! MACHINES.\n!\n! THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX\n! BESSEL function CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT\n! ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-\n! SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE\n! ELEMENTARY functionS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),\n! ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF\n! CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY\n! HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN\n! ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY\n! SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER\n! THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,\n! 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS\n! THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER\n! COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY\n! BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER\n! COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE\n! MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,\n! THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,\n! OR -PI/2+P.\n!\n! REFERENCES\n! ==========\n! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ\n! AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF\n! COMMERCE, 1955.\n!\n! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT\n! AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983\n!\n! A subroutine PACKAGE FOR BESSEL functionS OF A COMPLEX\n! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-\n! 1018, MAY, 1985\n!\n! A PORTABLE PACKAGE FOR BESSEL functionS OF A COMPLEX\n! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.\n! MATH. SOFTWARE, 1986\n!\n! DATE WRITTEN 830501 (YYMMDD)\n! REVISION DATE 830501 (YYMMDD)\n! AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES\n!\n! .. Parameters ..\n CHARACTER*6 SRNAME\n PARAMETER (SRNAME='S17DGE')\n! .. Scalar Arguments ..\n COMPLEX AI, Z\n INTEGER IFAIL, NZ\n CHARACTER DERIV, SCALE\n! .. Local Scalars ..\n COMPLEX CONE, CSQ, S1, S2, TRM1, TRM2, Z3, ZTA\n REAL AA, AD, AK, ALAZ, ALIM, ATRM, AZ, AZ3, BB, BK, &\n C1, C2, CK, COEF, D1, D2, DIG, DK, ELIM, FID, &\n FNU, R1M5, RL, SAVAA, SFAC, TOL, TTH, Z3I, Z3R, &\n ZI, ZR\n INTEGER ID, IERR, IFL, IFLAG, K, K1, K2, KODE, MR, NN, &\n NREC\n! .. Local Arrays ..\n COMPLEX CY(1)\n CHARACTER*80 REC(1)\n! .. External functions ..\n COMPLEX S01EAE\n REAL X02AHE, X02AJE, X02AME\n INTEGER P01ABE, X02BBE, X02BHE, X02BJE, X02BKE, X02BLE\n EXTERNAL S01EAE, X02AHE, X02AJE, X02AME, P01ABE, X02BBE, &\n X02BHE, X02BJE, X02BKE, X02BLE\n! .. External subroutines ..\n EXTERNAL DGXS17, DGZS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, LOG, LOG10, MAX, MIN, REAL, &\n SQRT\n! .. Data statements ..\n DATA TTH, C1, C2, COEF/6.66666666666666667E-01, &\n 3.55028053887817240E-01, &\n 2.58819403792806799E-01, &\n 1.83776298473930683E-01/\n DATA CONE/(1.0E0,0.0E0)/\n! .. Executable Statements ..\n IERR = 0\n NREC = 0\n NZ = 0\n if (DERIV == 'F' .or. DERIV == 'f') then\n ID = 0\n else if (DERIV == 'D' .or. DERIV == 'd') then\n ID = 1\n ELSE\n ID = -1\n endif\n if (SCALE == 'U' .or. SCALE == 'u') then\n KODE = 1\n else if (SCALE == 'S' .or. SCALE == 's') then\n KODE = 2\n ELSE\n KODE = -1\n endif\n if (ID == -1) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99999) DERIV\n else if (KODE == -1) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99998) SCALE\n endif\n if (IERR == 0) then\n AZ = ABS(Z)\n TOL = MAX(X02AJE(),1.0E-18)\n FID = ID\n if (AZ > 1.0E0) then\n! ------------------------------------------------------------\n! CASE FOR CABS(Z)>1.0\n! ------------------------------------------------------------\n FNU = (1.0E0+FID)/3.0E0\n! ------------------------------------------------------------\n! SET PARAMETERS RELATED TO MACHINE CONSTANTS.\n! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.\n! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW\n! LIMIT.\n! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND\n! EXP(ELIM)>EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS\n! NEAR UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC\n! IS DONE.\n! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR\n! LARGE Z.\n! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).\n! ------------------------------------------------------------\n K1 = X02BKE()\n K2 = X02BLE()\n R1M5 = LOG10(REAL(X02BHE()))\n K = MIN(ABS(K1),ABS(K2))\n ELIM = 2.303E0*(K*R1M5-3.0E0)\n K1 = X02BJE() - 1\n AA = R1M5*K1\n DIG = MIN(AA,18.0E0)\n AA = AA*2.303E0\n ALIM = ELIM + MAX(-AA,-41.45E0)\n RL = 1.2E0*DIG + 3.0E0\n ALAZ = LOG(AZ)\n! ------------------------------------------------------------\n! TEST FOR RANGE\n! ------------------------------------------------------------\n AA = 0.5E0/TOL\n BB = X02BBE(1.0E0)*0.5E0\n AA = MIN(AA,BB,X02AHE(1.0E0))\n AA = AA**TTH\n if (AZ > AA) then\n NZ = 0\n IERR = 4\n NREC = 1\n WRITE (REC,FMT=99997) AZ, AA\n ELSE\n AA = SQRT(AA)\n SAVAA = AA\n if (AZ > AA) then\n IERR = 3\n NREC = 1\n WRITE (REC,FMT=99996) AZ, AA\n endif\n CSQ = SQRT(Z)\n ZTA = Z*CSQ*CMPLX(TTH,0.0E0)\n! ---------------------------------------------------------\n! RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS\n! SMALL\n! ---------------------------------------------------------\n IFLAG = 0\n SFAC = 1.0E0\n ZI = AIMAG(Z)\n ZR = REAL(Z)\n AK = AIMAG(ZTA)\n if (ZR < 0.0E0) then\n BK = REAL(ZTA)\n CK = -ABS(BK)\n ZTA = CMPLX(CK,AK)\n endif\n if (ZI == 0.0E0) then\n if (ZR <= 0.0E0) ZTA = CMPLX(0.0E0,AK)\n endif\n AA = REAL(ZTA)\n if (AA >= 0.0E0 .and. ZR > 0.0E0) then\n if (KODE /= 2) then\n! ---------------------------------------------------\n! UNDERFLOW TEST\n! ---------------------------------------------------\n if (AA >= ALIM) then\n AA = -AA - 0.25E0*ALAZ\n IFLAG = 2\n SFAC = 1.0E0/TOL\n if (AA < (-ELIM)) then\n NZ = 1\n AI = CMPLX(0.0E0,0.0E0)\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n endif\n endif\n CALL DGXS17(ZTA,FNU,KODE,1,CY,NZ,TOL,ELIM,ALIM)\n ELSE\n if (KODE /= 2) then\n! ---------------------------------------------------\n! OVERFLOW TEST\n! ---------------------------------------------------\n if (AA <= (-ALIM)) then\n AA = -AA + 0.25E0*ALAZ\n IFLAG = 1\n SFAC = TOL\n if (AA > ELIM) goto 20\n endif\n endif\n! ------------------------------------------------------\n! DGXS17 AND DGZS17 return EXP(ZTA)*K(FNU,ZTA) ON KODE=2\n! ------------------------------------------------------\n MR = 1\n if (ZI < 0.0E0) MR = -1\n CALL DGZS17(ZTA,FNU,KODE,MR,1,CY,NN,RL,TOL,ELIM,ALIM)\n if (NN >= 0) then\n NZ = NZ + NN\n goto 40\n else if (NN == (-3)) then\n NZ = 0\n IERR = 4\n NREC = 1\n WRITE (REC,FMT=99997) AZ, SAVAA\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n else if (NN /= (-1)) then\n NZ = 0\n IERR = 5\n NREC = 1\n WRITE (REC,FMT=99995)\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n 20 NZ = 0\n IERR = 2\n NREC = 1\n WRITE (REC,FMT=99994)\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n 40 S1 = CY(1)*CMPLX(COEF,0.0E0)\n if (IFLAG /= 0) then\n S1 = S1*CMPLX(SFAC,0.0E0)\n if (ID == 1) then\n S1 = -S1*Z\n AI = S1*CMPLX(1.0E0/SFAC,0.0E0)\n ELSE\n S1 = S1*CSQ\n AI = S1*CMPLX(1.0E0/SFAC,0.0E0)\n endif\n else if (ID == 1) then\n AI = -Z*S1\n ELSE\n AI = CSQ*S1\n endif\n endif\n ELSE\n! ------------------------------------------------------------\n! POWER SERIES FOR CABS(Z) <= 1.\n! ------------------------------------------------------------\n S1 = CONE\n S2 = CONE\n if (AZ < TOL) then\n AA = 1.0E+3*X02AME()\n S1 = CMPLX(0.0E0,0.0E0)\n if (ID == 1) then\n AI = -CMPLX(C2,0.0E0)\n AA = SQRT(AA)\n if (AZ > AA) S1 = Z*Z*CMPLX(0.5E0,0.0E0)\n AI = AI + S1*CMPLX(C1,0.0E0)\n ELSE\n if (AZ > AA) S1 = CMPLX(C2,0.0E0)*Z\n AI = CMPLX(C1,0.0E0) - S1\n endif\n ELSE\n AA = AZ*AZ\n if (AA >= TOL/AZ) then\n TRM1 = CONE\n TRM2 = CONE\n ATRM = 1.0E0\n Z3 = Z*Z*Z\n AZ3 = AZ*AA\n AK = 2.0E0 + FID\n BK = 3.0E0 - FID - FID\n CK = 4.0E0 - FID\n DK = 3.0E0 + FID + FID\n D1 = AK*DK\n D2 = BK*CK\n AD = MIN(D1,D2)\n AK = 24.0E0 + 9.0E0*FID\n BK = 30.0E0 - 9.0E0*FID\n Z3R = REAL(Z3)\n Z3I = AIMAG(Z3)\n DO 60 K = 1, 25\n TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1)\n S1 = S1 + TRM1\n TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2)\n S2 = S2 + TRM2\n ATRM = ATRM*AZ3/AD\n D1 = D1 + AK\n D2 = D2 + BK\n AD = MIN(D1,D2)\n if (ATRM < TOL*AD) then\n goto 80\n ELSE\n AK = AK + 18.0E0\n BK = BK + 18.0E0\n endif\n 60 continue\n endif\n 80 if (ID == 1) then\n AI = -S2*CMPLX(C2,0.0E0)\n if (AZ > TOL) AI = AI + Z*Z*S1*CMPLX(C1/(1.0E0+FID), &\n 0.0E0)\n if (KODE /= 1) then\n ZTA = Z*SQRT(Z)*CMPLX(TTH,0.0E0)\n! AI = AI*EXP(ZTA)\n IFL = 1\n AI = AI*S01EAE(ZTA,IFL)\n endif\n ELSE\n AI = S1*CMPLX(C1,0.0E0) - Z*S2*CMPLX(C2,0.0E0)\n if (KODE /= 1) then\n ZTA = Z*SQRT(Z)*CMPLX(TTH,0.0E0)\n! AI = AI*EXP(ZTA)\n IFL = 1\n AI = AI*S01EAE(ZTA,IFL)\n endif\n endif\n endif\n endif\n endif\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n!\n 99999 FORMAT (1X,'** On entry, DERIV has illegal value: DERIV = ''',A, &\n '''')\n 99998 FORMAT (1X,'** On entry, SCALE has illegal value: SCALE = ''',A, &\n '''')\n 99997 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' > ', &\n E13.5)\n 99996 FORMAT (1X,'** Results lack precision because abs(Z) =',1P,E13.5, &\n ' > ',E13.5)\n 99995 FORMAT (1X,'** No computation - algorithm termination condition ', &\n 'not met.')\n 99994 FORMAT (1X,'** No computation because real(ZTA) too large, where', &\n ' ZTA = (2/3)*Z**(3/2).')\n END\n subroutine S17DLE(M,FNU,Z,N,SCALE,CY,NZ,IFAIL)\n! MARK 13 RELEASE. NAG COPYRIGHT 1988.\n! MARK 14 REVISED. IER-781 (DEC 1989).\n!\n! Original name: CBESH\n!\n! PURPOSE TO COMPUTE THE H-BESSEL functionS OF A COMPLEX ARGUMENT\n!\n! DESCRIPTION\n! ===========\n!\n! ON SCALE='U', S17DLE COMPUTES AN N MEMBER SEQUENCE OF COMPLEX\n! HANKEL (BESSEL) functionS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1\n! OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX\n! Z /= CMPLX(0.0E0,0.0E0) IN THE CUT PLANE -PI < ARG(Z) <= PI.\n! ON SCALE='S', S17DLE COMPUTES THE SCALED HANKEL functionS\n!\n! CY(I)=H(M,FNU+J-1,Z)*EXP(-MM*Z*I) MM=3-2M, I**2=-1.\n!\n! WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER\n! AND LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN\n! THE NBS HANDBOOK OF MATHEMATICAL functionS (REF. 1).\n!\n! INPUT\n! Z - Z=CMPLX(X,Y), Z /= CMPLX(0.,0.),-PI < ARG(Z) <= PI\n! FNU - ORDER OF INITIAL H function, FNU >= 0.0E0\n! SCALE - A PARAMETER TO INDICATE THE SCALING OPTION\n! SCALE = 'U' OR SCALE = 'u' returnS\n! CY(J)=H(M,FNU+J-1,Z), J=1,...,N\n! = 'S' OR SCALE = 's' returnS\n! CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))\n! J=1,...,N , I**2=-1\n! M - KIND OF HANKEL function, M=1 OR 2\n! N - NUMBER OF MEMBERS OF THE SEQUENCE, N >= 1\n!\n! OUTPUT\n! CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN\n! VALUES FOR THE SEQUENCE\n! CY(J)=H(M,FNU+J-1,Z) OR\n! CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N\n! DEPENDING ON SCALE, I**2=-1.\n! NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,\n! NZ= 0 , NORMAL return\n! NZ>0 , FIRST NZ COMPONENTS OF CY SET TO ZERO\n! DUE TO UNDERFLOW, CY(J)=CMPLX(0.0,0.0)\n! J=1,...,NZ WHEN Y>0.0 AND M=1 OR\n! Y < 0.0 AND M=2. FOR THE COMPLMENTARY\n! HALF PLANES, NZ STATES ONLY THE NUMBER\n! OF UNDERFLOWS.\n! IERR -ERROR FLAG\n! IERR=0, NORMAL return - COMPUTATION COMPLETED\n! IERR=1, INPUT ERROR - NO COMPUTATION\n! IERR=2, OVERFLOW - NO COMPUTATION,\n! CABS(Z) TOO SMALL\n! IERR=3 OVERFLOW - NO COMPUTATION,\n! FNU+N-1 TOO LARGE\n! IERR=4, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE\n! BUT LOSSES OF SIGNIFCANCE BY ARGUMENT\n! REDUCTION PRODUCE LESS THAN HALF OF MACHINE\n! ACCURACY\n! IERR=5, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-\n! TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-\n! CANCE BY ARGUMENT REDUCTION\n! IERR=6, ERROR - NO COMPUTATION,\n! ALGORITHM TERMINATION CONDITION NOT MET\n!\n! LONG DESCRIPTION\n! ================\n!\n! THE COMPUTATION IS CARRIED OUT BY THE RELATION\n!\n! H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP))\n! MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1\n!\n! FOR M=1 OR 2 WHERE THE K BESSEL function IS COMPUTED FOR THE\n! RIGHT HALF PLANE RE(Z) >= 0.0. THE K function IS continueD\n! TO THE LEFT HALF PLANE BY THE RELATION\n!\n! K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)\n! MP=MR*PI*I, MR=+1 OR -1, RE(Z)>0, I**2=-1\n!\n! WHERE I(FNU,Z) IS THE I BESSEL function.\n!\n! EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z\n! PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL\n! GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING\n! BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE\n! WHOLE Z PLANE FOR Z TO INFINITY.\n!\n! FOR NEGATIVE ORDERS,THE FORMULAE\n!\n! H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I)\n! H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I)\n! I**2=-1\n!\n! CAN BE USED.\n!\n! IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-\n! MENTARY functionS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS\n! LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.\n! CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN\n! LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG\n! IERR=4 IS TRIGGERED WHERE UR=X02AJE()=UNIT ROUNDOFF. ALSO\n! IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS\n! LOST AND IERR=5. IN ORDER TO USE THE INT function, ARGUMENTS\n! MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE\n! INTEGER, U3=X02BBE(). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS\n! RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3\n! ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION\n! ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION\n! ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN\n! THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT\n! TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS\n! IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.\n! SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.\n!\n! THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX\n! BESSEL function CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT\n! ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-\n! SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE\n! ELEMENTARY functionS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),\n! ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF\n! CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY\n! HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN\n! ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY\n! SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER\n! THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,\n! 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS\n! THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER\n! COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY\n! BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER\n! COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE\n! MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,\n! THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,\n! OR -PI/2+P.\n!\n! REFERENCES\n! ==========\n! HANDBOOK OF MATHEMATICAL functionS BY M. ABRAMOWITZ\n! AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF\n! COMMERCE, 1955.\n!\n! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT\n! BY D. E. AMOS, SAND83-0083, MAY, 1983.\n!\n! COMPUTATION OF BESSEL functionS OF COMPLEX ARGUMENT\n! AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983\n!\n! A subroutine PACKAGE FOR BESSEL functionS OF A COMPLEX\n! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-\n! 1018, MAY, 1985\n!\n! A PORTABLE PACKAGE FOR BESSEL functionS OF A COMPLEX\n! ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.\n! MATH. SOFTWARE, 1986\n!\n! DATE WRITTEN 830501 (YYMMDD)\n! REVISION DATE 830501 (YYMMDD)\n! AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES\n!\n! .. Parameters ..\n CHARACTER*6 SRNAME\n PARAMETER (SRNAME='S17DLE')\n! .. Scalar Arguments ..\n COMPLEX Z\n REAL FNU\n INTEGER IFAIL, M, N, NZ\n CHARACTER*1 SCALE\n! .. Array Arguments ..\n COMPLEX CY(N)\n! .. Local Scalars ..\n COMPLEX CSGN, ZN, ZT\n REAL AA, ALIM, ALN, ARG, ASCLE, ATOL, AZ, BB, CPN, &\n DIG, ELIM, FMM, FN, FNUL, HPI, R1M5, RHPI, RL, &\n RTOL, SGN, SPN, TOL, UFL, XN, XX, YN, YY\n INTEGER I, IERR, INU, INUH, IR, K, K1, K2, KODE, MM, MR, &\n NN, NREC, NUF, NW\n! .. Local Arrays ..\n CHARACTER*80 REC(1)\n! .. External functions ..\n REAL X02AHE, X02AJE\n INTEGER P01ABE, X02BBE, X02BHE, X02BJE, X02BKE, X02BLE\n EXTERNAL X02AHE, X02AJE, P01ABE, X02BBE, X02BHE, X02BJE, &\n X02BKE, X02BLE\n! .. External subroutines ..\n EXTERNAL DEVS17, DGXS17, DLYS17, DLZS17\n! .. Intrinsic functions ..\n INTRINSIC ABS, AIMAG, CMPLX, COS, EXP, INT, LOG, LOG10, &\n MAX, MIN, MOD, REAL, SIGN, SIN, SQRT\n! .. Data statements ..\n!\n DATA HPI/1.57079632679489662E0/\n! .. Executable Statements ..\n NZ = 0\n NREC = 0\n XX = REAL(Z)\n YY = AIMAG(Z)\n IERR = 0\n if (SCALE == 'U' .or. SCALE == 'u') then\n KODE = 1\n else if (SCALE == 'S' .or. SCALE == 's') then\n KODE = 2\n ELSE\n KODE = -1\n endif\n if (XX == 0.0E0 .and. YY == 0.0E0) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99999)\n else if (FNU < 0.0E0) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99998) FNU\n else if (KODE == -1) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99997) SCALE\n else if (N < 1) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99996) N\n else if (M < 1 .or. M > 2) then\n IERR = 1\n NREC = 1\n WRITE (REC,FMT=99995) M\n endif\n if (IERR == 0) then\n NN = N\n! ---------------------------------------------------------------\n! SET PARAMETERS RELATED TO MACHINE CONSTANTS.\n! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.\n! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.\n! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND\n! EXP(ELIM)>EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR\n! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.\n! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR\n! LARGE Z.\n! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).\n! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE\n! FNU\n! ---------------------------------------------------------------\n TOL = MAX(X02AJE(),1.0E-18)\n K1 = X02BKE()\n K2 = X02BLE()\n R1M5 = LOG10(REAL(X02BHE()))\n K = MIN(ABS(K1),ABS(K2))\n ELIM = 2.303E0*(K*R1M5-3.0E0)\n K1 = X02BJE() - 1\n AA = R1M5*K1\n DIG = MIN(AA,18.0E0)\n AA = AA*2.303E0\n ALIM = ELIM + MAX(-AA,-41.45E0)\n FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)\n RL = 1.2E0*DIG + 3.0E0\n FN = FNU + NN - 1\n MM = 3 - M - M\n FMM = MM\n ZN = Z*CMPLX(0.0E0,-FMM)\n XN = REAL(ZN)\n YN = AIMAG(ZN)\n AZ = ABS(Z)\n! ---------------------------------------------------------------\n! TEST FOR RANGE\n! ---------------------------------------------------------------\n AA = 0.5E0/TOL\n BB = X02BBE(1.0E0)*0.5E0\n AA = MIN(AA,BB,X02AHE(1.0E0))\n if (AZ <= AA) then\n if (FN <= AA) then\n AA = SQRT(AA)\n if (AZ > AA) then\n IERR = 4\n NREC = 1\n WRITE (REC,FMT=99994) AZ, AA\n else if (FN > AA) then\n IERR = 4\n NREC = 1\n WRITE (REC,FMT=99993) FN, AA\n endif\n! ---------------------------------------------------------\n! OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE\n! ---------------------------------------------------------\n UFL = EXP(-ELIM)\n if (AZ >= UFL) then\n if (FNU > FNUL) then\n! ---------------------------------------------------\n! UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU>FNUL\n! ---------------------------------------------------\n MR = 0\n if ((XN < 0.0E0) .or. (XN == 0.0E0 .and. YN <&\n 0.0E0 .and. M == 2)) then\n MR = -MM\n if (XN == 0.0E0 .and. YN < 0.0E0) ZN = -ZN\n endif\n CALL DLYS17(ZN,FNU,KODE,MR,NN,CY,NW,TOL,ELIM,ALIM)\n if (NW < 0) then\n goto 40\n ELSE\n NZ = NZ + NW\n endif\n ELSE\n if (FN > 1.0E0) then\n if (FN > 2.0E0) then\n CALL DEVS17(ZN,FNU,KODE,2,NN,CY,NUF,TOL,ELIM, &\n ALIM)\n if (NUF < 0) then\n goto 60\n ELSE\n NZ = NZ + NUF\n NN = NN - NUF\n! ------------------------------------------\n! HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1\n! ON return FROM DEVS17\n! IF NUF=NN, THEN CY(I)=CZERO FOR ALL I\n! ------------------------------------------\n if (NN == 0) then\n if (XN < 0.0E0) then\n goto 60\n ELSE\n IFAIL = P01ABE(IFAIL,IERR,SRNAME, &\n NREC,REC)\n return\n endif\n endif\n endif\n else if (AZ <= TOL) then\n ARG = 0.5E0*AZ\n ALN = -FN*LOG(ARG)\n if (ALN > ELIM) goto 60\n endif\n endif\n if ((XN < 0.0E0) .or. (XN == 0.0E0 .and. YN <&\n 0.0E0 .and. M == 2)) then\n! ------------------------------------------------\n! LEFT HALF PLANE COMPUTATION\n! ------------------------------------------------\n MR = -MM\n CALL DLZS17(ZN,FNU,KODE,MR,NN,CY,NW,RL,FNUL,TOL, &\n ELIM,ALIM)\n if (NW < 0) then\n goto 40\n ELSE\n NZ = NW\n endif\n ELSE\n! ------------------------------------------------\n! RIGHT HALF PLANE COMPUTATION, XN >= 0. .and.\n! (XN /= 0. .or. YN >= 0. .or. M=1)\n! ------------------------------------------------\n CALL DGXS17(ZN,FNU,KODE,NN,CY,NZ,TOL,ELIM,ALIM)\n endif\n endif\n! ------------------------------------------------------\n! H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT)\n!\n! ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2\n! ------------------------------------------------------\n SGN = SIGN(HPI,-FMM)\n! ------------------------------------------------------\n! CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF\n! SIGNIFICANCE WHEN FNU IS LARGE\n! ------------------------------------------------------\n INU = INT(FNU)\n INUH = INU/2\n IR = INU - 2*INUH\n ARG = (FNU-INU+IR)*SGN\n RHPI = 1.0E0/SGN\n CPN = RHPI*COS(ARG)\n SPN = RHPI*SIN(ARG)\n! ZN = CMPLX(-SPN,CPN)\n CSGN = CMPLX(-SPN,CPN)\n! if (MOD(INUH,2)==1) ZN = -ZN\n if (MOD(INUH,2) == 1) CSGN = -CSGN\n ZT = CMPLX(0.0E0,-FMM)\n RTOL = 1.0E0/TOL\n ASCLE = UFL*RTOL\n DO 20 I = 1, NN\n! CY(I) = CY(I)*ZN\n! ZN = ZN*ZT\n ZN = CY(I)\n AA = REAL(ZN)\n BB = AIMAG(ZN)\n ATOL = 1.0E0\n if (MAX(ABS(AA),ABS(BB)) <= ASCLE) then\n ZN = ZN*RTOL\n ATOL = TOL\n endif\n ZN = ZN*CSGN\n CY(I) = ZN*ATOL\n CSGN = CSGN*ZT\n 20 continue\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n 40 if (NW == (-3)) then\n NZ = 0\n IERR = 5\n NREC = 1\n WRITE (REC,FMT=99988) AZ, AA\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n else if (NW /= (-1)) then\n NZ = 0\n IERR = 6\n NREC = 1\n WRITE (REC,FMT=99992)\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n 60 IERR = 3\n NZ = 0\n NREC = 1\n WRITE (REC,FMT=99991) FN\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n ELSE\n IERR = 2\n NZ = 0\n NREC = 1\n WRITE (REC,FMT=99990) AZ, UFL\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n endif\n ELSE\n NZ = 0\n IERR = 5\n NREC = 1\n WRITE (REC,FMT=99989) FN, AA\n endif\n ELSE\n NZ = 0\n IERR = 5\n NREC = 1\n WRITE (REC,FMT=99988) AZ, AA\n endif\n endif\n IFAIL = P01ABE(IFAIL,IERR,SRNAME,NREC,REC)\n return\n!\n 99999 FORMAT (1X,'** On entry, Z = (0.0,0.0)')\n 99998 FORMAT (1X,'** On entry, FNU < 0: FNU = ',E13.5)\n 99997 FORMAT (1X,'** On entry, SCALE has an illegal value: SCALE = ''', &\n A,'''')\n 99996 FORMAT (1X,'** On entry, N <= 0: N = ',I16)\n 99995 FORMAT (1X,'** On entry, M has illegal value: M = ',I16)\n 99994 FORMAT (1X,'** Results lack precision because abs(Z) =',1P,E13.5, &\n ' > ',E13.5)\n 99993 FORMAT (1X,'** Results lack precision, FNU+N-1 =',1P,E13.5, &\n ' > ',E13.5)\n 99992 FORMAT (1X,'** No computation - algorithm termination condition ', &\n 'not met.')\n 99991 FORMAT (1X,'** No computation because FNU+N-1 =',1P,E13.5,' is t', &\n 'oo large.')\n 99990 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' < ', &\n E13.5)\n 99989 FORMAT (1X,'** No computation because FNU+N-1 =',1P,E13.5,' > ', &\n E13.5)\n 99988 FORMAT (1X,'** No computation because abs(Z) =',1P,E13.5,' > ', &\n E13.5)\n END\n REAL function X02AHE(X)\n! MARK 9 RELEASE. NAG COPYRIGHT 1981.\n! MARK 11.5(F77) REVISED. (SEPT 1985.)\n!\n! * MAXIMUM ARGUMENT FOR SIN AND COS *\n! returnS THE LARGEST POSITIVE REAL NUMBER MAXSC SUCH THAT\n! SIN(MAXSC) AND COS(MAXSC) CAN BE SUCCESSFULLY COMPUTED\n! BY THE COMPILER SUPPLIED SIN AND COS ROUTINES.\n!\n! .. Scalar Arguments ..\n REAL X\n REAL CONX02\n DATA CONX02 /1.677721600000E+7 /\n! .. Executable Statements ..\n X02AHE = CONX02\n return\n END\n REAL function X02AJE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS (1/2)*B**(1-P) IF ROUNDS IS .true.\n! returnS B**(1-P) OTHERWISE\n!\n REAL CONX02\n DATA CONX02 /1.4210854715202E-14 /\n!bc DATA CONX02 /1.421090000020E-14 /\n! .. Executable Statements ..\n X02AJE = CONX02\n return\n END\n REAL function X02ALE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS (1 - B**(-P)) * B**EMAX (THE LARGEST POSITIVE MODEL\n! NUMBER)\n!\n REAL CONX02\n! DK DK DK DATA CONX02 /0577757777777777777777B /\n DATA CONX02 /1.e30/\n! .. Executable Statements ..\n X02ALE = CONX02\n return\n END\n REAL function X02AME()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE 'SAFE RANGE' PARAMETER\n! I.E. THE SMALLEST POSITIVE MODEL NUMBER Z SUCH THAT\n! FOR ANY X WHICH SATISFIES X >= Z AND X <= 1/Z\n! THE FOLLOWING CAN BE COMPUTED WITHOUT OVERFLOW, UNDERFLOW OR OTHER\n! ERROR\n!\n! -X\n! 1.0/X\n! SQRT(X)\n! LOG(X)\n! EXP(LOG(X))\n! Y**(LOG(X)/LOG(Y)) FOR ANY Y\n!\n REAL CONX02\n! DK DK DK DATA CONX02 /0200044000000000000004B /\n DATA CONX02 /1.e-27/\n! .. Executable Statements ..\n X02AME = CONX02\n return\n END\n REAL function X02ANE()\n! MARK 15 RELEASE. NAG COPYRIGHT 1991.\n!\n! returns the 'safe range' parameter for complex numbers,\n! i.e. the smallest positive model number Z such that\n! for any X which satisfies X >= Z and X <= 1/Z\n! the following can be computed without overflow, underflow or other\n! error\n!\n! -W\n! 1.0/W\n! SQRT(W)\n! LOG(W)\n! EXP(LOG(W))\n! Y**(LOG(W)/LOG(Y)) for any Y\n! ABS(W)\n!\n! where W is any of cmplx(X,0), cmplx(0,X), cmplx(X,X),\n! cmplx(1/X,0), cmplx(0,1/X), cmplx(1/X,1/X).\n!\n REAL CONX02\n!bc DATA CONX02 /0000006220426276611547B /\n!! DK DK DATA CONX02 / 2.708212596942E-1233 /\n DATA CONX02 / 2.708212596942E-30 /\n! .. Executable Statements ..\n X02ANE = CONX02\n return\n END\n INTEGER function X02BBE(X)\n! NAG COPYRIGHT 1975\n! MARK 4.5 RELEASE\n! MARK 11.5(F77) REVISED. (SEPT 1985.)\n! * MAXINT *\n! returnS THE LARGEST INTEGER REPRESENTABLE ON THE COMPUTER\n! THE X PARAMETER IS NOT USED\n! .. Scalar Arguments ..\n REAL X\n! .. Executable Statements ..\n! FOR ICL 1900\n! X02BBE = 8388607\n! DK DK DK X02BBE = 70368744177663\n X02BBE = 744177663\n return\n END\n INTEGER function X02BHE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE MODEL PARAMETER, B.\n!\n! .. Executable Statements ..\n X02BHE = 2\n return\n END\n INTEGER function X02BJE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE MODEL PARAMETER, p.\n!\n! .. Executable Statements ..\n X02BJE = 47\n return\n END\n INTEGER function X02BKE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE MODEL PARAMETER, EMIN.\n!\n! .. Executable Statements ..\n X02BKE = -8192\n return\n END\n INTEGER function X02BLE()\n! MARK 12 RELEASE. NAG COPYRIGHT 1986.\n!\n! returnS THE MODEL PARAMETER, EMAX.\n!\n! .. Executable Statements ..\n X02BLE = 8189\n return\n END\n subroutine X04AAE(I,NERR)\n! MARK 7 RELEASE. NAG COPYRIGHT 1978\n! MARK 7C REVISED IER-190 (MAY 1979)\n! MARK 11.5(F77) REVISED. (SEPT 1985.)\n! MARK 14 REVISED. IER-829 (DEC 1989).\n! IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER\n! (STORED IN NERR1).\n! IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO\n! VALUE SPECIFIED BY NERR.\n!\n! .. Scalar Arguments ..\n INTEGER I, NERR\n! .. Local Scalars ..\n INTEGER NERR1\n! .. Save statement ..\n SAVE NERR1\n! .. Data statements ..\n DATA NERR1/0/\n! .. Executable Statements ..\n if (I == 0) NERR = NERR1\n if (I == 1) NERR1 = NERR\n return\n END\n subroutine X04BAE(NOUT,REC)\n! MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986.\n!\n! X04BAE writes the contents of REC to the unit defined by NOUT.\n!\n! Trailing blanks are not output, except that if REC is entirely\n! blank, a single blank character is output.\n! If NOUT < 0, i.e. if NOUT is not a valid Fortran unit identifier,\n! then no output occurs.\n!\n! .. Scalar Arguments ..\n INTEGER NOUT\n CHARACTER*(*) REC\n! .. Local Scalars ..\n INTEGER I\n! .. Intrinsic functions ..\n INTRINSIC LEN\n! .. Executable Statements ..\n if (NOUT >= 0) then\n! Remove trailing blanks\n DO 20 I = LEN(REC), 2, -1\n if (REC(I:I) /= ' ') goto 40\n 20 continue\n! Write record to external file\n 40 WRITE (NOUT,FMT=99999) REC(1:I)\n endif\n return\n!\n 99999 FORMAT (A)\n END\n\n" }, { "path": "attenuation_model_with_SolvOpt.f90", "content": "\n! use of SolvOpt to compute attenuation relaxation mechanisms,\n! from Emilie Blanc, Bruno Lombard and Dimitri Komatitsch, CNRS Marseille, France, for a Generalized Zener body model.\n\n! The SolvOpt algorithm was developed by Franz Kappel and Alexei V. Kuntsevich\n! and is available open source at http://www.uni-graz.at/imawww/kuntsevich/solvopt\n!\n! It is described in Kappel and Kuntsevich, An Implementation of Shor's r-Algorithm,\n! Computational Optimization and Applications, vol. 15, p. 193-205 (2000).\n\n! If you use this code for your own research, please cite some (or all) of these articles:\n!\n! @Article{BlKoChLoXi15,\n! Title = {Positivity-preserving highly-accurate optimization of the {Z}ener viscoelastic model, with application\n! to wave propagation in the presence of strong attenuation},\n! Author = {\\'Emilie Blanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard and Zhinan Xie},\n! Journal = {Geophysical Journal International},\n! Year = {2015},\n! Note = {in press.}}\n\n!-------------------------------------------------------------------------\n\n! From Bruno Lombard, May 2014:\n\n! En interne dans le code ci-dessous on travaille en (Theta, Kappa).\n! Les Theta sont les points et les Kappa sont les poids.\n! Pour repasser en (Tau_Sigma, Tau_Epsilon), on doit appliquer les formules:\n!\n! Tau_Sigma = 1 / Theta\n! Tau_Epsilon = (1 / Theta) * (1 + Nrelax * Kappa) = Tau_Sigma * (1 + Nrelax * Kappa)\n\n! The system to solve can be found in equation (7) of:\n! Lombard and Piraux, Numerical modeling of transient two-dimensional viscoelastic waves,\n! Journal of Computational Physics, Volume 230, Issue 15, Pages 6099-6114 (2011)\n\n! Suivant les compilateurs et les options de compilation utilisees,\n! il peut y avoir des differences au 4eme chiffre significatif. C'est sans consequences sur la precision du calcul :\n! l'erreur est de 0.015 % avec optimization non lineaire, a comparer a 1.47 % avec Emmerich and Korn (1987).\n! Si je relance le calcul en initialisant avec le resultat precedent, ce chiffre varie a nouveau tres legerement.\n\n!-------------------------------------------------------------------------\n\n! From Bruno Lombard, June 2014:\n\n! j'ai relu en detail :\n\n! [1] Carcione, Kosslof, Kosslof, \"Viscoacoustic wave propagation simulation in the Earth\",\n! Geophysics 53-6 (1988), 769-777\n!\n! [2] Carcione, Kosslof, Kosslof, \"Wave propagation simulation in a linear viscoelastic medium\",\n! Geophysical Journal International 95 (1988), 597-611\n!\n! [3] Moczo, Kristek, \"On the rheological models used for time-domain methods of seismic wave propagation\",\n! Geophysical Research Letters 32 (2005).\n\n! Le probleme provient probablement d'une erreur recurrente dans [1,2] et datant de Liu et al 1976 :\n! l'oubli du facteur 1/N dans la fonction de relaxation d'un modele de Zener a N elements.\n! Il est effectivement facile de faire l'erreur. Voir l'equation (12) de [3], et le paragraphe qui suit.\n\n! Du coup le module de viscoelasticite est faux dans [1,2], et donc le facteur de qualite,\n! et donc les temps de relaxation tau_sigma...\n\n! Apres, [2] calcule une solution analytique juste, mais avec des coefficients sans sens physique.\n! Et quand SPECFEM2D obtient un bon accord avec cette solution analytique, ca valide SPECFEM, mais pas le calcul des coefficients.\n\n! Il y a donc une erreur dans [1,2], et [3] a raison.\n\n! Sa solution analytique decoule d'un travail sur ses fonctions de relaxation (A4),\n! qu'il injecte ensuite dans la relation de comportement (A1) et travaille en Fourier.\n\n! Le probleme est que sa fonction de relaxation (A4) est fausse : il manque 1/N.\n! De ce fait, sa solution analytique est coherente avec sa solution numerique.\n! Dans les deux cas, ce sont les memes temps de relaxation qui sont utilises. Mais ces temps sont calcules de facon erronee.\n\n!-------------------------------------------------------------------------\n\n! From Dimitri Komatitsch, June 2014:\n\n! In [2] Carcione, Kosslof, Kosslof, \"Wave propagation simulation in a linear viscoelastic medium\",\n! Geophysical Journal International 95 (1988), 597-611\n! there is another mistake: in Appendix B page 611 Carcione writes omega/(r*v),\n! but that is not correct, it should be omega*r/v instead.\n\n!---------------------------------------------------\n\n! From Emilie Blanc, April 2014:\n\n! le programme SolvOpt d'optimization non-lineaire\n! avec contrainte. Ce programme prend quatre fonctions en entree :\n\n! - fun() est la fonction a minimiser\n\n! - grad() est le gradient de la fonction a minimiser par rapport a chaque parametre\n\n! - func() est le maximum des residus (= 0 si toutes les contraintes sont satisfaites)\n\n! - gradc() est le gradient du maximum des residus (= 0 si toutes les\n! contraintes sont satisfaites)\n\n! Ce programme a ete developpe par Kappel et Kuntsevich. Leur article decrit l'algorithme.\n\n! J'ai utilise ce code pour la poroelasticite haute-frequence, et aussi en\n! viscoelasticite fractionnaire (modele d'Andrade, avec Bruno Lombard et\n! Cedric Bellis). Nous pouvons interagir sur l'algorithme d'optimization\n! pour votre modele visco, et etudier l'effet des coefficients ainsi obtenus.\n\n!---------------------------------------------------\n\n! From Emilie Blanc, March 2014:\n\n! Les entrees du programme principal sont le nombre de variables\n! diffusives, le facteur de qualite voulu Qref et la frequence centrale f0.\n\n! Cependant, pour l'optimization non-lineaire, j'ai mis theta_max=100*f0\n! et non pas theta_max=2*pi*100*f0. En effet, dans le programme, on\n! travaille sur les frequences, et non pas sur les frequences angulaires.\n! Cela dit, dans les deux cas j'obtiens les memes coefficients...\n\n\n!---------------------------------------------------\n\nsubroutine compute_attenuation_coeffs(N,Qref,f0,f_min,f_max,tau_epsilon,tau_sigma)\n\n implicit none\n\n! pi\n double precision, parameter :: PI = 3.141592653589793d0\n double precision, parameter :: TWO_PI = 2.d0 * PI\n\n integer, intent(in) :: N\n double precision, intent(in) :: Qref,f_min,f_max,f0\n double precision, dimension(1:N), intent(out) :: tau_epsilon,tau_sigma\n\n integer i\n double precision, dimension(1:N) :: point,weight\n\n! nonlinear optimization with constraints\n call nonlinear_optimization(N,Qref,f0,point,weight,f_min,f_max)\n\n do i = 1,N\n tau_sigma(i) = 1.d0 / point(i)\n tau_epsilon(i) = tau_sigma(i) * (1.d0 + N * weight(i))\n enddo\n\n! print *,'points = '\n! do i = 1,N\n! print *,point(i)\n! enddo\n! print *\n\n! print *,'weights = '\n! do i = 1,N\n! print *,weight(i)\n! enddo\n! print *\n\n print *,'tau_epsilon computed by SolvOpt() = '\n do i = 1,N\n print *,tau_epsilon(i)\n enddo\n print *\n\n print *,'tau_sigma computed by SolvOpt() = '\n do i = 1,N\n print *,tau_sigma(i)\n enddo\n print *\n\nend subroutine compute_attenuation_coeffs\n\n!---------------------------------------------------\n\n! classical calculation of the coefficients based on linear least squares\n\nsubroutine decomposition_LU(a,i_min,n,indx,d)\n\n implicit none\n\n integer, intent(in) :: i_min,n\n double precision, intent(out) :: d\n integer, dimension(i_min:n), intent(inout) :: indx\n double precision, dimension(i_min:n,i_min:n), intent(inout) :: a\n\n integer i,imax,j,k\n double precision big,dum,somme,eps\n double precision, dimension(i_min:n) :: vv\n\n imax = 0\n d = 1.\n eps = 1.e-20\n\n do i = i_min,n\n big = 0.\n do j = i_min,n\n if (abs(a(i,j)) > big) then\n big = abs(a(i,j))\n endif\n enddo\n if (big == 0.) then\n print *,'Singular matrix in routine decomposition_LU'\n endif\n vv(i) = 1./big\n enddo\n\n do j = i_min,n\n do i = i_min,j-1\n somme = a(i,j)\n do k = i_min,i-1\n somme = somme - a(i,k)*a(k,j)\n enddo\n a(i,j) = somme\n enddo\n\n big = 0.\n\n do i = j,n\n somme = a(i,j)\n do k = i_min,j-1\n somme = somme - a(i,k)*a(k,j)\n enddo\n a(i,j) = somme\n dum = vv(i)*abs(somme)\n if (dum >= big) then\n big = dum\n imax = i\n endif\n enddo\n\n if (j /= imax) then\n do k = i_min,n\n dum = a(imax,k)\n a(imax,k) = a(j,k)\n a(j,k) = dum\n enddo\n d = -d\n vv(imax) = vv(j)\n endif\n\n indx(j) = imax\n if (a(j,j) == 0.) then\n a(j,j) = eps\n endif\n if (j /= n) then\n dum = 1./a(j,j)\n do i = j+1,n\n a(i,j) = a(i,j)*dum\n enddo\n endif\n enddo\n\nend subroutine decomposition_LU\n\nsubroutine LUbksb(a,i_min,n,indx,b,m)\n\n implicit none\n\n integer, intent(in) :: i_min,n,m\n integer, dimension(i_min:n), intent(in) :: indx\n double precision, dimension(i_min:n,i_min:n), intent(in) :: a\n double precision, dimension(i_min:n,i_min:m), intent(inout) :: b\n\n integer i,ip,j,ii,k\n double precision somme\n\n do k = i_min,m\n\n ii = -1\n\n do i = i_min,n\n ip = indx(i)\n somme = b(ip,k)\n b(ip,k) = b(i,k)\n if (ii /= -1) then\n do j = ii,i-1\n somme = somme - a(i,j)*b(j,k)\n enddo\n else if (somme /= 0.) then\n ii = i\n endif\n b(i,k) = somme\n enddo\n\n do i = n,i_min,-1\n somme = b(i,k)\n do j = i+1,n\n somme = somme - a(i,j)*b(j,k)\n enddo\n b(i,k) = somme/a(i,i)\n enddo\n enddo\n\nend subroutine LUbksb\n\nsubroutine syst_LU(a,i_min,n,b,m)\n\n implicit none\n\n integer, intent(in) :: i_min,n,m\n double precision, dimension(i_min:n,i_min:n), intent(in) :: a\n double precision, dimension(i_min:n,i_min:m), intent(inout) :: b\n\n integer i,j\n integer, dimension(i_min:n) :: indx\n double precision d\n double precision, dimension(i_min:n,i_min:n) :: aux\n\n do j = i_min,n\n indx(j) = 0\n do i = i_min,n\n aux(i,j) = a(i,j)\n enddo\n enddo\n\n call decomposition_LU(aux,i_min,n,indx,d)\n call LUbksb(aux,i_min,n,indx,b,m)\n\nend subroutine syst_LU\n\nsubroutine lfit_zener(x,y,sig,ndat,poids,ia,covar,chisq,ma,Qref,point)\n! ma = nombre de variable diffusive\n! ndat = m = K nombre d'abcisse freq_k\n\n implicit none\n\n integer, intent(in) :: ndat,ma\n logical, dimension(1:ma), intent(in) :: ia\n double precision, intent(in) :: Qref\n double precision, intent(out) :: chisq\n double precision, dimension(1:ndat), intent(in) :: x,y,sig\n double precision, dimension(1:ma), intent(in) :: point\n double precision, dimension(1:ma), intent(out) :: poids\n double precision, dimension(1:ma,1:ma), intent(out) :: covar\n\n integer i,j,k,l,mfit\n double precision ym,wt,sig2i\n double precision, dimension(1:ma) :: afunc\n double precision, dimension(1:ma,1:1) :: beta\n\n mfit = 0\n\n do j = 1,ma\n if (ia(j)) then\n mfit = mfit + 1\n endif\n enddo\n if (mfit == 0) then\n print *,'lfit: no parameters to be fitted'\n endif\n\n do j=1,mfit\n beta(j,1) = 0.\n do k=1,mfit\n covar(j,k) = 0.\n enddo\n enddo\n\n do i=1,ndat\n call func_zener(x(i),afunc,ma,Qref,point)\n ym = y(i)\n if (mfit < ma) then\n do j=1,ma\n if (.not. ia(j)) then\n ym = ym - poids(j) * afunc(j)\n endif\n enddo\n endif\n sig2i = 1. / (sig(i) * sig(i))\n j = 0\n do l=1,ma\n if (ia(l)) then\n j = j+1\n wt = afunc(l) * sig2i\n k = count(ia(1:l))\n covar(j,1:k) = covar(j,1:k) + wt * pack(afunc(1:l),ia(1:l))\n beta(j,1) = beta(j,1) + ym * wt\n endif\n enddo\n enddo\n\n do j=2,mfit,1\n do k=1,j-1,1\n covar(k,j) = covar(j,k)\n enddo\n enddo\n\n if (ma == 1) then\n poids(1) = beta(1,1)/covar(1,1)\n else if (ma > 1) then\n call syst_LU(covar,1,mfit,beta,1)\n poids(1:ma) = unpack(beta(1:ma,1),ia,poids(1:ma))\n endif\n\n chisq = 0.\n do i=1,ndat\n call func_zener(x(i),afunc,ma,Qref,point)\n chisq=chisq+((y(i)-dot_product(poids(1:ma),afunc(1:ma)))/sig(i))**2\n enddo\n\nend subroutine lfit_zener\n\nsubroutine func_zener(x,afunc,N,Qref,point)\n\n implicit none\n\n integer, intent(in) :: N\n double precision, intent(in) :: x,Qref\n double precision, dimension(1:N), intent(in) :: point\n double precision, dimension(1:N), intent(out) :: afunc\n\n integer k\n double precision num,deno\n\n do k = 1,N\n num = x * (point(k) - x / Qref)\n deno = point(k) * point(k) + x * x\n afunc(k) = num / deno\n enddo\n\nend subroutine func_zener\n\nsubroutine remplit_point(fmin,fmax,N,point)\n\n implicit none\n\n! pi\n double precision, parameter :: PI = 3.141592653589793d0\n double precision, parameter :: TWO_PI = 2.d0 * PI\n\n integer, intent(in) :: N\n double precision, intent(in) :: fmin,fmax\n double precision, dimension(1:N), intent(out) :: point\n\n integer l\n\n if (N == 1) then\n point(1) = sqrt(fmin * fmax)\n ELSE\n do l = 1, N, 1\n point(l) = (fmax/fmin) ** ((l-1.)/(N-1.))\n point(l) = TWO_PI * point(l) * fmin\n enddo\n endif\n\nend subroutine remplit_point\n\nsubroutine classical_linear_least_squares(Qref,poids,point,N,fmin,fmax)\n\n implicit none\n\n! pi\n double precision, parameter :: PI = 3.141592653589793d0\n double precision, parameter :: TWO_PI = 2.d0 * PI\n\n\n integer, intent(in) :: N\n double precision, intent(in) :: Qref,fmin,fmax\n double precision, dimension(1:N), intent(out) :: point,poids\n\n integer k,m\n logical, dimension(1:N) :: ia\n double precision ref,freq,chi2\n double precision, dimension(1:N,1:N) :: covar\n double precision, dimension(1:2*N-1) :: x,y_ref,sig\n\n m = 2*N-1\n\n call remplit_point(fmin,fmax,N,point)\n\n ref = 1.0 / Qref\n\n do k=1,m\n freq = (fmax/fmin) ** ((k - 1.)/(m - 1.))\n freq = TWO_PI * fmin * freq\n x(k) = freq\n y_ref(k) = ref\n sig(k) = 1.\n enddo\n\n do k=1,N\n ia(k) = .true.\n enddo\n\n call lfit_zener(x,y_ref,sig,m,poids,ia,covar,chi2,N,Qref,point)\n\nend subroutine classical_linear_least_squares\n\n! Calcul des coefficients par optimization non-lineaire avec contraintes\n\nsubroutine solvopt(n,x,f,fun,flg,grad,options,flfc,func,flgc,gradc,Qref,Kopt,theta_min,theta_max,f_min,f_max)\n!-----------------------------------------------------------------------------\n! The subroutine SOLVOPT performs a modified version of Shor's r-algorithm in\n! order to find a local minimum resp. maximum of a nonlinear function\n! defined on the n-dimensional Euclidean space\n! or\n! a local minimum for a nonlinear constrained problem:\n! min { f(x): g(x) ( < )= 0, g(x) in R(m), x in R(n) }.\n! Arguments:\n! n is the space dimension (integer*4),\n! x is the n-vector, the coordinates of the starting point\n! at a call to the subroutine and the optimizer at regular return\n! (double precision),\n! f returns the optimum function value\n! (double precision),\n! fun is the entry name of a subroutine which computes the value\n! of the function < fun> at a point x, should be declared as external\n! in a calling routine,\n! synopsis: fun(x,f)\n! grad is the entry name of a subroutine which computes the gradient\n! vector of the function < fun> at a point x, should be declared as\n! external in a calling routine,\n! synopsis: grad(x,g)\n! func is the entry name of a subroutine which computes the MAXIMAL\n! RESIDIAL!!! (a scalar) for a set of constraints at a point x,\n! should be declared as external in a calling routine,\n! synopsis: func(x,fc)\n! gradc is the entry name of a subroutine which computes the gradient\n! vector for a constraint with the MAXIMAL RESIDUAL at a point x,\n! should be declared as external in a calling routine,\n! synopsis: gradc(x,gc)\n! flg, (logical) is a flag for the use of a subroutine < grad>:\n! .true. means gradients are calculated by the user-supplied routine.\n! flfc, (logical) is a flag for a constrained problem:\n! .true. means the maximal residual for a set of constraints\n! is calculated by < func>.\n! flgc, (logical) is a flag for the use of a subroutine < gradc>:\n! .true. means gradients of the constraints are calculated\n! by the user-supplied routine.\n! options is a vector of optional parameters (double precision):\n! options(1)= H, where sign(H)=-1 resp. sign(H)=+1 means minimize resp.\n! maximize < fun> (valid only for an unconstrained problem) and\n! H itself is a factor for the initial trial step size\n! (options(1)=-1.d0 by default),\n! options(2)= relative error for the argument in terms of the infinity-norm\n! (1.d-4 by default),\n! options(3)= relative error for the function value (1.d-6 by default),\n! options(4)= limit for the number of iterations (1.5d4 by default),\n! options(5)= control of the display of intermediate results and error\n! resp. warning messages (default value is 0.d0, i.e., no intermediate\n! output but error and warning messages, see the manual for more),\n! options(6)= maximal admissible residual for a set of constraints\n! (options(6)=1.d-8 by default, see the manual for more),\n! *options(7)= the coefficient of space dilation (2.5d0 by default),\n! *options(8)= lower bound for the stepsize used for the difference\n! approximation of gradients (1.d-11 by default,see the manual for more).\n! (* ... changes should be done with care)\n! returned optional values:\n! options(9), the number of iterations, if positive,\n! or an abnormal stop code, if negative (see manual for more),\n! -1: allocation error,\n! -2: improper space dimension,\n! -3: < fun> returns an improper value,\n! -4: < grad> returns a zero vector or improper value at the\n! starting point,\n! -5: < func> returns an improper value,\n! -6: < gradc> returns an improper value,\n! -7: function is unbounded,\n! -8: gradient is zero at the point,\n! but stopping criteria are not fulfilled,\n! -9: iterations limit exceeded,\n! -11: Premature stop is possible,\n! -12: Result may not provide the true optimum,\n! -13: function is flat: result may be inaccurate\n! in view of a point.\n! -14: function is steep: result may be inaccurate\n! in view of a function value,\n! options(10), the number of objective function evaluations, and\n! options(11), the number of gradient evaluations.\n! options(12), the number of constraint function evaluations, and\n! options(13), the number of constraint gradient evaluations.\n! ____________________________________________________________________________\n!\n implicit none\n !include 'messages.inc'\n\n integer, intent(in) :: Kopt\n double precision, intent(in) :: Qref,theta_min,theta_max,f_min,f_max\n\n logical flg,flgc,flfc, constr, app, appconstr\n logical FsbPnt, FsbPnt1, termflag, stopf\n logical stopping, dispwarn, Reset, ksm,knan,obj\n integer n, kstore, ajp,ajpp,knorms, k, kcheck, numelem\n integer dispdata, ld, mxtc, termx, limxterm, nzero, krerun\n integer warnno, kflat, stepvanish, i,j,ni,ii, kd,kj,kc,ip\n integer iterlimit, kg,k1,k2, kless, allocerr\n double precision options(13),doptions(13)\n double precision x(n),f\n double precision nsteps(3), gnorms(10), kk, nx\n double precision ajb,ajs, des, dq,du20,du10,du03\n double precision n_float, cnteps\n double precision low_bound, ZeroGrad, ddx, y\n double precision lowxbound, lowfbound, detfr, detxr, grbnd\n double precision fp,fp1,fc,f1,f2,fm,fopt,frec,fst, fp_rate\n double precision PenCoef, PenCoefNew\n double precision gamma,w,wdef,h1,h,hp\n double precision dx,ng,ngc,nng,ngt,nrmz,ng1,d,dd, laststep\n double precision zero,one,two,three,four,five,six,seven\n double precision eight,nine,ten,hundr\n double precision infty, epsnorm,epsnorm2,powerm12\n double precision, dimension(:,:), allocatable :: B\n double precision, dimension(:), allocatable :: g\n double precision, dimension(:), allocatable :: g0\n double precision, dimension(:), allocatable :: g1\n double precision, dimension(:), allocatable :: gt\n double precision, dimension(:), allocatable :: gc\n double precision, dimension(:), allocatable :: z\n double precision, dimension(:), allocatable :: x1\n double precision, dimension(:), allocatable :: xopt\n double precision, dimension(:), allocatable :: xrec\n double precision, dimension(:), allocatable :: grec\n double precision, dimension(:), allocatable :: xx\n double precision, dimension(:), allocatable :: deltax\n integer, dimension(:), allocatable :: idx\n character(len=100) :: endwarn\n character(len=19) :: allocerrstr\n external fun,grad,func,gradc\n\n data zero/0.d0/, one/1.d0/, two/2.d0/, three/3.d0/, four/4.d0/, &\n five/5.d0/, six/6.d0/, seven/7.d0/, eight/8.d0/, nine/9.d0/, &\n ten/1.d1/, hundr/1.d2/, powerm12/1.d-12/, &\n infty /1.d100/, epsnorm /1.d-15/, epsnorm2 /1.d-30/, &\n allocerrstr/'Allocation Error = '/\n! Check the dimension:\n if (n < 2) then\n print *, 'SolvOpt error:'\n print *, 'Improper space dimension.'\n stop 'error in allocate statement in SolvOpt'\n options(9)=-one\n goto 999\n endif\n n_float=dble(n)\n! allocate working arrays:\n allocate (B(n,n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (g(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (g0(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (g1(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (gt(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (gc(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (z(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (x1(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (xopt(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (xrec(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (grec(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (xx(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (deltax(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n allocate (idx(n),stat=allocerr)\n if (allocerr /= 0) then\n options(9)=-one\n print *,allocerrstr,allocerr\n stop 'error in allocate statement in SolvOpt'\n endif\n\n! store flags:\n app= .not. flg\n constr=flfc\n appconstr= .not. flgc\n! Default values for options:\n call soptions(doptions)\n do i=1,8\n if (options(i) == zero) then\n options(i)=doptions(i)\n else if (i == 2 .or. i == 3 .or. i == 6) then\n options(i)=dmax1(options(i),powerm12)\n options(i)=dmin1(options(i),one)\n if (i == 2)options(i)=dmax1(options(i),options(8)*hundr)\n else if (i == 7) then\n options(7)=dmax1(options(i),1.5d0)\n endif\n enddo\n\n! WORKING CONSTANTS AND COUNTERS ----{\n\n options(10)=zero !! counter for function calculations\n options(11)=zero !! counter for gradient calculations\n options(12)=zero !! counter for constraint function calculations\n options(13)=zero !! counter for constraint gradient calculations\n iterlimit=idint(options(4))\n if (constr) then\n h1=-one !! NLP: restricted to minimization\n cnteps=options(6)\n else\n h1=dsign(one,options(1)) !! Minimize resp. maximize a function\n endif\n k=0 !! Iteration counter\n wdef=one/options(7)-one !! Default space transf. coeff.\n\n! Gamma control ---{\n ajb=one+1.d-1/n_float**2 !! Base I\n ajp=20\n ajpp=ajp !! Start value for the power\n ajs=1.15d0 !! Base II\n knorms=0\n do i=1,10\n gnorms(i)=zero\n enddo\n!---}\n! Display control ---{\n if (options(5) <= zero) then\n dispdata=0\n if (options(5) == -one) then\n dispwarn=.false.\n else\n dispwarn=.true.\n endif\n else\n dispdata=idnint(options(5))\n dispwarn=.true.\n endif\n ld=dispdata\n!---}\n\n! Stepsize control ---{\n dq=5.1d0 !! Step divider (at f_{i+1} > gamma*f_{i})\n du20=two\n du10=1.5d0\n du03=1.05d0 !! Step multipliers (at certain steps made)\n kstore=3\n do i=1,kstore\n nsteps(i)=zero !! Steps made at the last 'kstore' iterations\n enddo\n if (app) then\n des=6.3d0 !! Desired number of steps per 1-D search\n else\n des=3.3d0\n endif\n mxtc=3 !! Number of trial cycles (steep wall detect)\n!---}\n termx=0\n limxterm=50 !! Counter and limit for x-criterion\n! stepsize for gradient approximation\n ddx=dmax1(1.d-11,options(8))\n\n low_bound=-one+1.d-4 !! Lower bound cosine used to detect a ravine\n ZeroGrad=n_float*1.d-16 !! Lower bound for a gradient norm\n nzero=0 !! Zero-gradient events counter\n! Low bound for the values of variables to take into account\n lowxbound=dmax1(options(2),1.d-3)\n! Lower bound for function values to be considered as making difference\n lowfbound=options(3)**2\n krerun=0 !! Re-run events counter\n detfr=options(3)*hundr !! Relative error for f/f_{record}\n detxr=options(2)*ten !! Relative error for norm(x)/norm(x_{record})\n warnno=0 !! the number of warn.mess. to end with\n kflat=0 !! counter for points of flatness\n stepvanish=0 !! counter for vanished steps\n stopf=.false.\n! ----} End of setting constants\n! ----} End of the preamble\n!--------------------------------------------------------------------\n! COMPUTE THE function ( FIRST TIME ) ----{\n call fun(x,f,Qref,n/2,n,Kopt,f_min,f_max)\n options(10)=options(10)+one\n if (dabs(f) >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,'function equals infinity at the point.'\n print *,'Choose another starting point.'\n endif\n options(9)=-three\n goto 999\n endif\n do i=1,n\n xrec(i)=x(i)\n enddo\n frec=f !! record point and function value\n! Constrained problem\n if (constr) then\n kless=0\n fp=f\n call func(x,fc,n/2,n,theta_min,theta_max)\n options(12)=options(12)+one\n if (dabs(fc) >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,' < FUNC > returns infinite value at the point.'\n print *,'Choose another starting point.'\n endif\n options(9)=-five\n goto 999\n endif\n PenCoef=one !! first rough approximation\n if (fc <= cnteps) then\n FsbPnt=.true. !! feasible point\n fc=zero\n else\n FsbPnt=.false.\n endif\n f=f+PenCoef*fc\n endif\n! ----}\n! COMPUTE THE GRADIENT ( FIRST TIME ) ----{\n if (app) then\n do i=1,n\n deltax(i)=h1*ddx\n enddo\n obj=.true.\n !if (constr) then\n !call apprgrdn()\n !else\n !call apprgrdn()\n !endif\n options(10)=options(10)+n_float\n else\n call grad(x,g,Qref,n/2,n,Kopt,f_min,f_max)\n options(11)=options(11)+one\n endif\n ng=zero\n do i=1,n\n ng=ng+g(i)*g(i)\n enddo\n ng=dsqrt(ng)\n if (ng >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,'Gradient equals infinity at the starting point.'\n print *,'Choose another starting point.'\n endif\n options(9)=-four\n goto 999\n else if (ng < ZeroGrad) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,'Gradient equals zero at the starting point.'\n print *,'Choose another starting point.'\n endif\n options(9)=-four\n goto 999\n endif\n if (constr) then\n if (.not. FsbPnt) then\n !if (appconstr) then\n !do j=1,n\n !if (x(j) >= zero) then\n !deltax(j)=ddx\n !else\n !deltax(j)=-ddx\n !endif\n !enddo\n !obj=.false.\n !call apprgrdn()\n if (.not. appconstr) then\n call gradc(x,gc,n/2,n,theta_min,theta_max)\n endif\n ngc=zero\n do i=1,n\n ngc=ngc+gc(i)*gc(i)\n enddo\n ngc=dsqrt(ngc)\n if (ng >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,' < GRADC > returns infinite vector at the point.'\n print *,'Choose another starting point.'\n endif\n options(9)=-six\n goto 999\n else if (ng < ZeroGrad) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,' < GRADC > returns zero vector at an infeasible point.'\n endif\n options(9)=-six\n goto 999\n endif\n do i=1,n\n g(i)=g(i)+PenCoef*gc(i)\n enddo\n ng=zero\n do i=1,n\n ng=ng+g(i)*g(i)\n grec(i)=g(i)\n enddo\n ng=dsqrt(ng)\n endif\n endif\n do i=1,n\n grec(i)=g(i)\n enddo\n nng=ng\n! ----}\n! INITIAL STEPSIZE\n d=zero\n do i=1,n\n if (d < dabs(x(i))) d=dabs(x(i))\n enddo\n h=h1*dsqrt(options(2))*d !! smallest possible stepsize\n if (dabs(options(1)) /= one) then\n h=h1*dmax1(dabs(options(1)),dabs(h)) !! user-supplied stepsize\n else\n h=h1*dmax1(one/dlog(ng+1.1d0),dabs(h)) !! calculated stepsize\n endif\n\n! RESETTING LOOP ----{\n do while (.true.)\n kcheck=0 !! Set checkpoint counter.\n kg=0 !! stepsizes stored\n kj=0 !! ravine jump counter\n do i=1,n\n do j=1,n\n B(i,j)=zero\n enddo\n B(i,i)=one !! re-set transf. matrix to identity\n g1(i)=g(i)\n enddo\n fst=f\n dx=0\n! ----}\n\n! MAIN ITERATIONS ----{\n\n do while (.true.)\n k=k+1\n kcheck=kcheck+1\n laststep=dx\n! ADJUST GAMMA --{\n gamma=one+dmax1(ajb**((ajp-kcheck)*n),two*options(3))\n gamma=dmin1 ( gamma,ajs**dmax1(one,dlog10(nng+one)) )\n! --}\n ngt=zero\n ng1=zero\n dd=zero\n do i=1,n\n d=zero\n do j=1,n\n d=d+B(j,i)*g(j)\n enddo\n gt(i)=d\n dd=dd+d*g1(i)\n ngt=ngt+d*d\n ng1=ng1+g1(i)*g1(i)\n enddo\n ngt=dsqrt(ngt)\n ng1=dsqrt(ng1)\n dd=dd/ngt/ng1\n\n w=wdef\n! JUMPING OVER A RAVINE ----{\n if (dd < low_bound) then\n if (kj == 2) then\n do i=1,n\n xx(i)=x(i)\n enddo\n endif\n if (kj == 0) kd=4\n kj=kj+1\n w=-.9d0 !! use large coef. of space dilation\n h=h*two\n if (kj > 2*kd) then\n kd=kd+1\n warnno=1\n endwarn='Premature stop is possible. Try to re-run the routine from the obtained point.'\n do i=1,n\n if (dabs(x(i)-xx(i)) < epsnorm*dabs(x(i))) then\n if (dispwarn) then\n print *,'SolvOpt warning:'\n print *,'Ravine with a flat bottom is detected.'\n endif\n endif\n enddo\n endif\n else\n kj=0\n endif\n! ----}\n! DILATION ----{\n nrmz=zero\n do i=1,n\n z(i)=gt(i)-g1(i)\n nrmz=nrmz+z(i)*z(i)\n enddo\n nrmz=dsqrt(nrmz)\n if (nrmz > epsnorm*ngt) then\n do i=1,n\n z(i)=z(i)/nrmz\n enddo\n! New direction in the transformed space: g1=gt+w*(z*gt')*z and\n! new inverse matrix: B = B ( I + (1/alpha -1)zz' )\n d = zero\n do i=1,n\n d=d+z(i)*gt(i)\n enddo\n ng1=zero\n d = d*w\n do i=1,n\n dd=zero\n g1(i)=gt(i)+d*z(i)\n ng1=ng1+g1(i)*g1(i)\n do j=1,n\n dd=dd+B(i,j)*z(j)\n enddo\n dd=w*dd\n do j=1,n\n B(i,j)=B(i,j)+dd*z(j)\n enddo\n enddo\n ng1=dsqrt(ng1)\n else\n do i=1,n\n z(i)=zero\n g1(i)=gt(i)\n enddo\n nrmz=zero\n endif\n do i=1,n\n gt(i)=g1(i)/ng1\n enddo\n do i=1,n\n d=zero\n do j=1,n\n d=d+B(i,j)*gt(j)\n enddo\n g0(i)=d\n enddo\n! ----}\n! RESETTING ----{\n if (kcheck > 1) then\n numelem=0\n do i=1,n\n if (dabs(g(i)) > ZeroGrad) then\n numelem=numelem+1\n idx(numelem)=i\n endif\n enddo\n if (numelem > 0) then\n grbnd=epsnorm*dble(numelem**2)\n ii=0\n do i=1,numelem\n j=idx(i)\n if (dabs(g1(j)) <= dabs(g(j))*grbnd) ii=ii+1\n enddo\n if (ii == n .or. nrmz == zero) then\n if (dispwarn) then\n print *,'SolvOpt warning:'\n print *,'Normal re-setting of a transformation matrix.'\n endif\n if (dabs(fst-f) < dabs(f)*1.d-2) then\n ajp=ajp-10*n\n else\n ajp=ajpp\n endif\n h=h1*dx/three\n k=k-1\n exit\n endif\n endif\n endif\n! ----}\n! STORE THE CURRENT VALUES AND SET THE COUNTERS FOR 1-D SEARCH\n do i=1,n\n xopt(i)=x(i)\n enddo\n fopt=f\n k1=0\n k2=0\n ksm=.false.\n kc=0\n knan=.false.\n hp=h\n if (constr) Reset=.false.\n! 1-D SEARCH ----{\n do while (.true.)\n do i=1,n\n x1(i)=x(i)\n enddo\n f1=f\n if (constr) then\n FsbPnt1=FsbPnt\n fp1=fp\n endif\n! NEW POINT\n do i=1,n\n x(i)=x(i)+hp*g0(i)\n enddo\n ii=0\n do i=1,n\n if (dabs(x(i)-x1(i)) < dabs(x(i))*epsnorm) ii=ii+1\n enddo\n! function VALUE\n call fun(x,f,Qref,n/2,n,Kopt,f_min,f_max)\n options(10)=options(10)+one\n if (h1*f >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,'function is unbounded.'\n endif\n options(9)=-seven\n goto 999\n endif\n if (constr) then\n fp=f\n call func(x,fc,n/2,n,theta_min,theta_max)\n options(12)=options(12)+one\n if (dabs(fc) >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,' < FUNC > returns infinite value at the point.'\n print *,'Choose another starting point.'\n endif\n options(9)=-five\n goto 999\n endif\n if (fc <= cnteps) then\n FsbPnt=.true.\n fc=zero\n else\n FsbPnt=.false.\n fp_rate=fp-fp1\n if (fp_rate < -epsnorm) then\n if (.not. FsbPnt1) then\n d=zero\n do i=1,n\n d=d+(x(i)-x1(i))**2\n enddo\n d=dsqrt(d)\n PenCoefNew=-1.5d1*fp_rate/d\n if (PenCoefNew > 1.2d0*PenCoef) then\n PenCoef=PenCoefNew\n Reset=.true.\n kless=0\n f=f+PenCoef*fc\n exit\n endif\n endif\n endif\n endif\n f=f+PenCoef*fc\n endif\n if (dabs(f) >= infty) then\n if (dispwarn) then\n print *,'SolvOpt warning:'\n print *,'function equals infinity at the point.'\n endif\n if (ksm .or. kc >= mxtc) then\n options(9)=-three\n goto 999\n else\n k2=k2+1\n k1=0\n hp=hp/dq\n do i=1,n\n x(i)=x1(i)\n enddo\n f=f1\n knan=.true.\n if (constr) then\n FsbPnt=FsbPnt1\n fp=fp1\n endif\n endif\n! STEP SIZE IS ZERO TO THE EXTENT OF EPSNORM\n else if (ii == n) then\n stepvanish=stepvanish+1\n if (stepvanish >= 5) then\n options(9)=-ten-four\n if (dispwarn) then\n print *,'SolvOpt: Termination warning:'\n print *,'Stopping criteria are not fulfilled. The function is very steep at the solution.'\n endif\n goto 999\n else\n do i=1,n\n x(i)=x1(i)\n enddo\n f=f1\n hp=hp*ten\n ksm=.true.\n if (constr) then\n FsbPnt=FsbPnt1\n fp=fp1\n endif\n endif\n! USE SMALLER STEP\n else if (h1*f < h1*gamma**idint(dsign(one,f1))*f1) then\n if (ksm) exit\n k2=k2+1\n k1=0\n hp=hp/dq\n do i=1,n\n x(i)=x1(i)\n enddo\n f=f1\n if (constr) then\n FsbPnt=FsbPnt1\n fp=fp1\n endif\n if (kc >= mxtc) exit\n! 1-D OPTIMIZER IS LEFT BEHIND\n else\n if (h1*f <= h1*f1) exit\n! USE LARGER STEP\n k1=k1+1\n if (k2 > 0) kc=kc+1\n k2=0\n if (k1 >= 20) then\n hp=du20*hp\n else if (k1 >= 10) then\n hp=du10*hp\n else if (k1 >= 3) then\n hp=du03*hp\n endif\n endif\n enddo\n! ----} End of 1-D search\n! ADJUST THE TRIAL STEP SIZE ----{\n dx=zero\n do i=1,n\n dx=dx+(xopt(i)-x(i))**2\n enddo\n dx=dsqrt(dx)\n if (kg < kstore) kg=kg+1\n if (kg >= 2) then\n do i=kg,2,-1\n nsteps(i)=nsteps(i-1)\n enddo\n endif\n d=zero\n do i=1,n\n d=d+g0(i)*g0(i)\n enddo\n d=dsqrt(d)\n nsteps(1)=dx/(dabs(h)*d)\n kk=zero\n d=zero\n do i=1,kg\n dd=dble(kg-i+1)\n d=d+dd\n kk=kk+nsteps(i)*dd\n enddo\n kk=kk/d\n if (kk > des) then\n if (kg == 1) then\n h=h*(kk-des+one)\n else\n h=h*dsqrt(kk-des+one)\n endif\n else if (kk < des) then\n h=h*dsqrt(kk/des)\n endif\n\n if (ksm) stepvanish=stepvanish+1\n! ----}\n! COMPUTE THE GRADIENT ----{\n if (app) then\n do j=1,n\n if (g0(j) >= zero) then\n deltax(j)=h1*ddx\n else\n deltax(j)=-h1*ddx\n endif\n enddo\n obj=.true.\n !if (constr) then\n !call apprgrdn()\n !else\n !call apprgrdn()\n !endif\n !options(10)=options(10)+n_float\n else\n call grad(x,g,Qref,n/2,n,Kopt,f_min,f_max)\n options(11)=options(11)+one\n endif\n ng=zero\n do i=1,n\n ng=ng+g(i)*g(i)\n enddo\n ng=dsqrt(ng)\n if (ng >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,'Gradient equals infinity at the starting point.'\n endif\n options(9)=-four\n goto 999\n else if (ng < ZeroGrad) then\n if (dispwarn) then\n print *,'SolvOpt warning:'\n print *,'Gradient is zero, but stopping criteria are not fulfilled.'\n endif\n ng=ZeroGrad\n endif\n! Constraints:\n if (constr) then\n if (.not. FsbPnt) then\n if (ng < 1.d-2*PenCoef) then\n kless=kless+1\n if (kless >= 20) then\n PenCoef=PenCoef/ten\n Reset=.true.\n kless=0\n endif\n else\n kless=0\n endif\n !if (appconstr) then\n !do j=1,n\n !if (x(j) >= zero) then\n !deltax(j)=ddx\n !else\n !deltax(j)=-ddx\n !endif\n !enddo\n !obj=.false.\n !call apprgrdn()\n !options(12)=options(12)+n_float\n if (.not. appconstr) then\n call gradc(x,gc,n/2,n,theta_min,theta_max)\n options(13)=options(13)+one\n endif\n ngc=zero\n do i=1,n\n ngc=ngc+gc(i)*gc(i)\n enddo\n ngc=dsqrt(ngc)\n if (ngc >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,' < GRADC > returns infinite vector at the point.'\n endif\n options(9)=-six\n goto 999\n else if (ngc < ZeroGrad .and. .not. appconstr) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,' < GRADC > returns zero vector at an infeasible point.'\n endif\n options(9)=-six\n goto 999\n endif\n do i=1,n\n g(i)=g(i)+PenCoef*gc(i)\n enddo\n ng=zero\n do i=1,n\n ng=ng+g(i)*g(i)\n enddo\n ng=dsqrt(ng)\n if (Reset) then\n if (dispwarn) then\n print *,'SolvOpt warning:'\n print *,'Re-setting due to the use of a new penalty coefficient.'\n endif\n h=h1*dx/three\n k=k-1\n nng=ng\n exit\n endif\n endif\n endif\n if (h1*f > h1*frec) then\n frec=f\n do i=1,n\n xrec(i)=x(i)\n grec(i)=g(i)\n enddo\n endif\n! ----}\n if (ng > ZeroGrad) then\n if (knorms < 10) knorms=knorms+1\n if (knorms >= 2) then\n do i=knorms,2,-1\n gnorms(i)=gnorms(i-1)\n enddo\n endif\n gnorms(1)=ng\n nng=one\n do i=1,knorms\n nng=nng*gnorms(i)\n enddo\n nng=nng**(one/dble(knorms))\n endif\n! Norm X:\n nx=zero\n do i=1,n\n nx=nx+x(i)*x(i)\n enddo\n nx=dsqrt(nx)\n\n! DISPLAY THE CURRENT VALUES ----{\n if (k == ld) then\n print *, &\n 'Iteration # ..... function Value ..... ', &\n 'Step Value ..... Gradient Norm'\n print '(5x,i5,7x,g13.5,6x,g13.5,7x,g13.5)', k,f,dx,ng\n ld=k+dispdata\n endif\n!----}\n! CHECK THE STOPPING CRITERIA ----{\n termflag=.true.\n if (constr) then\n if (.not. FsbPnt) termflag=.false.\n endif\n if (kcheck <= 5 .or. kcheck <= 12 .and. ng > one)termflag=.false.\n if (kc >= mxtc .or. knan)termflag=.false.\n! ARGUMENT\n if (termflag) then\n ii=0\n stopping=.true.\n do i=1,n\n if (dabs(x(i)) >= lowxbound) then\n ii=ii+1\n idx(ii)=i\n if (dabs(xopt(i)-x(i)) > options(2)*dabs(x(i))) then\n stopping=.false.\n endif\n endif\n enddo\n if (ii == 0 .or. stopping) then\n stopping=.true.\n termx=termx+1\n d=zero\n do i=1,n\n d=d+(x(i)-xrec(i))**2\n enddo\n d=dsqrt(d)\n! function\n if (dabs(f-frec) > detfr*dabs(f) .and. &\n dabs(f-fopt) <= options(3)*dabs(f) .and. &\n krerun <= 3 .and. .not. constr) then\n stopping=.false.\n if (ii > 0) then\n do i=1,ii\n j=idx(i)\n if (dabs(xrec(j)-x(j)) > detxr*dabs(x(j))) then\n stopping=.true.\n exit\n endif\n enddo\n endif\n if (stopping) then\n if (dispwarn) then\n print *,'SolvOpt warning:'\n print *,'Re-run from recorded point.'\n endif\n ng=zero\n do i=1,n\n x(i)=xrec(i)\n g(i)=grec(i)\n ng=ng+g(i)*g(i)\n enddo\n ng=dsqrt(ng)\n f=frec\n krerun=krerun+1\n h=h1*dmax1(dx,detxr*nx)/dble(krerun)\n warnno=2\n endwarn='Result may not provide the optimum. The function apparently has many extremum points.'\n exit\n else\n h=h*ten\n endif\n else if (dabs(f-frec) > options(3)*dabs(f) .and. &\n d < options(2)*nx .and. constr) then\n continue\n else if (dabs(f-fopt) <= options(3)*dabs(f) .or. &\n dabs(f) <= lowfbound .or. &\n (dabs(f-fopt) <= options(3) .and. &\n termx >= limxterm )) then\n if (stopf) then\n if (dx <= laststep) then\n if (warnno == 1 .and. ng < dsqrt(options(3))) then\n warnno=0\n endif\n if (.not. app) then\n do i=1,n\n if (dabs(g(i)) <= epsnorm2) then\n warnno=3\n endwarn='Result may be inaccurate in the coordinates. The function is flat at the solution.'\n exit\n endif\n enddo\n endif\n if (warnno /= 0) then\n options(9)=-dble(warnno)-ten\n if (dispwarn) then\n print *,'SolvOpt: Termination warning:'\n print *,endwarn\n if (app) print *,'The above warning may be reasoned by inaccurate gradient approximation'\n endif\n else\n options(9)=dble(k)\n!! DK DK if (dispwarn) print *,'SolvOpt: Normal termination.'\n endif\n goto 999\n endif\n else\n stopf=.true.\n endif\n else if (dx < powerm12*dmax1(nx,one) .and. &\n termx >= limxterm ) then\n options(9)=-four-ten\n if (dispwarn) then\n print *,'SolvOpt: Termination warning:'\n print *,'Stopping criteria are not fulfilled. The function is very steep at the solution.'\n if (app) print *,'The above warning may be reasoned by inaccurate gradient approximation'\n f=frec\n do i=1,n\n x(i)=xrec(i)\n enddo\n endif\n goto 999\n endif\n endif\n endif\n! ITERATIONS LIMIT\n if (k == iterlimit) then\n options(9)=-nine\n if (dispwarn) then\n print *,'SolvOpt warning:'\n print *,'Iterations limit exceeded.'\n endif\n goto 999\n endif\n! ----}\n! ZERO GRADIENT ----{\n if (constr) then\n if (ng <= ZeroGrad) then\n if (dispwarn) then\n print *,'SolvOpt: Termination warning:'\n print *,'Gradient is zero, but stopping criteria are not fulfilled.'\n endif\n options(9)=-eight\n goto 999\n endif\n else\n if (ng <= ZeroGrad) then\n nzero=nzero+1\n if (dispwarn) then\n print *,'SolvOpt warning:'\n print *,'Gradient is zero, but stopping criteria are not fulfilled.'\n endif\n if (nzero >= 3) then\n options(9)=-eight\n goto 999\n endif\n do i=1,n\n g0(i)=-h*g0(i)/two\n enddo\n do i=1,10\n do j=1,n\n x(j)=x(j)+g0(j)\n enddo\n call fun(x,f,Qref,n/2,n,Kopt,f_min,f_max)\n options(10)=options(10)+one\n if (dabs(f) >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,'function equals infinity at the point.'\n endif\n options(9)=-three\n goto 999\n endif\n !if (app) then\n !do j=1,n\n !if (g0(j) >= zero) then\n !deltax(j)=h1*ddx\n !else\n !deltax(j)=-h1*ddx\n !endif\n !enddo\n !obj=.true.\n !call apprgrdn()\n !options(10)=options(10)+n_float\n if (.not. app) then\n call grad(x,g,Qref,n/2,n,Kopt,f_min,f_max)\n options(11)=options(11)+one\n endif\n ng=zero\n do j=1,n\n ng=ng+g(j)*g(j)\n enddo\n ng=dsqrt(ng)\n if (ng >= infty) then\n if (dispwarn) then\n print *,'SolvOpt error:'\n print *,'Gradient equals infinity at the starting point.'\n endif\n options(9)=-four\n goto 999\n endif\n if (ng > ZeroGrad) exit\n enddo\n if (ng <= ZeroGrad) then\n if (dispwarn) then\n print *,'SolvOpt: Termination warning:'\n print *,'Gradient is zero, but stopping criteria are not fulfilled.'\n endif\n options(9)=-eight\n goto 999\n endif\n h=h1*dx\n exit\n endif\n endif\n! ----}\n! function IS FLAT AT THE POINT ----{\n if (.not. constr .and. &\n dabs(f-fopt) < dabs(fopt)*options(3) .and. &\n kcheck > 5 .and. ng < one ) then\n\n ni=0\n do i=1,n\n if (dabs(g(i)) <= epsnorm2) then\n ni=ni+1\n idx(ni)=i\n endif\n enddo\n if (ni >= 1 .and. ni <= n/2 .and. kflat <= 3) then\n kflat=kflat+1\n if (dispwarn) then\n print *,'SolvOpt warning:'\n print *,'The function is flat in certain directions.'\n endif\n warnno=1\n endwarn='Premature stop is possible. Try to re-run the routine from the obtained point.'\n do i=1,n\n x1(i)=x(i)\n enddo\n fm=f\n do i=1,ni\n j=idx(i)\n f2=fm\n y=x(j)\n if (y == zero) then\n x1(j)=one\n else if (dabs(y) < one) then\n x1(j)=dsign(one,y)\n else\n x1(j)=y\n endif\n do ip=1,20\n x1(j)=x1(j)/1.15d0\n call fun(x1,f1,Qref,n/2,n,Kopt,f_min,f_max)\n options(10)=options(10)+one\n if (dabs(f1) < infty) then\n if (h1*f1 > h1*fm) then\n y=x1(j)\n fm=f1\n else if (h1*f2 > h1*f1) then\n exit\n else if (f2 == f1) then\n x1(j)=x1(j)/1.5d0\n endif\n f2=f1\n endif\n enddo\n x1(j)=y\n enddo\n if (h1*fm > h1*f) then\n !if (app) then\n !do j=1,n\n !deltax(j)=h1*ddx\n !enddo\n !obj=.true.\n !call apprgrdn()\n !options(10)=options(10)+n_float\n if (.not. app) then\n call grad(x1,gt,Qref,n/2,n,Kopt,f_min,f_max)\n options(11)=options(11)+one\n endif\n ngt=zero\n do i=1,n\n ngt=ngt+gt(i)*gt(i)\n enddo\n if (ngt > epsnorm2 .and. ngt < infty) then\n if (dispwarn) print *,'Trying to recover by shifting insensitive variables.'\n do i=1,n\n x(i)=x1(i)\n g(i)=gt(i)\n enddo\n ng=ngt\n f=fm\n h=h1*dx/three\n options(3)=options(3)/five\n exit\n endif !! regular gradient\n endif !! a better value has been found\n endif !! function is flat\n endif !! pre-conditions are fulfilled\n! ----}\n enddo !! iterations\n enddo !! restart\n\n999 continue\n\n! deallocate working arrays:\n deallocate (idx,deltax,xx,grec,xrec,xopt,x1,z,gc,gt,g1,g0,g,B)\n\nend subroutine solvopt\n\nsubroutine soptions(default)\n! SOPTIONS returns the default values for the optional parameters\n! used by SolvOpt.\n\n implicit none\n\n double precision default(13)\n\n default(1) = -1.d0\n default(2) = 1.d-4\n default(3) = 1.d-6\n default(4) = 15.d3\n default(5) = 0.d0\n default(6) = 1.d-8\n default(7) = 2.5d0\n default(8) = 1.d-12\n default(9) = 0.d0\n default(10) = 0.d0\n default(11) = 0.d0\n default(12) = 0.d0\n default(13) = 0.d0\n\nend subroutine soptions\n\nsubroutine func_objective(x,res,freq,Qref,N,Nopt)\n\n implicit none\n\n integer, intent(in) :: N,Nopt\n double precision, intent(in) :: freq,Qref\n double precision, intent(out) :: res\n double precision, dimension(1:Nopt), intent(in) :: x\n\n integer i\n double precision num,deno\n\n res = 0.d0\n do i=1,N\n num = x(N+i)*x(N+i)*freq*Qref*(x(i)*x(i) - freq/qref)\n deno = (x(i) ** 4.) + freq*freq\n res = res + num/deno\n enddo\n\nend subroutine func_objective\n\nsubroutine func_mini(x,res,Qref,N,Nopt,K,f_min,f_max)\n\n! Nopt=2*N : nombre de coefficients a optimiser\n\n implicit none\n\n! pi\n double precision, parameter :: PI = 3.141592653589793d0\n double precision, parameter :: TWO_PI = 2.d0 * PI\n\n integer, intent(in) :: N,Nopt,K\n double precision, intent(in) :: Qref,f_min,f_max\n double precision, intent(out) :: res\n double precision, dimension(1:Nopt), intent(in) :: x\n\n integer i\n double precision d,freq,aux\n\n res = 0.\n do i=1,K\n freq = TWO_PI * f_min*((f_max/f_min)**((i-1.)/(K-1.)))\n call func_objective(x,aux,freq,Qref,N,Nopt)\n d = aux - 1.\n res = res + d*d\n enddo\n\nend subroutine func_mini\n\nsubroutine grad_func_mini(x,grad,Qref,N,Nopt,K,f_min,f_max)\n\n implicit none\n\n! pi\n double precision, parameter :: PI = 3.141592653589793d0\n double precision, parameter :: TWO_PI = 2.d0 * PI\n\n integer, intent(in) :: N,Nopt,K\n double precision, intent(in) :: Qref,f_min,f_max\n double precision, dimension(1:Nopt), intent(in) :: x\n double precision, dimension(1:Nopt), intent(out) :: grad\n\n integer i,l\n double precision R,temp0,temp1,temp2,temp3,tamp,aux1,aux2,aux3,aux4\n double precision, dimension(1:N) :: point,poids\n double precision, dimension(1:K) :: freq\n\n do i=1,K\n freq(i) = TWO_PI * f_min*((f_max/f_min)**((i-1.)/(K-1.)))\n enddo\n\n do l=1,N\n point(l) = x(l)\n poids(l) = x(N+l)\n enddo\n\n do l=1,N\n grad(l) = 0.\n grad(N+l) = 0.\n\n do i=1,K\n call func_objective(x,R,freq(i),Qref,N,Nopt)\n temp3 = R - 1.\n temp0 = freq(i)*Qref\n\n !derivee par rapport aux poids\n temp1 = temp0*(point(l)*point(l) - freq(i)/qref)\n temp1 = temp1*2.*poids(l)\n temp2 = (point(l)**4.) + freq(i)*freq(i)\n temp1 = temp1/temp2\n tamp = 2.*temp3*temp1\n grad(N+l) = grad(N+l) + tamp\n\n !derivee par rapport aux points\n aux1 = -2.*(point(l)**5.) + 2.*point(l)*freq(i)*freq(i) + 4.*(point(l)**3.)*freq(i)/Qref\n aux3 = temp2*temp2\n aux4 = aux1/aux3\n aux4 = aux4*temp0\n aux2 = aux4*poids(l)*poids(l)\n tamp = 2.*temp3*aux2\n grad(l) = grad(l) + tamp\n enddo\n enddo\n\nend subroutine grad_func_mini\n\nsubroutine max_residu(x,res,N,Nopt,theta_min,theta_max)\n\n implicit none\n\n integer, intent(in) :: N,Nopt\n double precision, intent(in) :: theta_min,theta_max\n double precision, intent(out) :: res\n double precision, dimension(1:Nopt), intent(in) :: x\n\n integer l\n double precision temp,aux\n\n temp = 0.d0\n res = 0.d0\n\n do l=1,N\n aux = res\n temp = max(0.d0,x(l)*x(l)-(theta_max-theta_min))\n res = max(temp,aux)\n enddo\n\nend subroutine max_residu\n\nsubroutine grad_max_residu(x,grad,N,Nopt,theta_min,theta_max)\n\n implicit none\n\n integer, intent(in) :: N,Nopt\n double precision, intent(in) :: theta_min,theta_max\n double precision, dimension(1:Nopt), intent(in) :: x\n double precision, dimension(1:Nopt), intent(out) :: grad\n\n integer l,l0\n double precision temp,res,aux,temp2\n double precision, dimension(1:N) :: point\n\n temp = 0.d0\n res = 0.d0\n\n do l=1,N\n point(l) = x(l)\n enddo\n\n l0 = 1\n do l=1,N\n aux = res\n temp = max(0.d0,point(l)*point(l) - (theta_max-theta_min))\n res = max(temp,aux)\n if (temp > aux) then\n l0 = l\n endif\n enddo\n\n do l=1,N\n grad(N+l) = 0.d0\n if (l /= l0) then\n grad(l) = 0.d0\n else\n call max_residu(x,temp2,N,Nopt,theta_min,theta_max)\n if (temp2 == 0.d0) then\n grad(l0) = 0.d0\n else\n grad(l0) = 2.d0*point(l0)\n endif\n endif\n enddo\n\nend subroutine grad_max_residu\n\nsubroutine nonlinear_optimization(N,Qref,f0,point,poids,f_min,f_max)\n\n implicit none\n\n! pi\n double precision, parameter :: PI = 3.141592653589793d0\n double precision, parameter :: TWO_PI = 2.d0 * PI\n\n integer, intent(in) :: N\n double precision, intent(in) :: Qref,f0,f_min,f_max\n double precision, dimension(1:N), intent(out) :: point,poids\n\n external func_mini,grad_func_mini,max_residu,grad_max_residu\n\n integer K,i\n logical flg,flfc,flgc\n double precision theta_min,theta_max,res\n double precision, dimension(1:2*N) :: x\n double precision, dimension(1:13) :: options\n\n flg = .true.\n flgc = .true.\n flfc = .true.\n\n K = 4*N\n theta_min = TWO_PI*0.d0\n theta_max = TWO_PI*100.d0*f0\n\n ! this is used as a first guess\n call classical_linear_least_squares(Qref,poids,point,N,f_min,f_max)\n\n ! what follows is the nonlinear optimization part\n\n do i=1,N\n x(i) = sqrt(abs(point(i)) - theta_min)\n x(N+i) = sqrt(abs(poids(i)))\n enddo\n\n call soptions(options)\n call solvopt(2*N,x,res,func_mini,flg,grad_func_mini,options,flfc, &\n max_residu,flgc,grad_max_residu,Qref,K,theta_min,theta_max,f_min,f_max)\n\n do i=1,N\n point(i) = theta_min + x(i)*x(i)\n poids(i) = x(N+i)*x(N+i)\n enddo\n\nend subroutine nonlinear_optimization\n\n" }, { "path": "conversion_between_Qp_Qs_and_Qkappa_Qmu_from_Dahlen_Tromp_959_960_in_3D_and_in_2D_plane_strain.f90", "content": "\n program conversion\n\n! Dimitri Komatitsch, CNRS Marseille, France, July 2018\n\n! see formulas 9.59 and 9.60 in the book of Dahlen and Tromp, 1998\n! (in that book, P is called alpha and S is called beta).\n! See also file formulas_to_convert_between_Qkappa_Qmu_and_Qp_Qs_in_3D_and_in_2D_plane_strain.pdf in this directory.\n\n implicit none\n\n integer :: iconversion_type\n integer :: idimension\n\n double precision :: Qkappa,Qmu,Qp,Qs,cp,cs\n double precision :: inverse_of_Qp,inverse_of_Qmu,inverse_of_Qkappa,COEFFICIENT\n\n print *,'1 = you want to perform the conversion in 3D'\n print *,'2 = you want to perform the conversion in 2D plane strain'\n read(*,*) idimension\n if (idimension < 1 .or. idimension > 2) stop 'error: incorrect value of idimension'\n if (idimension == 1) then\n COEFFICIENT = 4.d0 / 3.d0\n else\n COEFFICIENT = 1.d0\n endif\n print *\n\n print *,'1 = you want to convert from (Qp,Qs) to (QKappa,Qmu)'\n print *,'2 = you want to convert from (QKappa,Qmu) to (Qp,Qs)'\n read(*,*) iconversion_type\n if (iconversion_type < 1 .or. iconversion_type > 2) stop 'error: incorrect value of iconversion_type'\n print *\n\n! get the input values from the user\n if (iconversion_type == 1) then\n print *,'enter Qp:'\n read(*,*) Qp\n print *,'enter Qs:'\n read(*,*) Qs\n print *\n else\n print *,'enter QKappa:'\n read(*,*) QKappa\n print *,'enter Qmu:'\n read(*,*) Qmu\n print *\n endif\n\n! enter the cp and cs velocities of the medium, at the frequency at which you want this conversion to be performed\n print *,'enter the cp and cs velocities of the medium, at the frequency at which you want this conversion to be performed:'\n print *,'enter cp:'\n read(*,*) cp\n print *,'enter cs:'\n read(*,*) cs\n print *\n\n if (iconversion_type == 1) then\n\n! Qmu is always the same as Qs\n Qmu = Qs\n\n! for QKappa the formula is more complex\n inverse_of_Qp = 1.d0 / Qp\n inverse_of_Qmu = 1.d0 / Qmu\n\n inverse_of_Qkappa = (inverse_of_Qp - COEFFICIENT*(cs**2)/(cp**2) * inverse_of_Qmu) / (1.d0 - COEFFICIENT*(cs**2)/(cp**2))\n\n Qkappa = 1.d0/inverse_of_Qkappa\n\n! print the result\n print *,'Qkappa = ',Qkappa\n print *,'Qmu = ',Qmu\n\n else ! if (iconversion_type == 2) then\n\n! Qs is always the same as Qmu\n Qs = Qmu\n\n! for Qp the formula is more complex\n inverse_of_Qp = (1.d0 - COEFFICIENT*(cs**2)/(cp**2))/Qkappa + COEFFICIENT*(cs**2)/(cp**2)/Qmu\n Qp = 1.d0/inverse_of_Qp\n\n! print the result\n print *,'Qp = ',Qp\n print *,'Qs = ',Qs\n\n endif\n\n end program conversion\n\n" }, { "path": "email_from_Youshan_Liu_about_bug_in_the_original_fourth_order_Runge_Kutta_scheme.txt", "content": "\nSubject: some questions about your CPML code\nFrom: ysliu\nDate: 08/03/2015 05:22 AM\nTo: komatitsch\n\nDear Prof. Komatitsch,\n\n\n Please allow me to introduce myself. My name is Youshan Liu,\n and I am a doctor student at Institute of Geology and Geophysics of Chinese Academy of Sciences.\n\n Ocassionally, I read your code of CPML software package (seismic_ADEPML_2D_elastic_RK4_eighth_order).\n\n Unfortunately, I found that your code with Runge-Kutta scheme may be not correct.\n\n For ordinary equation:\n\n y'(x) = f(x,y).\n\n The Runge-Kutta integration include the following four steps:\n\n y_n+1 = y_n + h/6*( K_1 + 2*K_2 + 2*K_3 + K_4)\n\n K_1 = f(x_n, y_n)\n\n K_2 = f(x_n + h/2, y_n + h/2*K_1)\n\n K_3 = f(x_n + h/2, y_n + h/2*K_2)\n\n K_4 = f(x_n + h , y_n + h*K_3)\n\n 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).\n\n Although you defined the coefficient of the Runge-Kutta stored in array rk42, you never use them.\n\n I have modified your code, and I send you.\n\n I think that your code may be not correct !\n\n I run the your code and your code modified by me with the identical parameters.\n\n Your results may be not correct.\n\n 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.\n\n The results have been uploaded in attachment. The su format files can be opened by Fimage.exe.\n\n In addition, your code titled by seismic_ADEPML_2D_viscoelastic_RK4_eighth_order may be also not correct.\n\n\n I also improve the code to save much more memory.\n\n I think the arrays of memory_dvx_dx, etc. can be allocated only in two dimension.\n\n I have try them again.\n\n It still work. Unfortunately, I check the original code several times. I found that it may be incorrect.\n\n The original coed can not work with the time interval of 3 ms.\n\n The modified code can work with the time interval of 3 ms.\n\n\n Best wishes,\n\n Youshan LiuS\n\n\nAttachments:\nelastic_rk4.zip 5.0 MB\n" }, { "path": "plotall_fit_is_perfect_for_viscoelastic_fourth_order.gnu", "content": "\n# this is a comparison of the results of seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic.f90\n# 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\n\nset term x11\n\nset xrange [0:1.2]\n\nplot \"Vx_file_001.dat\" w l lc 1, \"Vx_time_analytical_solution_viscoelastic.dat\" w l lc 3\npause -1 \"Hit any key...\"\n\nplot \"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\npause -1 \"Hit any key...\"\n\n" }, { "path": "seismic_ADEPML_2D_elastic_RK4_eighth_order.f90", "content": "!\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributors: Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr\n! and Youshan Liu, China.\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional isotropic elastic wave equation\n! using a finite-difference method with Auxiliary Differential\n! Equation Perfectly Matched Layer (ADE-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\nprogram seismic_ADEPML_2D_elastic_RK4_eighth_order\n\n! High order 2D explicit-semi implicit-implicit elastic finite-difference code\n! in velocity and stress formulation with Auxiliary Differential\n! Equation Perfectly Matched Layer (ADE-PML) absorbing conditions for\n! an isotropic elastic medium. It is fourth order Runge-Kutta (RK4) in time\n! and 8th order in space using Holberg spatial discretization.\n\n! Version 1.1.3\n! by Roland Martin, University of Pau, France, Jan 2010\n! with a major bug fix in the Runge-Kutta implementation\n! and also significant memory usage optimization by Youshan Liu, China, August 2015.\n! based on seismic_CPML_2D_isotropic_second_order.f90\n! by Dimitri Komatitsch and Roland Martin, University of Pau, France, 2007.\n\n! The 8th-order staggered-grid formulation of Holberg is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n!\n\n! The ADE-PML implementation is based in part on formulas given in Roden and Gedney (2010)\n!\n! If you use this code for your own research, please cite some (or all) of these articles:\n!\n! @ARTICLE{MaKoGeBr10,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney and Emilien Bruthiaux},\n! title = {A high-order time and space formulation of the unsplit perfectly matched layer\n! for the seismic wave equation using {Auxiliary Differential Equations (ADE-PML)}},\n! journal = {Comput. Model. Eng. Sci.},\n! year = {2010},\n! volume = {56},\n! pages = {17-42},\n! number = {1}}\n!\n! @ARTICLE{MaCo10,\n! author = {Roland Martin and Carlos Couder-Casta{\\~n}eda},\n! title = {An improved unsplit and convolutional Perfectly Matched Layer\n! absorbing technique for the Navier-Stokes equations using cut-off frequency shift},\n! journal = {Comput. Model. Eng. Sci.},\n! pages ={47-77}\n! year = {2010},\n! volume = {63},\n! number = {1}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdelaaziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\nimplicit none\n\n! total number of grid points in each direction of the grid\n!integer, parameter :: NX = 101\n!integer, parameter :: NY = 641\ninteger, parameter :: NX = 241\ninteger, parameter :: NY = 241\n\n! Explicit (epsn=1,epsn=0), implicit (epsn=0,epsn1=1), semi-implicit (epsn=0.5,epsn1=0.5)\ninteger, parameter :: iexpl=0\ninteger, parameter :: iimpl=0\ninteger, parameter :: isemiimpl=1\n\ndouble precision :: epsn,epsn1\n\n! size of a grid cell\ndouble precision, parameter :: DELTAX = 10.d0\ndouble precision, parameter :: DELTAY = DELTAX\n\n! flags to add PML layers to the edges of the grid\nlogical, parameter :: USE_PML_XMIN = .true.\nlogical, parameter :: USE_PML_XMAX = .true.\nlogical, parameter :: USE_PML_YMIN = .true.\nlogical, parameter :: USE_PML_YMAX = .true.\n\n! thickness of the PML layer in grid points. 8th order in space imposes to\n! increase the thickness of the CPML\ninteger, parameter :: NPOINTS_PML = 10\n\n! P-velocity, S-velocity and density\ndouble precision, parameter :: cp = 2000.d0\ndouble precision, parameter :: cs = 1150.d0\ndouble precision, parameter :: density = 2000.d0\n!double precision, parameter :: cp = 3300.d0\n!double precision, parameter :: cs = 1905.d0\n!double precision, parameter :: density = 2800.d0\n\n! total number of time steps\n! the time step is twice smaller for this fourth-order simulation,\n! therefore let us double the number of time steps to keep the same total duration\ninteger, parameter :: NSTEP = 2501\n\n! time step in seconds\n! 8th-order in space and 4th-order in time finite-difference schemes\n! are less stable than second-order in space and second-order in time,\n! therefore let us divide the time step by 2\ndouble precision, parameter :: DELTAT = 3.d-3\n\n! parameters for the source\ndouble precision, parameter :: f0 = 10.d0\ndouble precision, parameter :: t0 = 1.0d0 / f0\ndouble precision, parameter :: factor = 1.d4\n\n! source\n!integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1\ninteger, parameter :: ISOURCE = (NX-1)/2\ninteger, parameter :: JSOURCE = (NY-1)/2\ndouble precision, parameter :: xsource = (ISOURCE - 1) * DELTAX\ndouble precision, parameter :: ysource = (JSOURCE - 1) * DELTAY\n! angle of source force clockwise with respect to vertical (Y) axis\n!double precision, parameter :: ANGLE_FORCE = 135.d0\ndouble precision, parameter :: ANGLE_FORCE = 90.d0\n\n! receivers\n!integer, parameter :: NREC = 3\n!double precision, parameter :: xdeb = xsource ! first receiver x in meters\n!double precision, parameter :: ydeb = ysource - 2000.d0 ! first receiver y in meters\n!double precision, parameter :: xfin = xsource ! last receiver x in meters\n!double precision, parameter :: yfin = ysource - 4000.d0 ! last receiver y in meters\ninteger, parameter :: NREC = NX\ndouble precision, parameter :: xdeb = 0.d0 ! first receiver x in meters\ndouble precision, parameter :: ydeb = 50.d0 ! first receiver y in meters\ndouble precision, parameter :: xfin = (NX-1)*DELTAX ! last receiver x in meters\ndouble precision, parameter :: yfin = 50.d0 ! last receiver y in meters\n\n! display information on the screen from time to time\n! the time step is twice smaller for this fourth-order simulation,\n! therefore let us double the interval in time steps at which we display information\ninteger, parameter :: IT_DISPLAY = 200\n! value of PI\ndouble precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\ndouble precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\ndouble precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\ndouble precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\ndouble precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! Holberg (1987) coefficients, taken from\n! @ARTICLE{Hol87,\n! author = {O. Holberg},\n! title = {Computational aspects of the choice of operator and sampling interval\n! for numerical differentiation in large-scale simulation of wave phenomena},\n! journal = {Geophysical Prospecting},\n! year = {1987},\n! volume = {35},\n! pages = {629-655}}\ndouble precision, parameter :: c1 = 1.231666d0\ndouble precision, parameter :: c2 = -1.041182d-1\ndouble precision, parameter :: c3 = 2.063707d-2\ndouble precision, parameter :: c4 = -3.570998d-3\n\n! RK4 scheme coefficients, 2 per subloop, 8 in total\ndouble precision, dimension(4) :: rk41, rk42\n\n! main arrays\ndouble precision, dimension(-4:NX+4,-4:NY+4) :: lambda,mu,rho,vx,vy,sigmaxx,sigmayy,sigmaxy\n\n! variables are stored in four indices in the first dimension to implement RK4\n! dv does not always indicate a derivative\ndouble precision, dimension(3,-4:NX+4,-4:NY+4) :: dvx,dvy,dsigmaxx,dsigmayy,dsigmaxy\n\n! to interpolate material parameters at the right location in the staggered grid cell\ndouble precision lambda_half_x,mu_half_x,lambda_plus_two_mu_half_x,mu_half_y,rho_half_x_half_y\n\n! for evolution of total energy in the medium\ndouble precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n\n! power to compute d0 profile\ndouble precision, parameter :: NPOWER = 2.d0\ndouble precision, parameter :: NPOWER2 = 2.d0\n\n! Kappa must be strong enough to absorb energy and low enough to avoid\n! reflections.\n! Alpha1 must be low to absorb energy and high enough to have efficiency on\n! grazing incident waves.\ndouble precision, parameter :: K_MAX_PML = 7.d0\ndouble precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0)\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n!!! Youshan Liu suppressed the two comment lines below\n!!!!!! not true anymore: We have as many memory variables as the number of frequency shift poles in the CPML\n!!!!!! not true anymore: Indices are 1 and 2 for the 2 frequency shift poles\n! ==================== revised by Youshan Liu ==================\ndouble precision, dimension(-4:NX+4,-4:NY+4) :: memory_dvx_dx, memory_dvx_dy, memory_dvy_dx, memory_dvy_dy, &\n memory_dsigmaxx_dx, memory_dsigmayy_dy, &\n memory_dsigmaxy_dx, memory_dsigmaxy_dy\n\ndouble precision :: value_dvx_dx, value_dvx_dy, value_dvy_dx, value_dvy_dy, &\n value_dsigmaxx_dx, value_dsigmayy_dy, &\n value_dsigmaxy_dx, value_dsigmaxy_dy\n\n! 1D arrays for the damping profiles\ndouble precision, dimension(-4:NX+4) :: d_x,K_x,alpha_x,g_x,ksi_x\ndouble precision, dimension(-4:NX+4) :: d_x_half,K_x_half,alpha_x_half,g_x_half,ksi_x_half\ndouble precision, dimension(-4:NY+4) :: d_y,K_y,alpha_y,g_y,ksi_y\ndouble precision, dimension(-4:NY+4) :: d_y_half,K_y_half,alpha_y_half,g_y_half,ksi_y_half\n\n! coefficients that allow to reset the memory variables at each RK4 substep depend on the substepping and are then of dimension 4,\n! 1D arrays for the damping profiles\ndouble precision, dimension(4,-4:NX+4) :: a_x,b_x\ndouble precision, dimension(4,-4:NX+4) :: a_x_half,b_x_half\ndouble precision, dimension(4,-4:NY+4) :: a_y,b_y\ndouble precision, dimension(4,-4:NY+4) :: a_y_half,b_y_half\n\n\ndouble precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\ndouble precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n! for the source\ndouble precision :: a,t,force_x,force_y,source_term\n\n! for receivers\ndouble precision xspacerec,yspacerec,distval,dist\ninteger, dimension(NREC) :: ix_rec,iy_rec\ndouble precision, dimension(NREC) :: xrec,yrec\n\n! for seismograms\ndouble precision, dimension(NSTEP,NREC) :: sisvx,sisvy\n\ninteger :: i,j,k,it,irec,inc\n\ndouble precision :: Courant_number\n\n!define by ysliu 8/2/2015\ninteger(2) head(1:120)\n\ncharacter(80) :: routine\nreal,dimension(NSTEP,NREC) :: seisvx, seisvy\nreal,dimension(NX,NY) :: snapvx,snapvy\n\n!---\n!--- program starts here\n!---\n\nif (iexpl == 1) then\n epsn = 1.d0\n epsn1 = 0.d0\nendif\n\nif (iimpl == 1) then\n epsn = 0.d0\n epsn1 = 1.d0\nendif\n\nif (isemiimpl == 1) then\n epsn = 0.5d0\n epsn1 = 0.5d0\nendif\n\nprint *\nprint *,'2D elastic finite-difference code in velocity and stress formulation with C-PML'\nprint *\n\n! display size of the model\nprint *\nprint *,'NX = ',NX\nprint *,'NY = ',NY\nprint *\nprint *,'size of the model along X = ',(NX - 1) * DELTAX\nprint *,'size of the model along Y = ',(NY - 1) * DELTAY\nprint *\nprint *,'Total number of grid points = ',NX * NY\nprint *\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\nthickness_PML_x = NPOINTS_PML * DELTAX\nthickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\nRcoef = 0.00001d0\n\n! check that NPOWER is okay\nif (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\nd0_x = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_x)\nd0_y = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_y)\n\nprint *,'d0_x = ',d0_x\nprint *,'d0_y = ',d0_y\nprint *\n\n! parameters involved in RK4 time expansion\nrk41(1) = ZERO\nrk41(2) = 0.5d0\nrk41(3) = 0.5d0\nrk41(4) = 1.d0\n\nrk42(1) = 1.d0 / 6.d0\nrk42(2) = 2.d0 / 6.d0\nrk42(3) = 2.d0 / 6.d0\nrk42(4) = 1.d0 / 6.d0\n\nksi_x(:) = ZERO\nksi_x_half(:) = ZERO\nd_x(:) = ZERO\nd_x_half(:) = ZERO\nK_x(:) = 1.d0\nK_x_half(:) = 1.d0\nalpha_x(:) = ZERO\nalpha_x_half(:) = ZERO\na_x(:,:) = ZERO\na_x_half(:,:) = ZERO\ng_x(:) = 5.d-1\ng_x_half(:) = 5.d-1\n\nksi_y(:) = ZERO\nksi_y_half(:) = ZERO\nd_y(:) = ZERO\nd_y_half(:) = ZERO\nK_y(:) = 1.d0\nK_y_half(:) = 1.d0\nalpha_y(:) = ZERO\nalpha_y_half(:) = ZERO\na_y(:,:) = ZERO\na_y_half(:,:) = ZERO\ng_y(:) = 1.d0\ng_y_half(:) = 1.d0\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\nxoriginleft = thickness_PML_x\nxoriginright = (NX-1)*DELTAX - thickness_PML_x\n\ndo i = -4,NX+4\n\n ! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n !---------- left edge\n if (USE_PML_XMIN) then\n\n ! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n ! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n !---------- right edge\n if (USE_PML_XMAX) then\n\n ! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n ! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n ! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n ! CPML damping parameters for the 4 sub time steps of RK4 algorithm\n do inc=1,4\n b_x(inc,i) = (1.-epsn*DELTAT*rk41(inc)*(d_x(i)/K_x(i) + alpha_x(i)))/ &\n (1.+epsn1*DELTAT*rk41(inc)*(d_x(i)/K_x(i) + alpha_x(i)))\n b_x_half(inc,i) = (1.-epsn*DELTAT*rk41(inc)*(d_x_half(i)/K_x_half(i) &\n + alpha_x_half(i)))/(1. +epsn1*DELTAT*rk41(inc)*(d_x_half(i)/K_x_half(i) &\n + alpha_x_half(i)))\n\n ! this to avoid division by zero outside the PML\n if (abs(d_x(i)) > 1.d-6) a_x(inc,i) = - DELTAT*rk41(inc)*d_x(i) / (K_x(i)* K_x(i))/&\n (1. +epsn1*DELTAT*rk41(inc)*(d_x(i)/K_x(i) + alpha_x(i)))\n\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(inc,i) =-DELTAT*rk41(inc)*d_x_half(i)/&\n (K_x_half(i)*K_x_half(i) )/&\n (1. +epsn1*DELTAT*rk41(inc)*(d_x_half(i)/K_x_half(i)&\n + alpha_x_half(i)))\n\n enddo\n\nenddo !do i = -4,NX+4\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\nyoriginbottom = thickness_PML_y\nyorigintop = (NY-1)*DELTAY - thickness_PML_y\n\ndo j = -4,NY+4\n\n ! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n !---------- bottom edge\n if (USE_PML_YMIN) then\n\n ! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n ! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n !---------- top edge\n if (USE_PML_YMAX) then\n\n ! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n ! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n ! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER2\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n ! just in case, for -5 at the end\n if (alpha_y(j) < ZERO) alpha_y(j) = ZERO\n if (alpha_y_half(j) < ZERO) alpha_y_half(j) = ZERO\n\n ! CPML damping parameters for the 4 sub time steps of RK4 algorithm\n do inc=1,4\n b_y(inc,j) = (1.-epsn*DELTAT*rk41(inc)*(d_y(j)/K_y(j) + alpha_y(j)))/ &\n (1.+epsn1*DELTAT*rk41(inc)*(d_y(j)/K_y(j) + alpha_y(j)))\n b_y_half(inc,j) = (1.-epsn*DELTAT*rk41(inc)*(d_y_half(j)/K_y_half(j) + &\n alpha_y_half(j)))/(1.+epsn1*DELTAT*rk41(inc)*(d_y_half(j)/K_y_half(j) &\n + alpha_y_half(j)))\n\n ! this to avoid division by zero outside the PML\n if (abs(d_y(j)) > 1.d-6) a_y(inc,j) = - DELTAT*rk41(inc)*d_y(j) &\n / (K_y(j)* K_y(j))/&\n (1.+epsn1*DELTAT*rk41(inc)*(d_y(j)/K_y(j) + alpha_y(j)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(inc,j) = -DELTAT*rk41(inc)*d_y_half(j) /&\n (K_y_half(j) * K_y_half(j) )/&\n (1.+epsn1*DELTAT*rk41(inc)*(d_y_half(j)/K_y_half(j) + alpha_y_half(j)))\n enddo\n\nenddo !do j = -4,NY+4\n\n! compute the Lame parameters and density\ndo j = -4,NY+4\n do i = -4,NX+4\n rho(i,j) = density\n mu(i,j) = density*cs*cs\n lambda(i,j) = density*(cp*cp - 2.d0*cs*cs)\n enddo\nenddo\n\n! print position of the source\nprint *,'Position of the source:'\nprint *\nprint *,'x = ',xsource\nprint *,'y = ',ysource\nprint *\n\n! define location of receivers\nprint *,'There are ',nrec,' receivers'\nprint *\nxspacerec = (xfin-xdeb) / dble(NREC-1)\nyspacerec = (yfin-ydeb) / dble(NREC-1)\ndo irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\nenddo\n\n! find closest grid point for each receiver\ndo irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\nenddo !do irec=1,nrec\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant and K. O. Friedrichs and H. Lewy (1928)\nCourant_number = cp * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2)\nprint *,'Courant number is ',Courant_number\nprint *\nif (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable'\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')\n\n! initialize arrays\ndvx(:,:,:) = ZERO\ndvy(:,:,:) = ZERO\ndsigmaxx(:,:,:) = ZERO\ndsigmayy(:,:,:) = ZERO\ndsigmaxy(:,:,:) = ZERO\n\nvx(:,:) = ZERO\nvy(:,:) = ZERO\nsigmaxx(:,:) = ZERO\nsigmayy(:,:) = ZERO\nsigmaxy(:,:) = ZERO\n\n! PML\nmemory_dvx_dx(:,:) = ZERO\nmemory_dvx_dy(:,:) = ZERO\nmemory_dvy_dx(:,:) = ZERO\nmemory_dvy_dy(:,:) = ZERO\nmemory_dsigmaxx_dx(:,:) = ZERO\nmemory_dsigmayy_dy(:,:) = ZERO\nmemory_dsigmaxy_dx(:,:) = ZERO\nmemory_dsigmaxy_dy(:,:) = ZERO\n\n! initialize seismograms\nsisvx(:,:) = ZERO\nsisvy(:,:) = ZERO\n\n! initialize total energy\ntotal_energy_kinetic(:) = ZERO\ntotal_energy_potential(:) = ZERO\n\n!---\n!--- beginning of time loop\n!---\n\ndo it = 1,NSTEP\n\n !! v and sigma temporary variables of RK4\n !======================================================\n !====================revised by ysliu==================\n !backup the current snapshots\n dvx(2,:,:) = vx(:,:)\n dvy(2,:,:) = vy(:,:)\n dsigmaxx(2,:,:) = sigmaxx(:,:)\n dsigmayy(2,:,:) = sigmayy(:,:)\n dsigmaxy(2,:,:) = sigmaxy(:,:)\n dvx(3,:,:) = vx(:,:)\n dvy(3,:,:) = vy(:,:)\n dsigmaxx(3,:,:) = sigmaxx(:,:)\n dsigmayy(3,:,:) = sigmayy(:,:)\n dsigmaxy(3,:,:) = sigmaxy(:,:)\n\n !======================================================\n\n ! RK4 loop (loop on the four RK4 substeps)\n do inc= 1,4\n ! ==================== revised by Youshan Liu ==================\n ! The new values of the different variables v and sigma are computed\n dvx(1,:,:) = dvx(3,:,:) + rk41(inc) * dvx(2,:,:) * DELTAT\n dvy(1,:,:) = dvy(3,:,:) + rk41(inc) * dvy(2,:,:) * DELTAT\n dsigmaxx(1,:,:) = dsigmaxx(3,:,:) + rk41(inc) * dsigmaxx(2,:,:) * DELTAT\n dsigmayy(1,:,:) = dsigmayy(3,:,:) + rk41(inc) * dsigmayy(2,:,:) * DELTAT\n dsigmaxy(1,:,:) = dsigmaxy(3,:,:) + rk41(inc) * dsigmaxy(2,:,:) * DELTAT\n\n !------------------\n ! compute velocity\n !------------------\n\n do j = 2,NY\n do i = 2,NX\n\n value_dsigmaxx_dx = ( c1 * (dsigmaxx(1,i,j) - dsigmaxx(1,i-1,j)) + c2 * (dsigmaxx(1,i+1,j) - dsigmaxx(1,i-2,j)) + &\n c3 * (dsigmaxx(1,i+2,j) - dsigmaxx(1,i-3,j)) + c4 * (dsigmaxx(1,i+3,j) - dsigmaxx(1,i-4,j)) )/ DELTAX\n\n value_dsigmaxy_dy = ( c1 * (dsigmaxy(1,i,j) - dsigmaxy(1,i,j-1)) + c2* (dsigmaxy(1,i,j+1) - dsigmaxy(1,i,j-2)) + &\n c3 * (dsigmaxy(1,i,j+2) - dsigmaxy(1,i,j-3)) + c4 * (dsigmaxy(1,i,j+3) - dsigmaxy(1,i,j-4)) )/ DELTAY\n\n if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then\n ! ==================== revised by Youshan Liu ==================\n memory_dsigmaxx_dx(i,j) = b_x(inc,i) * memory_dsigmaxx_dx(i,j) + a_x(inc,i) * value_dsigmaxx_dx\n memory_dsigmaxy_dy(i,j) = b_y(inc,j) * memory_dsigmaxy_dy(i,j) + a_y(inc,j) * value_dsigmaxy_dy\n\n value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j)\n value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j)\n endif\n\n dvx(2,i,j) = (value_dsigmaxx_dx + value_dsigmaxy_dy) / rho(i,j)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n ! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n value_dsigmaxy_dx = ( c1 * (dsigmaxy(1,i+1,j) - dsigmaxy(1,i,j)) + c2 * (dsigmaxy(1,i+2,j) - dsigmaxy(1,i-1,j)) + &\n c3 * (dsigmaxy(1,i+3,j) - dsigmaxy(1,i-2,j)) + c4 * (dsigmaxy(1,i+4,j) - dsigmaxy(1,i-3,j)) )/ DELTAX\n\n value_dsigmayy_dy = ( c1 * (dsigmayy(1,i,j+1) - dsigmayy(1,i,j)) + c2 * (dsigmayy(1,i,j+2) - dsigmayy(1,i,j-1)) + &\n c3 * (dsigmayy(1,i,j+3) - dsigmayy(1,i,j-2)) + c4 * (dsigmayy(1,i,j+4) - dsigmayy(1,i,j-3)) )/ DELTAY\n\n if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then\n ! ==================== revised by Youshan Liu ==================\n memory_dsigmaxy_dx(i,j) = b_x_half(inc,i) * memory_dsigmaxy_dx(i,j) + a_x_half(inc,i) * value_dsigmaxy_dx\n memory_dsigmayy_dy(i,j) = b_y_half(inc,j) * memory_dsigmayy_dy(i,j) + a_y_half(inc,j) * value_dsigmayy_dy\n\n value_dsigmaxy_dx = value_dsigmaxy_dx/K_x_half(i)+memory_dsigmaxy_dx(i,j)\n value_dsigmayy_dy = value_dsigmayy_dy/K_y_half(j)+memory_dsigmayy_dy(i,j)\n endif\n\n dvy(2,i,j) = (value_dsigmaxy_dx + value_dsigmayy_dy) / rho_half_x_half_y\n\n enddo\n enddo\n\n ! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = (dble(it-1)+ rk41(inc)) * DELTAT\n\n ! Gaussian\n ! source_term = factor * exp(-a*(t-t0)**2) !\n\n ! first derivative of a Gaussian\n source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n ! Ricker source time function (second derivative of a Gaussian)\n ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n\n ! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n ! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n dvx(2,i,j) = dvx(2,i,j) + force_x / rho(i,j)\n dvy(2,i,j) = dvy(2,i,j) + force_y / rho_half_x_half_y\n\n ! Dirichlet conditions (rigid boundaries) on all the edges of the grid\n dvx(:,-4:1,:) = ZERO\n dvx(:,NX:NX+4,:) = ZERO\n\n dvx(:,:,-4:1) = ZERO\n dvx(:,:,NY:NY+4) = ZERO\n\n dvy(:,-4:1,:) = ZERO\n dvy(:,NX:NX+4,:) = ZERO\n\n dvy(:,:,-4:1) = ZERO\n dvy(:,:,NY:NY+4) = ZERO\n\n !----------------------\n ! compute stress sigma\n !----------------------\n\n do j = 2,NY\n do i = 1,NX-1\n\n ! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda(i+1,j) + lambda(i,j))\n mu_half_x = 0.5d0 * (mu(i+1,j) + mu(i,j))\n lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x\n\n value_dvx_dx = ( c1 * (dvx(1,i+1,j) - dvx(1,i,j)) + c2 * (dvx(1,i+2,j) - dvx(1,i-1,j)) + &\n c3 * (dvx(1,i+3,j) - dvx(1,i-2,j)) + c4 * (dvx(1,i+4,j) - dvx(1,i-3,j)) )/ DELTAX\n\n value_dvy_dy = ( c1 * (dvy(1,i,j) - dvy(1,i,j-1)) + c2 * (dvy(1,i,j+1) - dvy(1,i,j-2)) + &\n c3 * (dvy(1,i,j+2) - dvy(1,i,j-3)) + c4 * (dvy(1,i,j+3) - dvy(1,i,j-4)) )/ DELTAY\n\n if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then\n ! ==================== revised by Youshan Liu ==================\n memory_dvx_dx(i,j) = b_x_half(inc,i) * memory_dvx_dx(i,j) + a_x_half(inc,i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(inc,j) * memory_dvy_dy(i,j) + a_y(inc,j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j)\n endif\n\n dsigmaxx(2,i,j) = (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy)\n dsigmayy(2,i,j) = (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 2,NX\n\n ! interpolate material parameters at the right location in the staggered grid cell\n mu_half_y = 0.5d0 * (mu(i,j+1) + mu(i,j))\n\n value_dvx_dy = ( c1 * (dvx(1,i,j+1) - dvx(1,i,j)) + c2 * (dvx(1,i,j+2) - dvx(1,i,j-1)) + &\n c3 * (dvx(1,i,j+3) - dvx(1,i,j-2)) + c4 * (dvx(1,i,j+4) - dvx(1,i,j-3)) )/ DELTAY\n value_dvy_dx = ( c1 * (dvy(1,i,j) - dvy(1,i-1,j)) + c2 * (dvy(1,i+1,j) - dvy(1,i-2,j)) + &\n c3 * (dvy(1,i+2,j) - dvy(1,i-3,j)) + c4 * (dvy(1,i+3,j) - dvy(1,i-4,j)) )/ DELTAX\n\n if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then\n ! ==================== revised by Youshan Liu ==================\n memory_dvy_dx(i,j) = b_x(inc,i) * memory_dvy_dx(i,j) + a_x(inc,i) * value_dvy_dx\n memory_dvx_dy(i,j) = b_y_half(inc,j) * memory_dvx_dy(i,j) + a_y_half(inc,j) * value_dvx_dy\n\n value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)\n value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j)\n endif\n\n dsigmaxy(2,i,j) = mu_half_y * (value_dvy_dx + value_dvx_dy)\n\n enddo\n enddo\n\n ! ==================== revised by Youshan Liu ==================\n ! the new values of the different variables v and sigma are computed\n vx(:,:) = vx(:,:) + rk42(inc) * dvx(2,:,:) * DELTAT\n vy(:,:) = vy(:,:) + rk42(inc) * dvy(2,:,:) * DELTAT\n sigmaxx(:,:) = sigmaxx(:,:) + rk42(inc) * dsigmaxx(2,:,:) * DELTAT\n sigmayy(:,:) = sigmayy(:,:) + rk42(inc) * dsigmayy(2,:,:) * DELTAT\n sigmaxy(:,:) = sigmaxy(:,:) + rk42(inc) * dsigmaxy(2,:,:) * DELTAT\n\n !! Dirichlet conditions (rigid boundaries) on all the edges of the grid\n vx(-4:1,:) = ZERO\n vx(:,-4:1) = ZERO\n vy(-4:1,:) = ZERO\n vy(:,-4:1) = ZERO\n\n vx(NX:NX+4,:) = ZERO\n vx(:,NY:NY+4) = ZERO\n vy(NX:NX+4,:) = ZERO\n vy(:,NY:NY+4) = ZERO\n\n enddo\n ! end of RK4 loop\n\n ! store seismograms\n do irec = 1,NREC\n sisvx(it,irec) = (vx(ix_rec(irec),iy_rec(irec))+ &\n vx(ix_rec(irec)+1,iy_rec(irec))+ &\n vx(ix_rec(irec),iy_rec(irec)+1)+ &\n vx(ix_rec(irec)+1,iy_rec(irec)+1))/4.d0\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))\n enddo\n\n !! compute total energy in the medium (without the PML layers)\n !\n !! compute kinetic energy first, defined as 1/2 rho ||v||^2\n !! in principle we should use rho_half_x_half_y instead of rho for vy\n !! in order to interpolate density at the right location in the staggered grid cell\n !! but in a homogeneous medium we can safely ignore it\n ! total_energy_kinetic(it) = 0.5d0 * sum( &\n ! rho(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)*( &\n ! vx(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)**2 + &\n ! vy(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)**2))\n !\n !! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n !! in principle we should interpolate the medium parameters at the right location\n !! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n ! total_energy_potential(it) = ZERO\n ! do j = NPOINTS_PML+1, NY-NPOINTS_PML\n ! do i = NPOINTS_PML+1, NX-NPOINTS_PML\n ! epsilon_xx = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmaxx(i,j) - lambda(i,j) * &\n ! sigmayy(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j)))\n ! epsilon_yy = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmayy(i,j) - lambda(i,j) * &\n ! sigmaxx(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j)))\n ! epsilon_xy = sigmaxy(i,j) / (2.d0 * mu(i,j))\n ! total_energy_potential(it) = total_energy_potential(it) + &\n ! 0.5d0 * (epsilon_xx * sigmaxx(i,j) + epsilon_yy * sigmayy(i,j) + 2.d0 * epsilon_xy * sigmaxy(i,j))\n ! enddo\n ! enddo\n\n if (mod(it,IT_DISPLAY) == 0) then\n write(*,*) it, ' of ', nstep\n head=0\n head(58) = NY\n head(59) = DELTAY * 1E3\n snapvx = vx(1:NX,1:NY)\n snapvy = vy(1:NX,1:NY)\n write(routine,'(a12,i5.5,a9)') './snapshots/',it,'snapVx.su'\n open(21,file=routine,access='stream')\n do j = 1,NX,1\n write(21) head,(real(snapvx(k,j)),k=1,NY)\n enddo\n close(21)\n write(routine,'(a12,i5.5,a9)') './snapshots/',it,'snapVy.su'\n open(21,file=routine,access='stream')\n do j = 1,NX,1\n write(21) head,(real(snapvy(k,j)),k=1,NY)\n enddo\n close(21)\n endif\n\n !! output information\n ! if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n !\n !! print maximum of norm of velocity\n ! velocnorm = maxval(sqrt(vx**2 + vy**2))\n ! print *,'Time step # ',it\n ! print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n ! print *,'Max norm velocity vector V (m/s) = ',velocnorm\n ! print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n ! print *\n !! check stability of the code, exit if unstable\n ! if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n !\n ! call create_color_image(vx(1:NX,1:NY),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n ! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)\n ! call create_color_image(vy(1:NX,1:NY),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n ! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)\n ! open(unit=20,file='energy.dat',status='unknown')\n ! do it2 = 1,NSTEP\n ! write(20,*) sngl(dble(it2-1)*DELTAT),sngl(total_energy_kinetic(it2)), &\n ! sngl(total_energy_potential(it2)),sngl(total_energy_kinetic(it2) + total_energy_potential(it2))\n ! enddo\n ! close(20)\n ! call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n !\n ! endif\n\nenddo ! end of time loop\n\n! save seismograms\n\n!save seismogram in SU format\nwrite(*,*) NREC,nstep\nseisvx = sisvx\nseisvy = sisvy\nhead=0\nhead(58)=nstep\nhead(59)=deltat*1e6\nopen(21,file='./seismograms/seisVx.su',access='stream')\n do j=1,NREC,1\n write(21) head,(real(seisvx(k,j)),k=1,nstep)\n enddo\nclose(21)\nopen(21,file='./seismograms/seisVy.su',access='stream')\n do j=1,NREC,1\n write(21) head,(real(seisvy(k,j)),k=1,nstep)\n enddo\nclose(21)\n!call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n\n!! save total energy\n!open(unit=20,file='energy.dat',status='unknown')\n! do it = 1,NSTEP\n! write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n! sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))\n! enddo\n!close(20)\n\n!! create script for Gnuplot for total energy\n! open(unit=20,file='plot_energy',status='unknown')\n! write(20,*) '# set term x11'\n! write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n! write(20,*)\n! write(20,*) 'set xlabel \"Time (s)\"'\n! write(20,*) 'set ylabel \"Total energy\"'\n! write(20,*)\n! write(20,*) 'set output \"cpml_total_energy_semilog.eps\"'\n! write(20,*) 'set logscale y'\n! write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n! & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n! write(20,*) 'pause -1 \"Hit any key...\"'\n! write(20,*)\n! close(20)\n!\n! open(unit=20,file='plot_comparison',status='unknown')\n! write(20,*) '# set term x11'\n! write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n! write(20,*)\n! write(20,*) 'set xlabel \"Time (s)\"'\n! write(20,*) 'set ylabel \"Total energy\"'\n! write(20,*)\n! write(20,*) 'set output \"compare_total_energy_semilog.eps\"'\n! write(20,*) 'set logscale y'\n! write(20,*) 'plot \"energy.dat\" us 1:4 t ''Total energy CPML'' w l lc 1, &\n! & \"../collino/energy.dat\" us 1:4 t ''Total energy Collino'' w l lc 2'\n! write(20,*) 'pause -1 \"Hit any key...\"'\n! write(20,*)\n! close(20)\n!\n!! create script for Gnuplot\n! open(unit=20,file='plotgnu',status='unknown')\n! write(20,*) 'set term x11'\n! write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n! write(20,*)\n! write(20,*) 'set xlabel \"Time (s)\"'\n! write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n! write(20,*)\n!\n! write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n! write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n! write(20,*) 'pause -1 \"Hit any key...\"'\n! write(20,*)\n!\n! write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n! write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n! write(20,*) 'pause -1 \"Hit any key...\"'\n! write(20,*)\n!\n! write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n! write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n! write(20,*) 'pause -1 \"Hit any key...\"'\n! write(20,*)\n!\n! write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n! write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n! write(20,*) 'pause -1 \"Hit any key...\"'\n! write(20,*)\n!\n! close(20)\n\nprint *\nprint *,'End of the simulation'\nprint *\n\nend program seismic_ADEPML_2D_elastic_RK4_eighth_order\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_ADEPML_2D_viscoelastic_RK4_eighth_order.f90", "content": "!\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributors: Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr\n! and Ruiqi Shi and Youshan Liu, China.\n!\n! RK4 bug detected by Youshan Liu, China fixed by Quentin Brissaud, France and also Caltech (USA) in this version in March 2018.\n!\n! Ruiqi Shi, Department of Exploration Geophysics, China University of Petroleum, Beijing, China.\n! Email: shiruiqi123 AT gmail DOT com\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional viscoelastic wave equation\n! using a finite-difference method with Auxiliary Differential\n! Equation Perfectly Matched Layer (ADE-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\nprogram seismic_ADEPML_2D_viscoelastic_RK4_eighth_order\n\n! High order 2D explicit-semi implicit-implicit viscoelastic finite-difference code\n! in velocity and stress formulation with Auxiliary Differential\n! Equation Perfectly Matched Layer (ADE-PML) absorbing conditions for\n! an SLS viscoelastic medium. It is fourth order Runge-Kutta (RK4) in time\n! and 8th order in space using Holberg spatial discretization.\n\n! Version 1.1.3\n! by Roland Martin, University of Pau, France, Jan 2010\n! with improvements by Ruiqi Shi and\n! with a major bug fix in the Runge-Kutta implementation\n! and also significant memory usage optimization by Youshan Liu, China, August 2015.\n! based on seismic_CPML_2D_isotropic_second_order.f90\n! by Dimitri Komatitsch and Roland Martin, University of Pau, France, 2007.\n\n! *BEWARE* that the attenuation model implemented below is that of J. M. Carcione,\n! Seismic modeling in viscoelastic media, Geophysics, vol. 58(1), p. 110-120 (1993), which is NON causal,\n! i.e., waves speed up instead of slowing down when turning attenuation on.\n! This comes from the fact that in that model the relaxed state at zero frequency is used as a reference instead of\n! the unrelaxed state at infinite frequency. These days a causal model should be used instead,\n! i.e. one using the unrelaxed state at infinite frequency as a reference.\n\n! The 8th-order staggered-grid formulation of Holberg is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n!\n\n! The ADE-PML implementation is based in part on formulas given in Roden and Gedney (2010)\n!\n! If you use this code for your own research, please cite some (or all) of these articles:\n!\n! @Article{BlKoChLoXi15,\n! Title = {Positivity-preserving highly-accurate optimization of the {Z}ener viscoelastic model, with application\n! to wave propagation in the presence of strong attenuation},\n! Author = {\\'Emilie Blanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard and Zhinan Xie},\n! Journal = {Geophysical Journal International},\n! Year = {2015},\n! Note = {in press.}}\n!\n! @ARTICLE{MaKoGeBr10,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney and Emilien Bruthiaux},\n! title = {A high-order time and space formulation of the unsplit perfectly matched layer\n! for the seismic wave equation using {Auxiliary Differential Equations (ADE-PML)}},\n! journal = {Comput. Model. Eng. Sci.},\n! year = {2010},\n! volume = {56},\n! pages = {17-42},\n! number = {1}}\n!\n! @ARTICLE{MaCo10,\n! author = {Roland Martin and Carlos Couder-Casta{\\~n}eda},\n! title = {An improved unsplit and convolutional Perfectly Matched Layer\n! absorbing technique for the Navier-Stokes equations using cut-off frequency shift},\n! journal = {Comput. Model. Eng. Sci.},\n! pages ={47-77}\n! year = {2010},\n! volume = {63},\n! number = {1}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdelaaziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 141\n integer, parameter :: NY = 621 ! NY = 800\n\n! Explicit (epsn=1,epsn=0), implicit (epsn=0,epsn1=1), semi-implicit (epsn=0.5,epsn1=0.5)\n integer, parameter :: iexpl=0\n integer, parameter :: iimpl=0\n integer, parameter :: isemiimpl=1\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 5.d0, ONE_OVER_DELTAX = 1.d0 / DELTAX\n double precision, parameter :: DELTAY = DELTAX\n double precision, parameter :: ONE_OVER_DELTAY = ONE_OVER_DELTAX\n double precision, parameter :: ONE=1.d0,TWO=2.d0, DIM=2.d0\n\n! P-velocity, S-velocity and density\n double precision, parameter :: cp_top = 3050.d0\n double precision, parameter :: cs_top = 1950.d0\n double precision, parameter :: rho_top = 2000.d0\n double precision, parameter :: mu_top = rho_top*cs_top*cs_top\n double precision, parameter :: lambda_top = rho_top*(cp_top*cp_top - 2.d0*cs_top*cs_top)\n double precision, parameter :: lambdaplustwomu_top = rho_top*cp_top*cp_top\n\n double precision, parameter :: cp_bottom = 2600.d0\n double precision, parameter :: cs_bottom = 1500.d0\n double precision, parameter :: rho_bottom = 1500.d0\n double precision, parameter :: mu_bottom = rho_bottom*cs_bottom*cs_bottom\n double precision, parameter :: lambda_bottom = rho_bottom*(cp_bottom*cp_bottom - 2.d0*cs_bottom*cs_bottom)\n double precision, parameter :: lambdaplustwomu_bottom = rho_bottom*cp_bottom*cp_bottom\n\n! total number of time steps\n integer, parameter :: NSTEP = 5000\n\n! time step in seconds\n double precision, parameter :: DELTAT = 5.d-4\n\n! parameters for the source\n double precision, parameter :: f0 = 15.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d5\n\n! parameters for attenuation\n! number of standard linear solids\n integer, parameter :: N_SLS = 2\n\n! Qp approximately equal to 13, Qkappa approximately to 20 and Qmu / Qs approximately to 10\n double precision, parameter :: QKappa_att = 20.d0, QMu_att = 10.d0\n double precision, parameter :: f0_attenuation = 16 ! in Hz\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! heterogeneous model and height of the interface\n logical, parameter :: HETEROGENEOUS_MODEL = .true.\n\n! source\n! integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1\n integer, parameter :: ISOURCE = NPOINTS_PML+11\n integer, parameter :: JSOURCE = 2*NY / 3\n double precision, parameter :: xsource = (ISOURCE) * DELTAX\n double precision, parameter :: ysource = (JSOURCE) * DELTAY\n double precision, parameter :: INTERFACE_HEIGHT = ysource - 125*DELTAY\n integer, parameter:: JINTERFACE=INT(INTERFACE_HEIGHT/DELTAY)+1\n! angle of source force clockwise with respect to vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 45.d0\n\n! receivers\n integer, parameter :: NREC = 3\n double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters\n double precision, parameter :: xfin = xsource ! last receiver x in meters\n double precision, parameter :: yfin = 300.d0 ! last receiver y in meters\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 500\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! Holberg (1987) coefficients, taken from\n! @ARTICLE{Hol87,\n! author = {O. Holberg},\n! title = {Computational aspects of the choice of operator and sampling interval\n! for numerical differentiation in large-scale simulation of wave phenomena},\n! journal = {Geophysical Prospecting},\n! year = {1987},\n! volume = {35},\n! pages = {629-655}}\n double precision, parameter :: c1 = 1.231666d0\n double precision, parameter :: c2 = -1.041182d-1\n double precision, parameter :: c3 = 2.063707d-2\n double precision, parameter :: c4 = -3.570998d-3\n double precision, parameter :: coefficient_sum = abs(c1)+abs(c2)+abs(c3)+abs(c4)\n\n! RK4 scheme coefficients, 2 per subloop, 8 in total\n double precision, dimension(4) :: rk41, rk42\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n double precision, parameter :: NPOWER2 = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n !double precision, parameter :: K_MAX_PML = 7.d0\n! double precision, parameter :: ALPHA_MAX_PML = 0.d0 ! from Festa and Vilotte\n double precision, parameter :: ALPHA_MAX_PML_1 = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n double precision K_MAX_PML_1\n\n! double precision, parameter :: K_MAX_PML_2 = K_MAX_PML_1 / 15.d0\n! double precision, parameter :: K_MAX_PML_2 = K_MAX_PML_1\n! double precision, parameter :: ALPHA_MAX_PML_2 = ALPHA_MAX_PML_1 / 5.d0\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n! We have as many memory variables as the number of frequency shift poles in the CPML\n! Indices are 1 and 2 for the 2 frequency shift poles\n double precision, dimension(4,-4:NX+4,-4:NY+4) :: &\n memory_dvx_dx_1, &\n memory_dvx_dy_1, &\n memory_dvy_dx_1, &\n memory_dvy_dy_1, &\n memory_dsigmaxx_dx_1, &\n memory_dsigmayy_dy_1, &\n memory_dsigmaxy_dx_1, &\n memory_dsigmaxy_dy_1\n double precision, dimension(-4:NX+4,-4:NY+4) :: &\n memory_vx_dx_1, &\n memory_vx_dy_1, &\n memory_vy_dx_1, &\n memory_vy_dy_1, &\n memory_sigmaxx_dx_1, &\n memory_sigmayy_dy_1, &\n memory_sigmaxy_dx_1, &\n memory_sigmaxy_dy_1\n\n double precision :: &\n value_dvx_dx, &\n value_dvx_dy, &\n value_dvy_dx, &\n value_dvy_dy, &\n value_dsigmaxx_dx, &\n value_dsigmayy_dy, &\n value_dsigmaxy_dx, &\n value_dsigmaxy_dy\n\n double precision :: duxdx,duxdy,duydx,duydy,div\n double precision :: epsn,epsn1,Sn\n\n! 1D arrays for the damping profiles\n double precision, dimension(-4:NX+4) :: d_x_1,K_x_1,alpha_prime_x_1,g_x_1,ksi_x\n 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\n double precision, dimension(-4:NY+4) :: d_y_1,K_y_1,alpha_prime_y_1,g_y_1,ksi_y\n 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\n\n! 1D arrays for the damping profiles\n double precision, dimension(-4:NX+4) :: d_x_2,K_x_2,alpha_prime_x_2,g_x_2\n double precision, dimension(-4:NX+4) :: d_x_half_2,K_x_half_2,alpha_prime_x_half_2,g_x_half_2\n double precision, dimension(-4:NY+4) :: d_y_2,K_y_2,alpha_prime_y_2,g_y_2\n double precision, dimension(-4:NY+4) :: d_y_half_2,K_y_half_2,alpha_prime_y_half_2,g_y_half_2\n\n! coefficients that allow to reset the memory variables at each RK4 substep depend on the substepping and are then of dimension 4,\n! 1D arrays for the damping profiles\n double precision, dimension(4,-4:NX+4) :: a_x_1,b_x_1\n double precision, dimension(4,-4:NX+4) :: a_x_half_1,b_x_half_1\n double precision, dimension(4,-4:NY+4) :: a_y_1,b_y_1\n double precision, dimension(4,-4:NY+4) :: a_y_half_1,b_y_half_1\n\n double precision, dimension(-4:NX+4) :: r_x_1,s_x_1\n double precision, dimension(-4:NX+4) :: r_x_half_1,s_x_half_1\n double precision, dimension(-4:NY+4) :: r_y_1,s_y_1\n double precision, dimension(-4:NY+4) :: r_y_half_1,s_y_half_1\n\n! 1D arrays for the damping profiles\n double precision, dimension(4,-4:NX+4) :: a_x_2\n double precision, dimension(4,-4:NX+4) :: a_x_half_2\n double precision, dimension(4,-4:NY+4) :: a_y_2\n double precision, dimension(4,-4:NY+4) :: a_y_half_2\n\n! PML\n double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n double precision, dimension(-4:NX+4,-4:NY+4) :: vx,vy,sigmaxx,sigmayy,sigmaxy\n double precision, dimension(-4:NX+4,-4:NY+4) :: sigmaxx_R,sigmayy_R,sigmaxy_R\n double precision, dimension(N_SLS,-4:NX+4,-4:NY+4) :: e1,e11,e22,e12\n double precision, dimension(-4:NX+4,-4:NY+4) :: rho, mu,lambda,lambdaplustwomu\n\n double precision rho_half_x_half_y\n\n! variables are stored in four indices in the first dimension to implement RK4\n! dv does not always indicate a derivative\n double precision, dimension(4,-4:NX+4,-4:NY+4) :: dvx,dvy,dsigmaxx,dsigmayy,dsigmaxy\n double precision, dimension(4,-4:NX+4,-4:NY+4) :: dsigmaxx_R,dsigmayy_R,dsigmaxy_R\n double precision, dimension(N_SLS,4,-4:NX+4,-4:NY+4) :: de1,de11,de12\n\n integer, parameter :: number_of_2Darrays = 2*8\n integer, parameter :: number_of_3Darrays = 32\n\n! for the source\n double precision a,t,force_x,force_y,source_term\n\n! for attenuation\n double precision :: f_min_attenuation, f_max_attenuation\n double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,tau_epsilon_nu2,tau_sigma_nu2\n\n! for stability estimate\n double precision :: c_max,c_min\n\n! for receivers\n double precision distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy\n\n! max amplitude for color snapshots\n double precision max_amplitudeVx\n double precision max_amplitudeVy\n\n! for evolution of total energy in the medium\n double precision :: epsilon_xx,epsilon_yy,epsilon_xy\n double precision, dimension(NSTEP) :: total_energy,total_energy_kinetic,total_energy_potential\n double precision :: local_energy_kinetic,local_energy_potential\n\n integer :: irec,inc\n\n double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed\n double precision :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed\n double precision :: Mu_nu1,Mu_nu2\n double precision :: phi_nu1(N_SLS)\n double precision :: phi_nu2(N_SLS)\n double precision :: tauinv,inv_tau_sigma_nu1(N_SLS)\n double precision :: taumin,taumax, tau1, tau2, tau3, tau4\n double precision :: inv_tau_sigma_nu2(N_SLS)\n\n integer :: i,j,it,it2\n\n double precision :: Vsolidnorm\n\n double precision Courant_number_bottom,Courant_number_top\n double precision Dispersion_number_bottom,Dispersion_number_top\n\n! timer to count elapsed time\n character(len=8) datein\n character(len=10) timein\n character(len=5) :: zone\n integer, dimension(8) :: time_values\n integer ihours,iminutes,iseconds,int_tCPU\n double precision :: time_start,time_end,tCPU\n\n! names of the time stamp files\n character(len=150) outputname\n\n! main I/O file\n integer, parameter :: IOUT = 41\n\n!---\n!--- the program starts here\n!---\n\n if (iexpl == 1) then\n epsn = 1.d0\n epsn1 = 0.d0\n endif\n\n if (iimpl == 1) then\n epsn = 0.d0\n epsn1 = 1.d0\n endif\n\n if (isemiimpl == 1) then\n epsn = 0.5d0\n epsn1 = 0.5d0\n endif\n\n! attenuation constants for standard linear solids\n! nu1 is the dilatation/incompressibility mode (QKappa)\n! nu2 is the shear mode (Qmu)\n! array index (1) is the first standard linear solid, (2) is the second etc.\n\n! from J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,\n! vol. 58(1), p. 110-120 (1993) for two memory-variable mechanisms (page 112).\n! Beware: these values implement specific values of the quality factors:\n! Qp approximately equal to 13, Qkappa approximately to 20 and Qmu / Qs approximately to 10,\n! which means very high attenuation, see that paper for details.\n! tau_epsilon_nu1(1) = 0.0334d0\n! tau_sigma_nu1(1) = 0.0303d0\n\n! tau_epsilon_nu2(1) = 0.0352d0\n! tau_sigma_nu2(1) = 0.0287d0\n\n! tau_epsilon_nu1(2) = 0.0028d0\n! tau_sigma_nu1(2) = 0.0025d0\n\n! tau_epsilon_nu2(2) = 0.0029d0\n! tau_sigma_nu2(2) = 0.0024d0\n\n! from J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation\n! in a linear viscoelastic medium, Geophysical Journal International,\n! vol. 95, p. 597-611 (1988) for two memory-variable mechanisms (page 604).\n! Beware: these values implement specific values of the quality factors:\n! Qkappa approximately to 27 and Qmu / Qs approximately to 20,\n! which means very high attenuation, see that paper for details.\n\n! tau_epsilon_nu1(1) = 0.0325305d0\n! tau_sigma_nu1(1) = 0.0311465d0\n\n! tau_epsilon_nu2(1) = 0.0332577d0\n! tau_sigma_nu2(1) = 0.0304655d0\n\n! tau_epsilon_nu1(2) = 0.0032530d0\n! tau_sigma_nu1(2) = 0.0031146d0\n\n! tau_epsilon_nu2(2) = 0.0033257d0\n! tau_sigma_nu2(2) = 0.0030465d0\n\n! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0)\n f_min_attenuation = exp(log(f0_attenuation)-log(12.d0)/2.d0)\n f_max_attenuation = 12.d0 * f_min_attenuation\n\n! use new SolvOpt nonlinear optimization with constraints from Emilie Blanc, Bruno Lombard and Dimitri Komatitsch\n! to compute attenuation mechanisms\n call compute_attenuation_coeffs(N_SLS,QKappa_att,f0_attenuation,f_min_attenuation,f_max_attenuation, &\n tau_epsilon_nu1,tau_sigma_nu1)\n\n call compute_attenuation_coeffs(N_SLS,QMu_att,f0_attenuation,f_min_attenuation,f_max_attenuation, &\n tau_epsilon_nu2,tau_sigma_nu2)\n\n print *\n print *,'with new SolvOpt routine for attenuation:'\n print *\n print *,'N_SLS, QKappa_att, QMu_att = ',N_SLS, QKappa_att, QMu_att\n print *,'f0_attenuation,f_min_attenuation,f_max_attenuation = ',f0_attenuation,f_min_attenuation,f_max_attenuation\n print *,'tau_epsilon_nu1 = ',tau_epsilon_nu1\n print *,'tau_sigma_nu1 = ',tau_sigma_nu1\n print *,'tau_epsilon_nu2 = ',tau_epsilon_nu2\n print *,'tau_sigma_nu2 = ',tau_sigma_nu2\n print *\n\n tau1 = tau_sigma_nu1(1)/tau_epsilon_nu1(1)\n tau2 = tau_sigma_nu2(1)/tau_epsilon_nu2(1)\n tau3 = tau_sigma_nu1(2)/tau_epsilon_nu1(2)\n tau4 = tau_sigma_nu2(2)/tau_epsilon_nu2(2)\n\n taumax = max(1.d0/tau1,1.d0/tau2,1.d0/tau3,1.d0/tau4)\n taumin = min(1.d0/tau1,1.d0/tau2,1.d0/tau3,1.d0/tau4)\n\n inv_tau_sigma_nu1(1) = ONE / tau_sigma_nu1(1)\n inv_tau_sigma_nu2(1) = ONE / tau_sigma_nu2(1)\n inv_tau_sigma_nu1(2) = ONE / tau_sigma_nu1(2)\n inv_tau_sigma_nu2(2) = ONE / tau_sigma_nu2(2)\n\n phi_nu1(1) = (ONE - tau_epsilon_nu1(1)/tau_sigma_nu1(1)) / tau_sigma_nu1(1)\n phi_nu2(1) = (ONE - tau_epsilon_nu2(1)/tau_sigma_nu2(1)) / tau_sigma_nu2(1)\n phi_nu1(2) = (ONE - tau_epsilon_nu1(2)/tau_sigma_nu1(2)) / tau_sigma_nu1(2)\n phi_nu2(2) = (ONE - tau_epsilon_nu2(2)/tau_sigma_nu2(2)) / tau_sigma_nu2(2)\n\n Mu_nu1 = ONE - (ONE - tau_epsilon_nu1(1)/tau_sigma_nu1(1)) - (ONE - tau_epsilon_nu1(2)/tau_sigma_nu1(2))\n Mu_nu2 = ONE - (ONE - tau_epsilon_nu2(1)/tau_sigma_nu2(1)) - (ONE - tau_epsilon_nu2(2)/tau_sigma_nu2(2))\n\n print *\n print *,'2D visco-elastic FD code in velocity and stress formulation with ADE in 8th an RK4'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *\n print *,'size of the model along X = ',(NX+1) * DELTAX\n print *,'size of the model along Y = ',(NY+1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *,'Number of points of all the arrays = ',dble(NX+4*2+1)*dble(NY+4*2+1)*number_of_2Darrays + &\n 4*dble(NX+4*2+1)*dble(NY+4*2+1)*number_of_3Darrays\n 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) + &\n 4*dble(NX+4*2+1)*dble(NY+4*2+1)*number_of_3Darrays*8.d0/(1024.d0*1024.d0*1024.d0)\n\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 1.d-5\n c_max = max(cp_bottom,cp_top)\n c_min = min(cs_bottom,cs_top)\n\n K_MAX_PML_1 = 1.d0\n\n print *,'K_MAX_PML = ',K_MAX_PML_1\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n if (HETEROGENEOUS_MODEL) then\n d0_x = - (NPOWER + 1) * c_max *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * c_max *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_y)\n else\n d0_x = - (NPOWER + 1) * cp_bottom *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp_bottom *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_y)\n endif\n\n print *\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n\n! parameters involved in RK4 time expansion\n rk41(1) = ZERO\n rk41(2) = 0.5d0\n rk41(3) = 0.5d0\n rk41(4) = 1.d0\n\n rk42(1) = 1.d0 / 6.d0\n rk42(2) = 2.d0 / 6.d0\n rk42(3) = 2.d0 / 6.d0\n rk42(4) = 1.d0 / 6.d0\n\n ksi_x(:) = ZERO\n ksi_x_half(:) = ZERO\n d_x_1(:) = ZERO\n d_x_half_1(:) = ZERO\n K_x_1(:) = 1.d0\n K_x_half_1(:) = 1.d0\n alpha_prime_x_1(:) = ZERO\n alpha_prime_x_half_1(:) = ZERO\n a_x_1(:,:) = ZERO\n a_x_half_1(:,:) = ZERO\n g_x_1(:) = 5.d-1\n g_x_half_1(:) = 5.d-1\n\n ksi_y(:) = ZERO\n ksi_y_half(:) = ZERO\n d_y_1(:) = ZERO\n d_y_half_1(:) = ZERO\n K_y_1(:) = 1.d0\n K_y_half_1(:) = 1.d0\n alpha_prime_y_1(:) = ZERO\n alpha_prime_y_half_1(:) = ZERO\n a_y_1(:,:) = ZERO\n a_y_half_1(:,:) = ZERO\n g_y_1(:) = 1.d0\n g_y_half_1(:) = 1.d0\n\n d_x_2(:) = ZERO\n d_x_half_2(:) = ZERO\n K_x_2(:) = 1.d0\n K_x_half_2(:) = 1.d0\n alpha_prime_x_2(:) = ZERO\n alpha_prime_x_half_2(:) = ZERO\n a_x_2(:,:) = ZERO\n a_x_half_2(:,:) = ZERO\n g_x_2(:) = 1.d0\n g_x_half_2(:) = 1.d0\n\n d_y_2(:) = ZERO\n d_y_half_2(:) = ZERO\n K_y_2(:) = 1.d0\n K_y_half_2(:) = 1.d0\n alpha_prime_y_2(:) = ZERO\n alpha_prime_y_half_2(:) = ZERO\n a_y_2(:,:) = ZERO\n a_y_half_2(:,:) = ZERO\n g_y_2(:) = 1.d0\n g_y_half_2(:) =1.d0\n\n r_x_1(:) = ZERO\n s_x_1(:) = ZERO\n r_x_half_1(:) = ZERO\n s_x_half_1(:) = ZERO\n r_y_1(:) = ZERO\n s_y_1(:) = ZERO\n r_y_half_1(:) = ZERO\n s_y_half_1(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = -4,NX+4\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- left edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_1(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_1(i) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2\n alpha_prime_x_1(i) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half_1(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half_1(i) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2\n alpha_prime_x_half_1(i) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- right edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_1(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_1(i) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2\n alpha_prime_x_1(i) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half_1(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half_1(i) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2\n alpha_prime_x_half_1(i) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! 1 pole\n d_x_2(i) = 0.d0\n d_x_half_2(i) = 0.d0\n\n! just in case, for -5 at the end\n if (alpha_prime_x_1(i) < ZERO) alpha_prime_x_1(i) = ZERO\n if (alpha_prime_x_half_1(i) < ZERO) alpha_prime_x_half_1(i) = ZERO\n\n! just in case, for -5 at the end\n if (alpha_prime_x_2(i) < ZERO) alpha_prime_x_2(i) = ZERO\n if (alpha_prime_x_half_2(i) < ZERO) alpha_prime_x_half_2(i) = ZERO\n\n! CPML damping parameters for the 4 sub time steps of RK4 algorithm\ndo inc=1,4\n b_x_1(inc,i) = (1.-epsn*DELTAT*rk41(inc)*(d_x_1(i)/K_x_1(i) + alpha_prime_x_1(i)))/&\n (1.+epsn1*DELTAT*rk41(inc)*(d_x_1(i)/K_x_1(i) + alpha_prime_x_1(i)))\n b_x_half_1(inc,i) = (1.-epsn*DELTAT*rk41(inc)*(d_x_half_1(i)/K_x_half_1(i) &\n + alpha_prime_x_half_1(i)))/(1. +epsn1*DELTAT*rk41(inc)*(d_x_half_1(i)/K_x_half_1(i) &\n + alpha_prime_x_half_1(i)))\n\n! this to avoid division by zero outside the PML\nif (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))/&\n (1. +epsn1*DELTAT*rk41(inc)*(d_x_1(i)/K_x_1(i) + alpha_prime_x_1(i)))\n\n if (abs(d_x_half_1(i)) > 1.d-6) a_x_half_1(inc,i) =-DELTAT*rk41(inc)*d_x_half_1(i)/&\n (K_x_half_1(i)*K_x_half_1(i) )/&\n (1. +epsn1*DELTAT*rk41(inc)*(d_x_half_1(i)/K_x_half_1(i)&\n + alpha_prime_x_half_1(i)))\n\n r_x_1(i) = -(d_x_1(i)/K_x_1(i) + alpha_prime_x_1(i))\n s_x_1(i) = - d_x_1(i)/K_x_1(i)/K_x_1(i)\n r_x_half_1(i) = -(d_x_half_1(i)/K_x_half_1(i) + alpha_prime_x_half_1(i))\n s_x_half_1(i) = - d_x_half_1(i)/K_x_half_1(i)/K_x_half_1(i)\n\n enddo\n\nenddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = -4,NY+4\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- bottom edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_1(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_1(j) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2\n alpha_prime_y_1(j) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half_1(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half_1(j) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2\n alpha_prime_y_half_1(j) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- top edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_1(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_1(j) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2\n alpha_prime_y_1(j) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half_1(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half_1(j) = 1.d0 + (K_MAX_PML_1 - 1.d0) * abscissa_normalized**NPOWER2\n alpha_prime_y_half_1(j) = ALPHA_MAX_PML_1 * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_prime_y_1(j) < ZERO) alpha_prime_y_1(j) = ZERO\n if (alpha_prime_y_half_1(j) < ZERO) alpha_prime_y_half_1(j) = ZERO\n\n! CPML damping parameters for the 4 sub time steps of RK4 algorithm\ndo inc=1,4\n b_y_1(inc,j) = (1.-epsn*DELTAT*rk41(inc)*(d_y_1(j)/K_y_1(j) + alpha_prime_y_1(j)))/&\n (1.+epsn1*DELTAT*rk41(inc)*(d_y_1(j)/K_y_1(j) + alpha_prime_y_1(j)))\n b_y_half_1(inc,j) = (1.-epsn*DELTAT*rk41(inc)*(d_y_half_1(j)/K_y_half_1(j) + &\n alpha_prime_y_half_1(j)))/(1.+epsn1*DELTAT*rk41(inc)*(d_y_half_1(j)/K_y_half_1(j)&\n + alpha_prime_y_half_1(j)))\n\n! this to avoid division by zero outside the PML\n if (abs(d_y_1(j)) > 1.d-6) a_y_1(inc,j) = - DELTAT*rk41(inc)*d_y_1(j)&\n / (K_y_1(j)* K_y_1(j))/&\n (1.+epsn1*DELTAT*rk41(inc)*(d_y_1(j)/K_y_1(j) + alpha_prime_y_1(j)))\n if (abs(d_y_half_1(j)) > 1.d-6) a_y_half_1(inc,j) = -DELTAT*rk41(inc)*d_y_half_1(j) /&\n (K_y_half_1(j) * K_y_half_1(j) )/&\n(1.+epsn1*DELTAT*rk41(inc)*(d_y_half_1(j)/K_y_half_1(j) + alpha_prime_y_half_1(j)))\n enddo\n\n r_y_1(j) = -(d_y_1(j)/K_y_1(j) + alpha_prime_y_1(j))\n s_y_1(j) = - d_y_1(j)/K_y_1(j)/K_y_1(j)\n r_y_half_1(j) = -(d_y_half_1(j)/K_y_half_1(j) + alpha_prime_y_half_1(j))\n s_y_half_1(j) = - d_y_half_1(j)/K_y_half_1(j)/K_y_half_1(j)\n\nenddo\n\n! compute the Lame parameters and density\n do j = -4,NY+4\n do i = -4,NX+4\n if (HETEROGENEOUS_MODEL .and. DELTAY*dble(j-1) > INTERFACE_HEIGHT) then\n rho(i,j)= rho_top\n mu(i,j)= mu_top\n lambda(i,j) = lambda_top\n lambdaplustwomu(i,j) = lambdaplustwomu_top\n else\n rho(i,j)= rho_bottom\n mu(i,j)= mu_bottom\n lambda(i,j) = lambda_bottom\n lambdaplustwomu(i,j) = lambdaplustwomu_bottom\n endif\n enddo\n enddo\n\n\n! print position of the source\n print *\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *\n print *,'There are ',nrec,' receivers'\n print *\n! xspacerec = (xfin-xdeb) / dble(NREC-1)\n! yspacerec = (yfin-ydeb) / dble(NREC-1)\n! do irec=1,nrec\n! xrec(irec) = xdeb + dble(irec-1)*xspacerec\n! yrec(irec) = ydeb + dble(irec-1)*yspacerec\n! enddo\n\n xrec(1) = xsource\n yrec(1) = ysource - 393*DELTAY\n xrec(2) = xsource\n yrec(2) = ysource + 191*DELTAY\n xrec(3) = xsource + 101*DELTAX\n yrec(3) = ysource\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i) - xrec(irec))**2 + (DELTAY*dble(j) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number_bottom = cp_bottom *dsqrt(taumax)* DELTAT*sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2)\n Dispersion_number_bottom=cs_bottom*dsqrt(taumin)/(2.5d0*f0*max(DELTAX,DELTAY))\n print *,'Courant number at the bottom is ',Courant_number_bottom\n print *,'Dispersion number at the bottom is ',Dispersion_number_bottom\n print *\n !if (Courant_number_bottom > 1.d0/coefficient_sum) stop 'time step is too large, simulation will be unstable'\n\n if (HETEROGENEOUS_MODEL) then\n Courant_number_top = cp_top *dsqrt(taumax) * DELTAT* sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2 )\n Dispersion_number_top= cs_top*dsqrt(taumin) /(2.5d0*f0*max(DELTAX,DELTAY))\n print *,'Courant number at the top is ',Courant_number_top\n print *\n print *,'Dispersion number at the top is ',Dispersion_number_top\n !if (Courant_number_top > 1.d0/coefficient_sum) stop 'time step is too large, simulation will be unstable'\n endif\n\n! erase main arrays\n vx(:,:) = ZERO\n vy(:,:) = ZERO\n sigmaxy(:,:) = ZERO\n sigmayy(:,:) = ZERO\n sigmaxx(:,:) = ZERO\n sigmaxy_R(:,:) = ZERO\n sigmayy_R(:,:) = ZERO\n sigmaxx_R(:,:) = ZERO\n\n dvx(:,:,:) = ZERO\n dvy(:,:,:) = ZERO\n dsigmaxy(:,:,:) = ZERO\n dsigmayy(:,:,:) = ZERO\n dsigmaxx(:,:,:) = ZERO\n dsigmaxy_R(:,:,:) = ZERO\n dsigmayy_R(:,:,:) = ZERO\n dsigmaxx_R(:,:,:) = ZERO\n\n e1(1,:,:)=ZERO\n e1(2,:,:)=ZERO\n e11(1,:,:)=ZERO\n e11(2,:,:)=ZERO\n e12(1,:,:)=ZERO\n e12(2,:,:)=ZERO\n e22(1,:,:)=ZERO\n e22(2,:,:)=ZERO\n\n de1(1,:,:,:)=ZERO\n de1(2,:,:,:)=ZERO\n de11(1,:,:,:)=ZERO\n de11(2,:,:,:)=ZERO\n de12(1,:,:,:)=ZERO\n de12(2,:,:,:)=ZERO\n\n! PML\n memory_vx_dx_1(:,:) = ZERO\n memory_vx_dy_1(:,:) = ZERO\n memory_vy_dx_1(:,:) = ZERO\n memory_vy_dy_1(:,:) = ZERO\n memory_sigmaxx_dx_1(:,:) = ZERO\n memory_sigmayy_dy_1(:,:) = ZERO\n memory_sigmaxy_dx_1(:,:) = ZERO\n memory_sigmaxy_dy_1(:,:) = ZERO\n\n memory_dvx_dx_1(:,:,:) = ZERO\n memory_dvx_dy_1(:,:,:) = ZERO\n memory_dvy_dx_1(:,:,:) = ZERO\n memory_dvy_dy_1(:,:,:) = ZERO\n memory_dsigmaxx_dx_1(:,:,:) = ZERO\n memory_dsigmayy_dy_1(:,:,:) = ZERO\n memory_dsigmaxy_dx_1(:,:,:) = ZERO\n memory_dsigmaxy_dy_1(:,:,:) = ZERO\n\n! erase seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n\n! initialize total energy\n total_energy(:) = ZERO\n total_energy_kinetic(:) = ZERO\n total_energy_potential(:) = ZERO\n\n call date_and_time(datein,timein,zone,time_values)\n! time_values(3): day of the month\n! time_values(5): hour of the day\n! time_values(6): minutes of the hour\n! time_values(7): seconds of the minute\n! time_values(8): milliseconds of the second\n! this fails if we cross the end of the month\n time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &\n 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0\n\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n ! v and sigma temporary variables of RK4\n ! Save initial value for each field\n\n !dvx(1,:,:) = vx(:,:)\n !dvy(1,:,:) = vy(:,:)\n !dsigmaxx(1,:,:) = sigmaxx(:,:)\n !dsigmayy(1,:,:) = sigmayy(:,:)\n !dsigmaxy(1,:,:) = sigmaxy(:,:)\n !dsigmaxx_R(1,:,:) = sigmaxx_R(:,:)\n !dsigmayy_R(1,:,:) = sigmayy_R(:,:)\n !dsigmaxy_R(1,:,:) = sigmaxy_R(:,:)\n\n dvx(4,:,:) = vx(:,:)\n dvy(4,:,:) = vy(:,:)\n dsigmaxx(4,:,:) = sigmaxx(:,:)\n dsigmayy(4,:,:) = sigmayy(:,:)\n dsigmaxy(4,:,:) = sigmaxy(:,:)\n dsigmaxx_R(4,:,:) = sigmaxx_R(:,:)\n dsigmayy_R(4,:,:) = sigmayy_R(:,:)\n dsigmaxy_R(4,:,:) = sigmaxy_R(:,:)\n\n de1(1,4,:,:) = e1(1,:,:)\n de1(2,4,:,:) = e1(2,:,:)\n de11(1,4,:,:) = e11(1,:,:)\n de11(2,4,:,:) = e11(2,:,:)\n ! de22(1,4,:,:) = de22(1,1,:,:)\n ! de22(2,4,:,:) = de22(2,1,:,:)\n de12(1,4,:,:) = e12(1,:,:)\n de12(2,4,:,:) = e12(2,:,:)\n\n ! same thing for memory variables\n memory_dsigmaxx_dx_1(4,:,:) = memory_sigmaxx_dx_1(:,:)\n memory_dsigmaxy_dy_1(4,:,:) = memory_sigmaxy_dy_1(:,:)\n memory_dsigmaxy_dx_1(4,:,:) = memory_sigmaxy_dx_1(:,:)\n memory_dsigmayy_dy_1(4,:,:) = memory_sigmayy_dy_1(:,:)\n memory_dvx_dx_1(4,:,:) = memory_vx_dx_1(:,:)\n memory_dvy_dy_1(4,:,:) = memory_vy_dy_1(:,:)\n memory_dvy_dx_1(4,:,:) = memory_vy_dx_1(:,:)\n memory_dvx_dy_1(4,:,:) = memory_vx_dy_1(:,:)\n\n ! Initialization of time derivatives\n dvx(2,:,:) = ZERO\n dvy(2,:,:) = ZERO\n dsigmaxx(2,:,:) = ZERO\n dsigmayy(2,:,:) = ZERO\n dsigmaxy(2,:,:) = ZERO\n dsigmaxx_R(2,:,:) = ZERO\n dsigmayy_R(2,:,:) = ZERO\n dsigmaxy_R(2,:,:) = ZERO\n\n de1(1,2,:,:) = ZERO\n de1(2,2,:,:) = ZERO\n de11(1,2,:,:) = ZERO\n de11(2,2,:,:) = ZERO\n de12(1,2,:,:) = ZERO\n de12(2,2,:,:) = ZERO\n\n ! same thing for memory variables\n memory_dsigmaxx_dx_1(2,:,:) = ZERO\n memory_dsigmaxy_dy_1(2,:,:) = ZERO\n memory_dsigmaxy_dx_1(2,:,:) = ZERO\n memory_dsigmayy_dy_1(2,:,:) = ZERO\n memory_dvx_dx_1(2,:,:) = ZERO\n memory_dvy_dy_1(2,:,:) = ZERO\n memory_dvy_dx_1(2,:,:) = ZERO\n memory_dvx_dy_1(2,:,:) = ZERO\n\n ! RK4 loop (loop on the four RK4 substeps)\n do inc= 1,4\n\n! The new values of the different variables v and sigma are computed\n dvx(1,:,:) = dvx(4,:,:) + rk41(inc) * dvx(2,:,:) * DELTAT\n dvy(1,:,:) = dvy(4,:,:) + rk41(inc) * dvy(2,:,:) * DELTAT\n dsigmaxx(1,:,:) = dsigmaxx(4,:,:) + rk41(inc) * dsigmaxx(2,:,:) * DELTAT\n dsigmayy(1,:,:) = dsigmayy(4,:,:) + rk41(inc) * dsigmayy(2,:,:) * DELTAT\n dsigmaxy(1,:,:) = dsigmaxy(4,:,:) + rk41(inc) * dsigmaxy(2,:,:) * DELTAT\n dsigmaxx_R(1,:,:) = dsigmaxx_R(4,:,:) + rk41(inc) * dsigmaxx_R(2,:,:) * DELTAT\n dsigmayy_R(1,:,:) = dsigmayy_R(4,:,:) + rk41(inc) * dsigmayy_R(2,:,:) * DELTAT\n dsigmaxy_R(1,:,:) = dsigmaxy_R(4,:,:) + rk41(inc) * dsigmaxy_R(2,:,:) * DELTAT\n\n de1(1,1,:,:) = de1(1,4,:,:) + rk41(inc) * de1(1,2,:,:) * DELTAT\n de1(2,1,:,:) = de1(2,4,:,:) + rk41(inc) * de1(2,2,:,:) * DELTAT\n de11(1,1,:,:) = de11(1,4,:,:) + rk41(inc) * de11(1,2,:,:) * DELTAT\n de11(2,1,:,:) = de11(2,4,:,:) + rk41(inc) * de11(2,2,:,:) * DELTAT\n de12(1,1,:,:) = de12(1,4,:,:) + rk41(inc) * de12(1,2,:,:) * DELTAT\n de12(2,1,:,:) = de12(2,4,:,:) + rk41(inc) * de12(2,2,:,:) * DELTAT\n\n memory_dsigmaxx_dx_1(1,:,:) = memory_dsigmaxx_dx_1(4,:,:) + rk41(inc)*DELTAT*memory_dsigmaxx_dx_1(2,:,:)\n memory_dsigmaxy_dy_1(1,:,:) = memory_dsigmaxy_dy_1(4,:,:) + rk41(inc)*DELTAT*memory_dsigmaxy_dy_1(2,:,:)\n memory_dsigmaxy_dx_1(1,:,:) = memory_dsigmaxy_dx_1(4,:,:) + rk41(inc)*DELTAT*memory_dsigmaxy_dx_1(2,:,:)\n memory_dsigmayy_dy_1(1,:,:) = memory_dsigmayy_dy_1(4,:,:) + rk41(inc)*DELTAT*memory_dsigmayy_dy_1(2,:,:)\n memory_dvx_dx_1(1,:,:) = memory_dvx_dx_1(4,:,:) + rk41(inc)*DELTAT*memory_dvx_dx_1(2,:,:)\n memory_dvy_dy_1(1,:,:) = memory_dvy_dy_1(4,:,:) + rk41(inc)*DELTAT*memory_dvy_dy_1(2,:,:)\n memory_dvx_dy_1(1,:,:) = memory_dvx_dy_1(4,:,:) + rk41(inc)*DELTAT*memory_dvx_dy_1(2,:,:)\n memory_dvy_dx_1(1,:,:) = memory_dvy_dx_1(4,:,:) + rk41(inc)*DELTAT*memory_dvy_dx_1(2,:,:)\n\n !------------------\n ! compute velocity\n !------------------\n do j = 2,NY\n do i = 2,NX\n\n value_dsigmaxx_dx = ( c1 * (dsigmaxx(1,i,j) - dsigmaxx(1,i-1,j)) + c2 * (dsigmaxx(1,i+1,j) - dsigmaxx(1,i-2,j)) + &\n 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\n\n value_dsigmaxy_dy = ( c1 * (dsigmaxy(1,i,j) - dsigmaxy(1,i,j-1)) + c2* (dsigmaxy(1,i,j+1) - dsigmaxy(1,i,j-2)) + &\n 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\n\n if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then\n\n 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\n 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\n\n value_dsigmaxx_dx = value_dsigmaxx_dx / K_x_1(i) + memory_dsigmaxx_dx_1(1,i,j)\n value_dsigmaxy_dy = value_dsigmaxy_dy / K_y_1(j) + memory_dsigmaxy_dy_1(1,i,j)\n endif\n\n dvx(2,i,j) = (value_dsigmaxx_dx + value_dsigmaxy_dy)/rho(i,j)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n value_dsigmaxy_dx = ( c1 * (dsigmaxy(1,i+1,j) - dsigmaxy(1,i,j)) + c2 * (dsigmaxy(1,i+2,j) - dsigmaxy(1,i-1,j)) + &\n 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\n\n value_dsigmayy_dy = ( c1 * (dsigmayy(1,i,j+1) - dsigmayy(1,i,j)) + c2 * (dsigmayy(1,i,j+2) - dsigmayy(1,i,j-1)) + &\n 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\n\n if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then\n 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\n 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\n\n value_dsigmaxy_dx = value_dsigmaxy_dx/K_x_half_1(i)+memory_dsigmaxy_dx_1(1,i,j)\n value_dsigmayy_dy = value_dsigmayy_dy/K_y_half_1(j)+memory_dsigmayy_dy_1(1,i,j)\n endif\n\n dvy(2,i,j) = (value_dsigmaxy_dx + value_dsigmayy_dy) /rho_half_x_half_y\n enddo\n enddo\n\n\n ! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0;\n t = (dble(it-1)+ rk41(inc)) * DELTAT\n\n ! Gaussian\n ! source_term = factor * exp(-a*(t-t0)**2)\n\n ! first derivative of a Gaussian\n source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n ! Ricker source time function (second derivative of a Gaussian)\n ! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n\n ! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n ! interpolate density at the right location in the staggered grid cell\n dvx(2,i,j) = dvx(2,i,j) + force_x/ rho(i,j)\n\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n dvy(2,i,j) = dvy(2,i,j) + force_y/ rho_half_x_half_y\n\n ! Dirichlet conditions (rigid boundaries) on all the edges of the grid\n dvx(:,-4:1,:) = ZERO\n dvx(:,NX:NX+4,:) = ZERO\n\n dvx(:,:,-4:1) = ZERO\n dvx(:,:,NY:NY+4) = ZERO\n\n dvy(:,-4:1,:) = ZERO\n dvy(:,NX:NX+4,:) = ZERO\n\n dvy(:,:,-4:1) = ZERO\n dvy(:,:,NY:NY+4) = ZERO\n\n !----------------------\n ! compute stress sigma\n !----------------------\n\n do j=2,NY\n do i=1,NX-1\n\n mul_relaxed = 0.5d0 * (mu(i+1,j) + mu(i,j))\n lambdal_relaxed = 0.5d0 * (lambda(i+1,j) + lambda(i,j))\n lambdalplus2mul_relaxed = 0.5d0 * (lambdaplustwomu(i+1,j) + lambdaplustwomu(i,j))\n\n lambdal_unrelaxed = (lambdal_relaxed + 2.d0/DIM*mul_relaxed) * Mu_nu1 - 2.d0/DIM*mul_relaxed * Mu_nu2\n mul_unrelaxed = mul_relaxed * Mu_nu2\n lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed\n\n value_dvx_dx = ( c1 * (dvx(1,i+1,j) - dvx(1,i,j)) + c2 * (dvx(1,i+2,j) - dvx(1,i-1,j)) + &\n 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\n\n value_dvy_dy = ( c1 * (dvy(1,i,j) - dvy(1,i,j-1)) + c2 * (dvy(1,i,j+1) - dvy(1,i,j-2)) + &\n 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\n\n duxdx = value_dvx_dx\n duydy = value_dvy_dy\n\n if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then\n 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\n 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\n\n duxdx = value_dvx_dx / K_x_half_1(i) + memory_dvx_dx_1(1,i,j)\n duydy = value_dvy_dy / K_y_1(j) + memory_dvy_dy_1(1,i,j)\n endif\n\n div=duxdx+duydy\n\n!evolution e1(1)\n tauinv = - inv_tau_sigma_nu1(1)\n Sn = div * phi_nu1(1)\n de1(1,2,i,j) = tauinv * de1(1,1,i,j) + Sn\n\n!evolution e1(2)\n tauinv = - inv_tau_sigma_nu1(2)\n Sn = div * phi_nu1(2)\n de1(2,2,i,j) = tauinv * de1(2,1,i,j) + Sn\n\n! evolution e11(1)\n tauinv = - inv_tau_sigma_nu2(1)\n Sn = (duxdx - div/DIM) * phi_nu2(1)\n de11(1,2,i,j) = tauinv * de11(1,1,i,j) + Sn\n\n! evolution e11(2)\n tauinv = - inv_tau_sigma_nu2(2)\n Sn = (duxdx - div/DIM) * phi_nu2(2)\n de11(2,2,i,j) = tauinv * de11(2,1,i,j) + Sn\n\n!add the memory variables using the relaxed parameters (Carcione page 111)\n! there is a bug in Carcione's equation for sigma_zz\n dsigmaxx(2,i,j) = ((lambdal_relaxed + 2.d0/DIM*mul_relaxed)* &\n (de1(1,1,i,j) + de1(2,1,i,j)) + TWO * mul_relaxed * (de11(1,1,i,j) + de11(2,1,i,j))+ &\n (lambdalplus2mul_unrelaxed * (duxdx) + lambdal_unrelaxed* (duydy) ))\n\n dsigmayy(2,i,j) = ((lambdal_relaxed + 2.d0*mul_relaxed)* &\n (de1(1,1,i,j) + de1(2,1,i,j)) - TWO/DIM * mul_relaxed * (de11(1,1,i,j) + de11(2,1,i,j)) + &\n (lambdal_unrelaxed * (duxdx) + lambdalplus2mul_unrelaxed* (duydy) ))\n\n! compute the stress using the unrelaxed Lame parameters (Carcione page 111)\n dsigmaxx_R(2,i,j) = lambdalplus2mul_relaxed * (duxdx) + lambdal_relaxed* (duydy)\n\n dsigmayy_R(2,i,j) = lambdal_relaxed * (duxdx) + lambdalplus2mul_relaxed* (duydy)\n\n enddo\n enddo\n\n do j=1,NY-1\n do i=2,NX\n mul_relaxed = 0.5d0 * (mu(i,j+1) + mu(i,j))\n mul_unrelaxed = mul_relaxed * Mu_nu2\n\n value_dvy_dx = ( c1 * (dvy(1,i,j) - dvy(1,i-1,j)) + c2 * (dvy(1,i+1,j) - dvy(1,i-2,j)) + &\n 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\n\n value_dvx_dy = ( c1 * (dvx(1,i,j+1) - dvx(1,i,j)) + c2 * (dvx(1,i,j+2) - dvx(1,i,j-1)) + &\n 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\n\n duydx = value_dvy_dx\n duxdy = value_dvx_dy\n\n if (i <= NPOINTS_PML+2 .or. i >= NX-NPOINTS_PML-2 .or. j <= NPOINTS_PML+2 .or. j >= NY-NPOINTS_PML-2) then\n 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\n 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\n\n duydx = value_dvy_dx / K_x_1(i) + memory_dvy_dx_1(1,i,j)\n duxdy = value_dvx_dy / K_y_half_1(j) + memory_dvx_dy_1(1,i,j)\n endif\n\n! evolution e12(1)\n tauinv = - inv_tau_sigma_nu2(1)\n Sn = (duxdy+duydx) * phi_nu2(1)\n de12(1,2,i,j) = tauinv * de12(1,1,i,j) + Sn\n\n! evolution e12(2)\n tauinv = - inv_tau_sigma_nu2(2)\n Sn = (duxdy+duydx) * phi_nu2(2)\n de12(2,2,i,j) = tauinv * de12(2,1,i,j) + Sn\n\n dsigmaxy(2,i,j) = mul_relaxed * (de12(1,1,i,j) + de12(2,1,i,j))+mul_unrelaxed * (duxdy+duydx)\n dsigmaxy_R(2,i,j) = mul_relaxed * (duxdy+duydx)\n\n enddo\n enddo\n\n ! Update solution for next time step Delta_t\n vx(:,:) = vx(:,:) + rk42(inc) * dvx(2,:,:) * DELTAT\n vy(:,:) = vy(:,:) + rk42(inc) * dvy(2,:,:) * DELTAT\n sigmaxx(:,:) = sigmaxx(:,:) + rk42(inc) * dsigmaxx(2,:,:) * DELTAT\n sigmayy(:,:) = sigmayy(:,:) + rk42(inc) * dsigmayy(2,:,:) * DELTAT\n sigmaxy(:,:) = sigmaxy(:,:) + rk42(inc) * dsigmaxy(2,:,:) * DELTAT\n sigmaxx_R(:,:) = sigmaxx_R(:,:) + rk42(inc) * dsigmaxx_R(2,:,:) * DELTAT\n sigmayy_R(:,:) = sigmayy_R(:,:) + rk42(inc) * dsigmayy_R(2,:,:) * DELTAT\n sigmaxy_R(:,:) = sigmaxy_R(:,:) + rk42(inc) * dsigmaxy_R(2,:,:) * DELTAT\n\n e1(1,:,:) = e1(1,:,:) + rk42(inc) * de1(1,2,:,:) * DELTAT\n e1(2,:,:) = e1(2,:,:) + rk42(inc) * de1(2,2,:,:) * DELTAT\n e11(1,:,:) = e11(1,:,:) + rk42(inc) * de11(1,2,:,:) * DELTAT\n e11(2,:,:) = e11(2,:,:) + rk42(inc) * de11(2,2,:,:) * DELTAT\n e12(1,:,:) = e12(1,:,:) + rk42(inc) * de12(1,2,:,:) * DELTAT\n e12(2,:,:) = e12(2,:,:) + rk42(inc) * de12(2,2,:,:) * DELTAT\n\n memory_vx_dx_1(:,:) = memory_vx_dx_1(:,:) + rk42(inc) * memory_dvx_dx_1(2,:,:) * DELTAT\n memory_vx_dy_1(:,:) = memory_vx_dy_1(:,:) + rk42(inc) * memory_dvx_dy_1(2,:,:) * DELTAT\n memory_vy_dx_1(:,:) = memory_vy_dx_1(:,:) + rk42(inc) * memory_dvy_dx_1(2,:,:) * DELTAT\n memory_vy_dy_1(:,:) = memory_vy_dy_1(:,:) + rk42(inc) * memory_dvy_dy_1(2,:,:) * DELTAT\n memory_sigmaxx_dx_1(:,:) = memory_sigmaxx_dx_1(:,:) + rk42(inc) * memory_dsigmaxx_dx_1(2,:,:) * DELTAT\n memory_sigmayy_dy_1(:,:) = memory_sigmayy_dy_1(:,:) + rk42(inc) * memory_dsigmayy_dy_1(2,:,:) * DELTAT\n memory_sigmaxy_dx_1(:,:) = memory_sigmaxy_dx_1(:,:) + rk42(inc) * memory_dsigmaxy_dx_1(2,:,:) * DELTAT\n memory_sigmaxy_dy_1(:,:) = memory_sigmaxy_dy_1(:,:) + rk42(inc) * memory_dsigmaxy_dy_1(2,:,:) * DELTAT\n\n ! Dirichlet conditions (rigid boundaries) on all the edges of the grid\n dvx(:,-4:1,:) = ZERO\n dvx(:,NX:NX+4,:) = ZERO\n\n dvx(:,:,-4:1) = ZERO\n dvx(:,:,NY:NY+4) = ZERO\n\n dvy(:,-4:1,:) = ZERO\n dvy(:,NX:NX+4,:) = ZERO\n\n dvy(:,:,-4:1) = ZERO\n dvy(:,:,NY:NY+4) = ZERO\n\n vx(-4:1,:) = ZERO\n vx(:,-4:1) = ZERO\n vy(-4:1,:) = ZERO\n vy(:,-4:1) = ZERO\n\n vx(NX:NX+4,:) = ZERO\n vx(:,NY:NY+4) = ZERO\n vy(NX:NX+4,:) = ZERO\n vy(:,NY:NY+4) = ZERO\n\n enddo\n\n !vx(:,:) = dvx(1,:,:)\n !vy(:,:) = dvy(1,:,:)\n !sigmaxx(:,:) = dsigmaxx(1,:,:)\n !sigmayy(:,:) = dsigmayy(1,:,:)\n !sigmaxy(:,:) = dsigmaxy(1,:,:)\n !sigmaxx_R(:,:) = dsigmaxx_R(1,:,:)\n !sigmayy_R(:,:) = dsigmayy_R(1,:,:)\n !sigmaxy_R(:,:) = dsigmaxy_R(1,:,:)\n\n !e1(1,:,:) = de1(1,1,:,:)\n !e1(2,:,:) = de1(2,1,:,:)\n !e11(1,:,:) = de11(1,1,:,:)\n !e11(2,:,:) = de11(2,1,:,:)\n !e12(1,:,:) = de12(1,1,:,:)\n !e12(2,:,:) = de12(2,1,:,:)\n\n! end of RK4 loop\n\n! store seismograms\n do irec = 1,NREC\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec))\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))\n enddo\n\n! compute total energy in the medium (without the PML layers)\n local_energy_kinetic = ZERO\n local_energy_potential = ZERO\n\n\n do j = NPOINTS_PML, NY-NPOINTS_PML+1\n do i = NPOINTS_PML, NX-NPOINTS_PML+1\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n! in principle we should use rho_half_x_half_y instead of rho for vy\n! in order to interpolate density at the right location in the staggered grid cell\n! but in a homogeneous medium we can safely ignore it\n local_energy_kinetic = local_energy_kinetic + 0.5d0 * rho(i,j)*( &\n vx(i,j)**2 + vy(i,j)**2)\n\n total_energy_kinetic(it) = local_energy_kinetic\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n! in principle we should interpolate the medium parameters at the right location\n! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n\n! compute total field from split components\n epsilon_xx = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmaxx_R(i,j) - lambda(i,j) * sigmayy_R(i,j)) / &\n (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j)))\n\n epsilon_yy = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmayy_R(i,j) - lambda(i,j) * sigmaxx_R(i,j)) / &\n (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j)))\n\n epsilon_xy = sigmaxy_R(i,j) / (2.d0 * mu(i,j))\n\n local_energy_potential = local_energy_potential + &\n 0.5d0 * (epsilon_xx * sigmaxx_R(i,j) + epsilon_yy * sigmayy_R(i,j) + &\n epsilon_yy * sigmayy_R(i,j)+ 2.d0 * epsilon_xy * sigmaxy_R(i,j))\n\n total_energy_potential(it) = local_energy_potential\n\n enddo\n enddo\n\n total_energy(it) = total_energy_kinetic(it) + total_energy_potential(it)\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n Vsolidnorm = maxval(sqrt(vx**2 + vy**2))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',Vsolidnorm\n print *,'Total energy = ',total_energy(it)\n! check stability of the code, exit if unstable\n if (Vsolidnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up in solid'\n\n! save energy\n open(unit=21,file='energy.dat',status='unknown')\n do it2=1,NSTEP\n write(21,*) sngl(dble(it2-1)*DELTAT),total_energy_kinetic(it2), &\n total_energy_potential(it2),total_energy(it2)\n enddo\n close(21)\n\n! save seismograms\n print *,'saving seismograms'\n print *\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT,t0)\n\n call create_color_image(vx(1:NX,1:NY),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1,max_amplitudeVx,JINTERFACE)\n call create_color_image(vy(1:NX,1:NY),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2,max_amplitudeVy,JINTERFACE)\n\n endif\n\n! --- end of time loop\n enddo\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT,t0)\n\n! save total energy\n open(unit=20,file='RK4_energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n sngl(total_energy_potential(it)),sngl(total_energy(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='RK4_plot_energy',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"ADEPML2D_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"RK4_energy.dat\" t ''Total energy'' w l 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"RK4_Vx_file_001.dat\" t ''Vx ADE-PML RK4'' w l 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"RK4_Vy_file_001.dat\" t ''Vy ADE-PML RK4'' w l 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"RK4_Vx_file_002.dat\" t ''Vx ADE-PML RK4'' w l 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"RK4_Vy_file_002.dat\" t ''Vy ADE-PML RK4'' w l 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_003.eps\"'\n write(20,*) 'plot \"RK4_Vx_file_003.dat\" t ''Vx ADE-PML RK4'' w l 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_003.eps\"'\n write(20,*) 'plot \"RK4_Vy_file_003.dat\" t ''Vy ADE-PML RK4'' w l 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n ! count elapsed wall-clock time\n call date_and_time(datein,timein,zone,time_values)\n! time_values(3): day of the month\n! time_values(5): hour of the day\n! time_values(6): minutes of the hour\n! time_values(7): seconds of the minute\n! time_values(8): milliseconds of the second\n! this fails if we cross the end of the month\n time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &\n 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0\n\n! elapsed time since beginning of the simulation\n tCPU = time_end - time_start\n int_tCPU = int(tCPU)\n ihours = int_tCPU / 3600\n iminutes = (int_tCPU - 3600*ihours) / 60\n iseconds = int_tCPU - 3600*ihours - 60*iminutes\n write(*,*) 'Elapsed time in seconds = ',tCPU\n write(*,\"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')\") ihours,iminutes,iseconds\n write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)\n write(*,*)\n\n! write time stamp file to give information about progression of simulation\n write(outputname,\"('timestamp',i6.6)\") it\n open(unit=IOUT,file=outputname,status='unknown')\n write(IOUT,*) 'Time step # ',it\n write(IOUT,*) 'Time: ',sngl((it-1)*DELTAT),' seconds'\n write(IOUT,*) 'Max norm velocity vector V (m/s) = ',Vsolidnorm\n write(IOUT,*) 'Total energy = ',total_energy(it)\n write(IOUT,*) 'Elapsed time in seconds = ',tCPU\n write(IOUT,\"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')\") ihours,iminutes,iseconds\n write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)\n close(IOUT)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_ADEPML_2D_viscoelastic_RK4_eighth_order\n\n! include the SolvOpt routines\n include \"attenuation_model_with_SolvOpt.f90\"\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT,t0)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT,t0\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('RK4_Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT-t0),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component\n do irec=1,nrec\n write(file_name,\"('RK4_Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT-t0),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM,USE_PML_TOP,field_number,max_amplitude,JINTERFACE)\n\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM,USE_PML_TOP\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer ix,iy,irec,JINTERFACE\n\n double precision max_amplitude\n\n character(len=100) file_name,system_command\n\n double precision normalized_value\n integer :: R, G, B\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n endif\n if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n if (field_number == 3) then\n write(file_name,\"('image',i6.6,'_Vnorm.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vnorm.pnm image',i6.6,'_Vnorm.gif ; rm image',i6.6,'_Vnorm.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_LEFT .and. ix == NPOINTS_PML) .or. &\n (USE_PML_RIGHT .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_BOTTOM .and. iy == NPOINTS_PML) .or. &\n (USE_PML_TOP .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n else if (iy == JINTERFACE) then\n R = 0\n G = 0\n B = 0\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to JPEG\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_CPML_2D_anisotropic.f90", "content": "!\n! SEISMIC_CPML Version 1.1.1, November 2009.\n!\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributors: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n! and Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional anisotropic elastic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_2D_aniso\n\n! 2D elastic finite-difference code in velocity and stress formulation\n! with Convolutional-PML (C-PML) absorbing conditions for an anisotropic medium\n\n! Dimitri Komatitsch, University of Pau, France, April 2007.\n! Anisotropic implementation by Roland Martin and Dimitri Komatitsch, University of Pau, France, April 2007.\n\n! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n!\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these\n! articles:\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! If you use the anisotropic implementation, please cite this article,\n! in which the anisotropic parameters are described, as well:\n!\n! @ARTICLE{KoBaTr00,\n! author = {D. Komatitsch and C. Barnes and J. Tromp},\n! title = {Simulation of anisotropic wave propagation based upon a spectral element method},\n! journal = {Geophysics},\n! year = {2000},\n! volume = {65},\n! number = {4},\n! pages = {1251-1260},\n! doi = {10.1190/1.1444816}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 401\n integer, parameter :: NY = 401\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 0.0625d-2\n double precision, parameter :: DELTAY = DELTAX\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! Velocity of qP along horizontal axis = sqrt(c11/rho)\n! Velocity of qP along vertical axis = sqrt(c22/rho)\n! Velocity of qSV along horizontal axis = sqrt(c33/rho)\n! Velocity of qSV along vertical axis = sqrt(c33/rho), same as along horizontal axis\n\n! zinc, from Komatitsch et al. (2000)\n! double precision, parameter :: c11 = 16.5d10\n! double precision, parameter :: c12 = 5.d10\n! double precision, parameter :: c22 = 6.2d10\n! double precision, parameter :: c33 = 3.96d10\n! double precision, parameter :: rho = 7100.d0\n! double precision, parameter :: f0 = 170.d3\n\n! apatite, from Komatitsch et al. (2000)\n! double precision, parameter :: c11 = 16.7d10\n! double precision, parameter :: c12 = 6.6d10\n! double precision, parameter :: c22 = 14.d10\n! double precision, parameter :: c33 = 6.63d10\n! double precision, parameter :: rho = 3200.d0\n! double precision, parameter :: f0 = 300.d3\n\n! isotropic material a bit similar to apatite\n! double precision, parameter :: c11 = 16.7d10\n! double precision, parameter :: c12 = c11/3.d0\n! double precision, parameter :: c22 = c11\n! double precision, parameter :: c33 = (c11-c12)/2.d0 ! = c11/3.d0\n! double precision, parameter :: rho = 3200.d0\n! double precision, parameter :: f0 = 300.d3\n\n! model I from Becache, Fauqueux and Joly, which is stable\n double precision, parameter :: scale_aniso = 1.d10\n double precision, parameter :: c11 = 4.d0 * scale_aniso\n double precision, parameter :: c12 = 3.8d0 * scale_aniso\n double precision, parameter :: c22 = 20.d0 * scale_aniso\n double precision, parameter :: c33 = 2.d0 * scale_aniso\n double precision, parameter :: rho = 4000.d0 ! used to be 1.\n double precision, parameter :: f0 = 200.d3\n\n! model II from Becache, Fauqueux and Joly, which is stable\n! double precision, parameter :: scale_aniso = 1.d10\n! double precision, parameter :: c11 = 20.d0 * scale_aniso\n! double precision, parameter :: c12 = 3.8d0 * scale_aniso\n! double precision, parameter :: c22 = c11\n! double precision, parameter :: c33 = 2.d0 * scale_aniso\n! double precision, parameter :: rho = 4000.d0 ! used to be 1.\n! double precision, parameter :: f0 = 200.d3\n\n! model III from Becache, Fauqueux and Joly, which is unstable\n! double precision, parameter :: scale_aniso = 1.d10\n! double precision, parameter :: c11 = 4.d0 * scale_aniso\n! double precision, parameter :: c12 = 4.9d0 * scale_aniso\n! double precision, parameter :: c22 = 20.d0 * scale_aniso\n! double precision, parameter :: c33 = 2.d0 * scale_aniso\n! double precision, parameter :: rho = 4000.d0 ! used to be 1.\n! double precision, parameter :: f0 = 250.d3\n\n! model IV from Becache, Fauqueux and Joly, which is unstable\n! double precision, parameter :: scale_aniso = 1.d10\n! double precision, parameter :: c11 = 4.d0 * scale_aniso\n! double precision, parameter :: c12 = 7.5d0 * scale_aniso\n! double precision, parameter :: c22 = 20.d0 * scale_aniso\n! double precision, parameter :: c33 = 2.d0 * scale_aniso\n! double precision, parameter :: rho = 4000.d0 ! used to be 1.\n! double precision, parameter :: f0 = 170.d3\n\n! total number of time steps\n integer, parameter :: NSTEP = 3000\n\n! time step in seconds\n double precision, parameter :: DELTAT = 50.d-9\n\n! parameters for the source\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d7\n\n! source\n integer, parameter :: ISOURCE = NX / 2\n integer, parameter :: JSOURCE = NY / 2\n double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX\n double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY\n! angle of source force clockwise with respect to vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 0.d0\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 100\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n double precision, dimension(NX,NY) :: vx,vy,sigmaxx,sigmayy,sigmaxy\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(NX,NY) :: &\n memory_dvx_dx, &\n memory_dvx_dy, &\n memory_dvy_dx, &\n memory_dvy_dy, &\n memory_dsigmaxx_dx, &\n memory_dsigmayy_dy, &\n memory_dsigmaxy_dx, &\n memory_dsigmaxy_dy\n\n double precision :: &\n value_dvx_dx, &\n value_dvx_dy, &\n value_dvy_dx, &\n value_dvy_dy, &\n value_dsigmaxx_dx, &\n value_dsigmayy_dy, &\n value_dsigmaxy_dx, &\n value_dsigmaxy_dy\n\n! 1D arrays for the damping profiles\n 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\n 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\n\n double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n! for the source\n double precision :: a,t,force_x,force_y,source_term\n\n integer :: i,j,it\n\n double precision :: Courant_number,velocnorm\n\n! for stability estimate\n double precision :: quasi_cp_max,aniso_stability_criterion,aniso2,aniso3\n\n!---\n!--- program starts here\n!---\n\n print *\n print *,'2D elastic finite-difference code in velocity and stress formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n print *,'Velocity of qP along vertical axis. . . . =',sqrt(c22/rho)\n print *,'Velocity of qP along horizontal axis. . . =',sqrt(c11/rho)\n print *\n print *,'Velocity of qSV along vertical axis . . . =',sqrt(c33/rho)\n print *,'Velocity of qSV along horizontal axis . . =',sqrt(c33/rho)\n print *\n\n! from Becache et al., INRIA report, equation 7 page 5 http://hal.inria.fr/docs/00/07/22/83/PDF/RR-4304.pdf\n if (c11*c22 - c12*c12 <= 0.d0) stop 'problem in definition of orthotropic material'\n\n! check intrinsic mathematical stability of PML model for an anisotropic material\n! from E. B\\'ecache, S. Fauqueux and P. Joly, Stability of Perfectly Matched Layers, group\n! velocities and anisotropic waves, Journal of Computational Physics, 188(2), p. 399-433 (2003)\n aniso_stability_criterion = ((c12+c33)**2 - c11*(c22-c33)) * ((c12+c33)**2 + c33*(c22-c33))\n print *,'PML anisotropy stability criterion from Becache et al. 2003 = ',aniso_stability_criterion\n if (aniso_stability_criterion > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) &\n print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 1'\n print *\n\n aniso2 = (c12 + 2*c33)**2 - c11*c22\n print *,'PML aniso2 stability criterion from Becache et al. 2003 = ',aniso2\n if (aniso2 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) &\n print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 2'\n print *\n\n aniso3 = (c12 + c33)**2 - c11*c22 - c33**2\n print *,'PML aniso3 stability criterion from Becache et al. 2003 = ',aniso3\n if (aniso3 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) &\n print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 3'\n print *\n\n! to compute d0 below, and for stability estimate\n quasi_cp_max = max(sqrt(c22/rho),sqrt(c11/rho))\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * quasi_cp_max * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * quasi_cp_max * log(Rcoef) / (2.d0 * thickness_PML_y)\n\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *\n\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- left edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- right edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- bottom edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- top edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! print position of the source\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number = quasi_cp_max * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2)\n print *,'Courant number is ',Courant_number\n print *\n if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable'\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')\n\n! initialize arrays\n vx(:,:) = ZERO\n vy(:,:) = ZERO\n sigmaxx(:,:) = ZERO\n sigmayy(:,:) = ZERO\n sigmaxy(:,:) = ZERO\n\n! PML\n memory_dvx_dx(:,:) = ZERO\n memory_dvx_dy(:,:) = ZERO\n memory_dvy_dx(:,:) = ZERO\n memory_dvy_dy(:,:) = ZERO\n memory_dsigmaxx_dx(:,:) = ZERO\n memory_dsigmayy_dy(:,:) = ZERO\n memory_dsigmaxy_dx(:,:) = ZERO\n memory_dsigmaxy_dy(:,:) = ZERO\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!------------------------------------------------------------\n! compute stress sigma and update memory variables for C-PML\n!------------------------------------------------------------\n\n do j = 2,NY\n do i = 1,NX-1\n\n value_dvx_dx = (vx(i+1,j) - vx(i,j)) / DELTAX\n value_dvy_dy = (vy(i,j) - vy(i,j-1)) / DELTAY\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j)\n\n sigmaxx(i,j) = sigmaxx(i,j) + (c11 * value_dvx_dx + c12 * value_dvy_dy) * DELTAT\n sigmayy(i,j) = sigmayy(i,j) + (c12 * value_dvx_dx + c22 * value_dvy_dy) * DELTAT\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 2,NX\n\n value_dvy_dx = (vy(i,j) - vy(i-1,j)) / DELTAX\n value_dvx_dy = (vx(i,j+1) - vx(i,j)) / DELTAY\n\n memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx\n memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy\n\n value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)\n value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j)\n\n sigmaxy(i,j) = sigmaxy(i,j) + c33 * (value_dvy_dx + value_dvx_dy) * DELTAT\n\n enddo\n enddo\n\n!--------------------------------------------------------\n! compute velocity and update memory variables for C-PML\n!--------------------------------------------------------\n\n do j = 2,NY\n do i = 2,NX\n\n value_dsigmaxx_dx = (sigmaxx(i,j) - sigmaxx(i-1,j)) / DELTAX\n value_dsigmaxy_dy = (sigmaxy(i,j) - sigmaxy(i,j-1)) / DELTAY\n\n memory_dsigmaxx_dx(i,j) = b_x(i) * memory_dsigmaxx_dx(i,j) + a_x(i) * value_dsigmaxx_dx\n memory_dsigmaxy_dy(i,j) = b_y(j) * memory_dsigmaxy_dy(i,j) + a_y(j) * value_dsigmaxy_dy\n\n value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j)\n value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j)\n\n vx(i,j) = vx(i,j) + (value_dsigmaxx_dx + value_dsigmaxy_dy) * DELTAT / rho\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n value_dsigmaxy_dx = (sigmaxy(i+1,j) - sigmaxy(i,j)) / DELTAX\n value_dsigmayy_dy = (sigmayy(i,j+1) - sigmayy(i,j)) / DELTAY\n\n memory_dsigmaxy_dx(i,j) = b_x_half(i) * memory_dsigmaxy_dx(i,j) + a_x_half(i) * value_dsigmaxy_dx\n memory_dsigmayy_dy(i,j) = b_y_half(j) * memory_dsigmayy_dy(i,j) + a_y_half(j) * value_dsigmayy_dy\n\n value_dsigmaxy_dx = value_dsigmaxy_dx / K_x_half(i) + memory_dsigmaxy_dx(i,j)\n value_dsigmayy_dy = value_dsigmayy_dy / K_y_half(j) + memory_dsigmayy_dy(i,j)\n\n vy(i,j) = vy(i,j) + (value_dsigmaxy_dx + value_dsigmayy_dy) * DELTAT / rho\n\n enddo\n enddo\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! source_term = factor * exp(-a*(t-t0)**2)\n\n! first derivative of a Gaussian\n source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n vx(i,j) = vx(i,j) + force_x * DELTAT / rho\n vy(i,j) = vy(i,j) + force_y * DELTAT / rho\n\n! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers\n vx(1,:) = ZERO\n vx(NX,:) = ZERO\n\n vx(:,1) = ZERO\n vx(:,NY) = ZERO\n\n vy(1,:) = ZERO\n vy(NX,:) = ZERO\n\n vy(:,1) = ZERO\n vy(:,NY) = ZERO\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n! print maximum of norm of velocity\n velocnorm = maxval(sqrt(vx**2 + vy**2))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',velocnorm\n print *\n! check stability of the code, exit if unstable\n if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)\n call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)\n\n endif\n\n enddo ! end of time loop\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_CPML_2D_aniso\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer :: ix,iy\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_CPML_2D_isotropic_fourth_order.f90", "content": "!\n! SEISMIC_CPML Version 1.1.1, November 2009.\n!\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributors: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n! and Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional isotropic elastic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_2D_iso_fourth\n\n! 2D elastic finite-difference code in velocity and stress formulation\n! with Convolutional-PML (C-PML) absorbing conditions for an isotropic medium\n\n! Dimitri Komatitsch, University of Pau, France, April 2007.\n! Fourth-order implementation by Dimitri Komatitsch and Roland Martin, University of Pau, France, August 2007.\n\n! The staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n!\n! but a fourth-order spatial operator is used instead of a second-order operator\n! as in program seismic_CPML_2D_iso_second.f90 . You can type the following command\n! to see the changes that have been made to switch from the second-order operator\n! to the fourth-order operator:\n!\n! diff seismic_CPML_2D_isotropic_second_order.f90 seismic_CPML_2D_isotropic_fourth_order.f90\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000)\n!\n! If you use this code for your own research, please cite some (or all) of these articles:\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdelaaziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 101\n integer, parameter :: NY = 641\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 10.d0\n double precision, parameter :: DELTAY = DELTAX\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! P-velocity, S-velocity and density\n double precision, parameter :: cp = 3300.d0\n double precision, parameter :: cs = cp / 1.732d0\n double precision, parameter :: density = 2800.d0\n\n! total number of time steps\n! the time step is twice smaller for this fourth-order simulation,\n! therefore let us double the number of time steps to keep the same total duration\n integer, parameter :: NSTEP = 2000 * 2\n\n! time step in seconds\n! fourth-order in space and second-order in time finite-difference schemes\n! are less stable than second-order in space and second-order in time,\n! therefore let us divide the time step by 2\n double precision, parameter :: DELTAT = 2.d-3 / 2\n\n! parameters for the source\n double precision, parameter :: f0 = 7.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d7\n\n! source\n integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1\n integer, parameter :: JSOURCE = 2 * NY / 3 + 1\n double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX\n double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY\n! angle of source force clockwise with respect to vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 135.d0\n\n! receivers\n integer, parameter :: NREC = 2\n double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters\n double precision, parameter :: xfin = xsource ! last receiver x in meters\n double precision, parameter :: yfin = 300.d0 ! last receiver y in meters\n\n! display information on the screen from time to time\n! the time step is twice smaller for this fourth-order simulation,\n! therefore let us double the interval in time steps at which we display information\n integer, parameter :: IT_DISPLAY = 100 * 2\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n double precision, dimension(0:NX+1,0:NY+1) :: vx,vy,sigmaxx,sigmayy,sigmaxy,lambda,mu,rho\n\n! to interpolate material parameters at the right location in the staggered grid cell\n double precision lambda_half_x,mu_half_x,lambda_plus_two_mu_half_x,mu_half_y,rho_half_x_half_y\n\n! for evolution of total energy in the medium\n double precision epsilon_xx,epsilon_yy,epsilon_xy\n double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(0:NX+1,0:NY+1) :: &\n memory_dvx_dx, &\n memory_dvx_dy, &\n memory_dvy_dx, &\n memory_dvy_dy, &\n memory_dsigmaxx_dx, &\n memory_dsigmayy_dy, &\n memory_dsigmaxy_dx, &\n memory_dsigmaxy_dy\n\n double precision :: &\n value_dvx_dx, &\n value_dvx_dy, &\n value_dvy_dx, &\n value_dvy_dy, &\n value_dsigmaxx_dx, &\n value_dsigmayy_dy, &\n value_dsigmaxy_dx, &\n value_dsigmaxy_dy\n\n! 1D arrays for the damping profiles\n 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\n 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\n\n double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n! for the source\n double precision :: a,t,force_x,force_y,source_term\n\n! for receivers\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy\n\n integer :: i,j,it,irec\n\n double precision :: Courant_number,velocnorm\n\n!---\n!--- program starts here\n!---\n\n print *\n print *,'2D elastic finite-difference code in velocity and stress formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_y)\n\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *\n\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- left edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- right edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = NY*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- bottom edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- top edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! compute the Lame parameters and density\n do j = 1,NY\n do i = 1,NX\n rho(i,j) = density\n mu(i,j) = density*cs*cs\n lambda(i,j) = density*(cp*cp - 2.d0*cs*cs)\n enddo\n enddo\n\n! print position of the source\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *,'There are ',nrec,' receivers'\n print *\n xspacerec = (xfin-xdeb) / dble(NREC-1)\n yspacerec = (yfin-ydeb) / dble(NREC-1)\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number = cp * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2)\n print *,'Courant number is ',Courant_number\n print *\n if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable'\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')\n\n! initialize arrays\n vx(:,:) = ZERO\n vy(:,:) = ZERO\n sigmaxx(:,:) = ZERO\n sigmayy(:,:) = ZERO\n sigmaxy(:,:) = ZERO\n\n! PML\n memory_dvx_dx(:,:) = ZERO\n memory_dvx_dy(:,:) = ZERO\n memory_dvy_dx(:,:) = ZERO\n memory_dvy_dy(:,:) = ZERO\n memory_dsigmaxx_dx(:,:) = ZERO\n memory_dsigmayy_dy(:,:) = ZERO\n memory_dsigmaxy_dx(:,:) = ZERO\n memory_dsigmaxy_dy(:,:) = ZERO\n\n! initialize seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n\n! initialize total energy\n total_energy_kinetic(:) = ZERO\n total_energy_potential(:) = ZERO\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!------------------------------------------------------------\n! compute stress sigma and update memory variables for C-PML\n!------------------------------------------------------------\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda(i+1,j) + lambda(i,j))\n mu_half_x = 0.5d0 * (mu(i+1,j) + mu(i,j))\n lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x\n\n 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)\n 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)\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j)\n\n sigmaxx(i,j) = sigmaxx(i,j) + &\n (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) * DELTAT\n\n sigmayy(i,j) = sigmayy(i,j) + &\n (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) * DELTAT\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 2,NX\n\n! interpolate material parameters at the right location in the staggered grid cell\n mu_half_y = 0.5d0 * (mu(i,j+1) + mu(i,j))\n\n 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)\n 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)\n\n memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx\n memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy\n\n value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)\n value_dvx_dy = value_dvx_dy / K_y(j) + memory_dvx_dy(i,j)\n\n sigmaxy(i,j) = sigmaxy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy) * DELTAT\n\n enddo\n enddo\n\n!--------------------------------------------------------\n! compute velocity and update memory variables for C-PML\n!--------------------------------------------------------\n\n do j = 2,NY\n do i = 2,NX\n\n 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)\n 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)\n\n memory_dsigmaxx_dx(i,j) = b_x(i) * memory_dsigmaxx_dx(i,j) + a_x(i) * value_dsigmaxx_dx\n memory_dsigmaxy_dy(i,j) = b_y(j) * memory_dsigmaxy_dy(i,j) + a_y(j) * value_dsigmaxy_dy\n\n value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j)\n value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j)\n\n vx(i,j) = vx(i,j) + (value_dsigmaxx_dx + value_dsigmaxy_dy) * DELTAT / rho(i,j)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n 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)\n 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)\n\n memory_dsigmaxy_dx(i,j) = b_x_half(i) * memory_dsigmaxy_dx(i,j) + a_x_half(i) * value_dsigmaxy_dx\n memory_dsigmayy_dy(i,j) = b_y_half(j) * memory_dsigmayy_dy(i,j) + a_y_half(j) * value_dsigmayy_dy\n\n value_dsigmaxy_dx = value_dsigmaxy_dx / K_x_half(i) + memory_dsigmaxy_dx(i,j)\n value_dsigmayy_dy = value_dsigmayy_dy / K_y_half(j) + memory_dsigmayy_dy(i,j)\n\n vy(i,j) = vy(i,j) + (value_dsigmaxy_dx + value_dsigmayy_dy) * DELTAT / rho_half_x_half_y\n\n enddo\n enddo\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! source_term = factor * exp(-a*(t-t0)**2)\n\n! first derivative of a Gaussian\n source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n vx(i,j) = vx(i,j) + force_x * DELTAT / rho(i,j)\n vy(i,j) = vy(i,j) + force_y * DELTAT / rho_half_x_half_y\n\n! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers\n vx(1,:) = ZERO\n vx(NX,:) = ZERO\n\n vx(:,1) = ZERO\n vx(:,NY) = ZERO\n\n vy(1,:) = ZERO\n vy(NX,:) = ZERO\n\n vy(:,1) = ZERO\n vy(:,NY) = ZERO\n\n! store seismograms\n do irec = 1,NREC\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec))\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))\n enddo\n\n! compute total energy in the medium (without the PML layers)\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n! in principle we should use rho_half_x_half_y instead of rho for vy\n! in order to interpolate density at the right location in the staggered grid cell\n! but in a homogeneous medium we can safely ignore it\n total_energy_kinetic(it) = 0.5d0 * sum( &\n rho(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)*( &\n vx(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2 + &\n vy(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2))\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n! in principle we should interpolate the medium parameters at the right location\n! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n total_energy_potential(it) = ZERO\n do j = NPOINTS_PML, NY-NPOINTS_PML+1\n do i = NPOINTS_PML, NX-NPOINTS_PML+1\n epsilon_xx = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmaxx(i,j) - lambda(i,j) * &\n sigmayy(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j)))\n epsilon_yy = ((lambda(i,j) + 2.d0*mu(i,j)) * sigmayy(i,j) - lambda(i,j) * &\n sigmaxx(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j)))\n epsilon_xy = sigmaxy(i,j) / (2.d0 * mu(i,j))\n total_energy_potential(it) = total_energy_potential(it) + &\n 0.5d0 * (epsilon_xx * sigmaxx(i,j) + epsilon_yy * sigmayy(i,j) + 2.d0 * epsilon_xy * sigmaxy(i,j))\n enddo\n enddo\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n! print maximum of norm of velocity\n velocnorm = maxval(sqrt(vx**2 + vy**2))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',velocnorm\n print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n print *\n! check stability of the code, exit if unstable\n if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n call create_color_image(vx,NX+2,NY+2,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)\n call create_color_image(vy,NX+2,NY+2,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"cpml_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n open(unit=20,file='plot_comparison',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"compare_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:4 t ''Total energy CPML'' w l lc 1, &\n & \"../collino/energy.dat\" us 1:4 t ''Total energy Collino'' w l lc 2'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_CPML_2D_iso_fourth\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_CPML_2D_isotropic_second_order.f90", "content": "!\n! SEISMIC_CPML Version 1.1.1, November 2009.\n!\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional isotropic elastic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_2D_iso_second\n\n! 2D elastic finite-difference code in velocity and stress formulation\n! with Convolutional-PML (C-PML) absorbing conditions for an isotropic medium\n\n! Dimitri Komatitsch, University of Pau, France, April 2007.\n\n! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n!\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these\n! articles:\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 101\n integer, parameter :: NY = 641\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 10.d0\n double precision, parameter :: DELTAY = DELTAX\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! P-velocity, S-velocity and density\n double precision, parameter :: cp = 3300.d0\n double precision, parameter :: cs = cp / 1.732d0\n double precision, parameter :: density = 2800.d0\n\n! total number of time steps\n integer, parameter :: NSTEP = 2000\n\n! time step in seconds\n double precision, parameter :: DELTAT = 2.d-3\n\n! parameters for the source\n double precision, parameter :: f0 = 7.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d7\n\n! source\n integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1\n integer, parameter :: JSOURCE = 2 * NY / 3 + 1\n double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX\n double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY\n! angle of source force in degrees and clockwise, with respect to the vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 135.d0\n\n! receivers\n integer, parameter :: NREC = 2\n double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters\n double precision, parameter :: xfin = xsource ! last receiver x in meters\n double precision, parameter :: yfin = 300.d0 ! last receiver y in meters\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 100\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n double precision, dimension(NX,NY) :: vx,vy,sigma_xx,sigma_yy,sigma_xy,lambda,mu,rho\n\n! to interpolate material parameters at the right location in the staggered grid cell\n double precision lambda_half_x,mu_half_x,lambda_plus_two_mu_half_x,mu_half_y,rho_half_x_half_y\n\n! for evolution of total energy in the medium\n double precision :: epsilon_xx,epsilon_yy,epsilon_xy\n double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(NX,NY) :: &\n memory_dvx_dx, &\n memory_dvx_dy, &\n memory_dvy_dx, &\n memory_dvy_dy, &\n memory_dsigma_xx_dx, &\n memory_dsigma_yy_dy, &\n memory_dsigma_xy_dx, &\n memory_dsigma_xy_dy\n\n double precision :: &\n value_dvx_dx, &\n value_dvx_dy, &\n value_dvy_dx, &\n value_dvy_dy, &\n value_dsigma_xx_dx, &\n value_dsigma_yy_dy, &\n value_dsigma_xy_dx, &\n value_dsigma_xy_dy\n\n! 1D arrays for the damping profiles\n 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\n 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\n\n double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n! for the source\n double precision :: a,t,force_x,force_y,source_term\n\n! for receivers\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy\n\n integer :: i,j,it,irec\n\n double precision :: Courant_number,velocnorm\n\n!---\n!--- program starts here\n!---\n\n print *\n print *,'2D elastic finite-difference code in velocity and stress formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_y)\n\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *\n\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- left edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- right edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- bottom edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- top edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! compute the Lame parameters and density\n do j = 1,NY\n do i = 1,NX\n rho(i,j) = density\n mu(i,j) = density*cs*cs\n lambda(i,j) = density*(cp*cp - 2.d0*cs*cs)\n enddo\n enddo\n\n! print position of the source\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *,'There are ',nrec,' receivers'\n print *\n xspacerec = (xfin-xdeb) / dble(NREC-1)\n yspacerec = (yfin-ydeb) / dble(NREC-1)\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number = cp * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2)\n print *,'Courant number is ',Courant_number\n print *\n if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable'\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')\n\n! initialize arrays\n vx(:,:) = ZERO\n vy(:,:) = ZERO\n sigma_xx(:,:) = ZERO\n sigma_yy(:,:) = ZERO\n sigma_xy(:,:) = ZERO\n\n! PML\n memory_dvx_dx(:,:) = ZERO\n memory_dvx_dy(:,:) = ZERO\n memory_dvy_dx(:,:) = ZERO\n memory_dvy_dy(:,:) = ZERO\n memory_dsigma_xx_dx(:,:) = ZERO\n memory_dsigma_yy_dy(:,:) = ZERO\n memory_dsigma_xy_dx(:,:) = ZERO\n memory_dsigma_xy_dy(:,:) = ZERO\n\n! initialize seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n\n! initialize total energy\n total_energy_kinetic(:) = ZERO\n total_energy_potential(:) = ZERO\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!------------------------------------------------------------\n! compute stress sigma and update memory variables for C-PML\n!------------------------------------------------------------\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda(i+1,j) + lambda(i,j))\n mu_half_x = 0.5d0 * (mu(i+1,j) + mu(i,j))\n lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x\n\n value_dvx_dx = (vx(i+1,j) - vx(i,j)) / DELTAX\n value_dvy_dy = (vy(i,j) - vy(i,j-1)) / DELTAY\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j)\n\n sigma_xx(i,j) = sigma_xx(i,j) + &\n (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) * DELTAT\n\n sigma_yy(i,j) = sigma_yy(i,j) + &\n (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) * DELTAT\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 2,NX\n\n! interpolate material parameters at the right location in the staggered grid cell\n mu_half_y = 0.5d0 * (mu(i,j+1) + mu(i,j))\n\n value_dvy_dx = (vy(i,j) - vy(i-1,j)) / DELTAX\n value_dvx_dy = (vx(i,j+1) - vx(i,j)) / DELTAY\n\n memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx\n memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy\n\n value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)\n value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j)\n\n sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy) * DELTAT\n\n enddo\n enddo\n\n!--------------------------------------------------------\n! compute velocity and update memory variables for C-PML\n!--------------------------------------------------------\n\n do j = 2,NY\n do i = 2,NX\n\n value_dsigma_xx_dx = (sigma_xx(i,j) - sigma_xx(i-1,j)) / DELTAX\n value_dsigma_xy_dy = (sigma_xy(i,j) - sigma_xy(i,j-1)) / DELTAY\n\n memory_dsigma_xx_dx(i,j) = b_x(i) * memory_dsigma_xx_dx(i,j) + a_x(i) * value_dsigma_xx_dx\n memory_dsigma_xy_dy(i,j) = b_y(j) * memory_dsigma_xy_dy(i,j) + a_y(j) * value_dsigma_xy_dy\n\n value_dsigma_xx_dx = value_dsigma_xx_dx / K_x(i) + memory_dsigma_xx_dx(i,j)\n value_dsigma_xy_dy = value_dsigma_xy_dy / K_y(j) + memory_dsigma_xy_dy(i,j)\n\n vx(i,j) = vx(i,j) + (value_dsigma_xx_dx + value_dsigma_xy_dy) * DELTAT / rho(i,j)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n value_dsigma_xy_dx = (sigma_xy(i+1,j) - sigma_xy(i,j)) / DELTAX\n value_dsigma_yy_dy = (sigma_yy(i,j+1) - sigma_yy(i,j)) / DELTAY\n\n memory_dsigma_xy_dx(i,j) = b_x_half(i) * memory_dsigma_xy_dx(i,j) + a_x_half(i) * value_dsigma_xy_dx\n memory_dsigma_yy_dy(i,j) = b_y_half(j) * memory_dsigma_yy_dy(i,j) + a_y_half(j) * value_dsigma_yy_dy\n\n value_dsigma_xy_dx = value_dsigma_xy_dx / K_x_half(i) + memory_dsigma_xy_dx(i,j)\n value_dsigma_yy_dy = value_dsigma_yy_dy / K_y_half(j) + memory_dsigma_yy_dy(i,j)\n\n vy(i,j) = vy(i,j) + (value_dsigma_xy_dx + value_dsigma_yy_dy) * DELTAT / rho_half_x_half_y\n\n enddo\n enddo\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! source_term = factor * exp(-a*(t-t0)**2)\n\n! first derivative of a Gaussian\n source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n vx(i,j) = vx(i,j) + force_x * DELTAT / rho(i,j)\n vy(i,j) = vy(i,j) + force_y * DELTAT / rho_half_x_half_y\n\n! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers\n vx(1,:) = ZERO\n vx(NX,:) = ZERO\n\n vx(:,1) = ZERO\n vx(:,NY) = ZERO\n\n vy(1,:) = ZERO\n vy(NX,:) = ZERO\n\n vy(:,1) = ZERO\n vy(:,NY) = ZERO\n\n! store seismograms\n do irec = 1,NREC\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec))\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))\n enddo\n\n! compute total energy in the medium (without the PML layers)\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n! in principle we should use rho_half_x_half_y instead of rho for vy\n! in order to interpolate density at the right location in the staggered grid cell\n! but in a homogeneous medium we can safely ignore it\n total_energy_kinetic(it) = 0.5d0 * sum( &\n rho(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)*( &\n vx(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)**2 + &\n vy(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML)**2))\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n! in principle we should interpolate the medium parameters at the right location\n! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n total_energy_potential(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n epsilon_xx = ((lambda(i,j) + 2.d0*mu(i,j)) * sigma_xx(i,j) - lambda(i,j) * &\n sigma_yy(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j)))\n epsilon_yy = ((lambda(i,j) + 2.d0*mu(i,j)) * sigma_yy(i,j) - lambda(i,j) * &\n sigma_xx(i,j)) / (4.d0 * mu(i,j) * (lambda(i,j) + mu(i,j)))\n epsilon_xy = sigma_xy(i,j) / (2.d0 * mu(i,j))\n total_energy_potential(it) = total_energy_potential(it) + &\n 0.5d0 * (epsilon_xx * sigma_xx(i,j) + epsilon_yy * sigma_yy(i,j) + 2.d0 * epsilon_xy * sigma_xy(i,j))\n enddo\n enddo\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n! print maximum of norm of velocity\n velocnorm = maxval(sqrt(vx**2 + vy**2))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',velocnorm\n print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n print *\n! check stability of the code, exit if unstable\n if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)\n call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"cpml_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n open(unit=20,file='plot_comparison',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"compare_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:4 t ''Total energy CPML'' w l lc 1, &\n & \"../collino/energy.dat\" us 1:4 t ''Total energy Collino'' w l lc 2'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_CPML_2D_iso_second\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_CPML_2D_poroelastic_fourth_order.f90", "content": "!\n! SEISMIC_CPML Version 1.1.1, November 2009.\n!\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributors: Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr\n! and Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the poroelastic elastic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions and Biot model with and without viscous dissipation.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_2D_poroelastic_fourth\n\n! 2D poroelastic finite-difference code in velocity and stress formulation\n! with Convolution-PML (C-PML) absorbing conditions\n! with and without viscous dissipation\n\n! Roland Martin, University of Pau, France, October 2009.\n! based on the elastic code of Komatitsch and Martin, 2007.\n\n! The fourth-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n!\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these\n! articles:\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n! To display the results as color images in the selected 2D cut plane, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif\n! \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif\n! \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n\n! To display the 2D results as PostScript vector plots with small arrows, use:\n!\n! \" gs vect*.ps \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 140\n integer, parameter :: NY = 620\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 0.5D0\n double precision, parameter :: DELTAY = DELTAX\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_LEFT = .true.\n logical, parameter :: USE_PML_RIGHT = .true.\n logical, parameter :: USE_PML_BOTTOM = .true.\n logical, parameter :: USE_PML_TOP = .true.\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! heterogeneous model and height of the interface\n logical, parameter :: HETEROGENEOUS_MODEL = .true.\n double precision, parameter :: INTERFACE_HEIGHT =105.D0+NPOINTS_PML*DELTAY\n integer, parameter:: JINTERFACE=INT(INTERFACE_HEIGHT/DELTAY)+1\n double precision :: co,c1,c2,vtemp\n\n! model mud saturated with water, see article by Martin and Komatitsch\n double precision, parameter :: etaokappa_bottom=0.d0\n double precision, parameter :: rmu_bottom = 5.25D09\n double precision, parameter :: phi_bottom =0.25d0\n double precision, parameter :: a_bottom = 2.49d0\n double precision, parameter :: rhos_bottom = 2588.d0\n double precision, parameter :: rhof_bottom = 952.4d0\n double precision, parameter :: rho_bottom =2179.1d0\n double precision, parameter :: rsm_bottom =9486.d0\n double precision, parameter :: alpha_bottom=0.89d0\n double precision, parameter :: rbM_bottom =7.71d09\n double precision, parameter :: rlambdao_bottom = 6.2D08\n double precision, parameter :: rlambdac_bottom =rlambdao_bottom+alpha_bottom**2*rbM_bottom\n double precision, parameter :: ro11_b=rho_bottom+phi_bottom*rhof_bottom*(a_bottom-2.d0)\n double precision, parameter :: ro12_b=phi_bottom*rhof_bottom*(1.d0-a_bottom)\n double precision, parameter :: ro22_b=a_bottom*phi_bottom*rhof_bottom\n double precision, parameter :: lambda_b=rlambdao_bottom+rbM_bottom*(alpha_bottom-phi_bottom)**2\n double precision, parameter :: R_b=rbM_bottom*phi_bottom**2\n double precision, parameter :: ga_b=rbM_bottom*phi_bottom*(alpha_bottom-phi_bottom)\n double precision, parameter :: S_b=lambda_b+2*rmu_bottom\n double precision, parameter :: c1_b=S_b*R_b-ga_b**2\n double precision, parameter :: b1_b=-S_b*ro22_b-R_b*ro11_b+2*ga_b*ro12_b\n double precision, parameter :: a1_b=ro11_b*ro22_b-ro12_b**2\n double precision, parameter :: delta_b=b1_b**2-4.d0*a1_b*c1_b\n\n double precision:: cp_bottom\n double precision:: cps_bottom\n double precision:: cs_bottom\n\n double precision, parameter :: etaokappa_top=3.33D06\n double precision, parameter :: rmu_top = 2.4D09\n double precision, parameter :: phi_top =0.1d0\n double precision, parameter :: a_top = 2.42d0\n double precision, parameter :: rhos_top = 2250.d0\n double precision, parameter :: rhof_top = 1040.d0\n double precision, parameter :: rho_top = 2129.d0\n double precision, parameter :: rsm_top =25168.d0\n double precision, parameter :: alpha_top=0.58d0\n double precision, parameter :: rbM_top = 7.34d09\n double precision, parameter :: rlambdao_top =6.D08\n double precision, parameter :: rlambdac_top =rlambdao_top+alpha_top**2*rbM_top\n double precision, parameter :: ro11_t=rho_top+phi_top*rhof_top*(a_top-2.d0)\n double precision, parameter :: ro12_t=phi_top*rhof_top*(1.d0-a_top)\n double precision, parameter :: ro22_t=a_top*phi_top*rhof_top\n double precision, parameter :: lambda_t=rlambdao_top+rbM_top*(alpha_top-phi_top)**2\n double precision, parameter :: R_t=rbM_top*phi_top**2\n double precision, parameter :: ga_t=rbM_top*phi_top*(alpha_top-phi_top)\n double precision, parameter :: S_t=lambda_t+2*rmu_top\n double precision, parameter :: c1_t=S_t*R_t-ga_t**2\n double precision, parameter :: b1_t=-S_t*ro22_t-R_t*ro11_t+2*ga_t*ro12_t\n double precision, parameter :: a1_t=ro11_t*ro22_t-ro12_t**2\n double precision, parameter :: delta_t=b1_t**2-4.d0*a1_t*c1_t\n\n double precision:: cp_top\n double precision:: cps_top\n double precision:: cs_top\n\n! total number of time steps\n integer, parameter :: NSTEP = 100000\n\n! time step in seconds\n double precision, parameter :: DELTAT = 1.d-04\n\n! parameters for the source\n double precision, parameter :: f0 = 80.d0\n double precision, parameter :: t0 = 1.d0/f0\n double precision, parameter :: factor =1.d02\n\n! source\n integer, parameter :: ISOURCE = NX/2+1\n integer, parameter :: JSOURCE = NY/2 +1\n integer, parameter :: IDEB = NX / 2 + 1\n integer, parameter :: JDEB = NY / 2 + 1\n double precision, parameter :: xsource = DELTAX * ISOURCE\n double precision, parameter :: ysource = DELTAY * JSOURCE\n! angle of source force clockwise with respect to vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 0.d0\n\n! receivers\n integer, parameter :: NREC = 2\n double precision, parameter :: ydeb = NPOINTS_PML*DELTAY+10.D0 ! first receiver x in meters\n double precision, parameter :: yfin = NY*DELTAY-NPOINTS_PML*DELTAY-10.d0 ! first receiver x in meters\n double precision, parameter :: xdeb =xsource ! first receiver y in meters\n double precision, parameter :: xfin =xdeb ! first receiver y in meters\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 200\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n double precision, dimension(0:NX+1,0:NY+1) :: vx,vy,sigmaxx,sigma2,alp_sigma2,sigmayy,sigmaxy,vnorm\n double precision, dimension(0:NX+1,0:NY+1) :: vxf,vyf\n double precision, dimension(0:NX+1,0:NY+1) :: rho,rhof,rsm,rmu,rlambdac,rbM,alpha,etaokappa,rlambdao\n\n! to interpolate material parameters at the right location in the staggered grid cell\n double precision rho_half_x_half_y,rhof_half_x_half_y,rsm_half_x_half_y,etaokappa_half_x_half_y\n\n! for evolution of total energy in the medium\n double precision epsilon_xx,epsilon_yy,epsilon_xy\n double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n double precision c33_half_y\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! 2D arrays for the memory variables\n double precision, dimension(0:NX+1,0:NY+1) :: gamma11,gamma22\n double precision, dimension(0:NX+1,0:NY+1) :: gamma12_1\n double precision, dimension(0:NX+1,0:NY+1) :: xi_1,xi_2\n\n double precision, dimension(0:NX+1,0:NY+1) :: &\n memory_dx_vx1,memory_dx_vx2,memory_dy_vx,memory_dx_vy,memory_dy_vy1,memory_dy_vy2, &\n memory_dx_sigmaxx,memory_dx_sigmayy,memory_dx_sigmaxy, &\n memory_dx_sigma2vx,memory_dx_sigma2vxf,memory_dy_sigma2vy,memory_dy_sigma2vyf, &\n memory_dy_sigmaxx,memory_dy_sigmayy,memory_dy_sigmaxy\n\n! 1D arrays for the damping profiles\n 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\n 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\n\n double precision thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n double precision value_dx_vx1,value_dx_vx2,value_dx_vy,value_dx_sigmaxx,value_dx_sigmaxy\n double precision value_dy_vy1,value_dy_vy2,value_dy_vx,value_dy_sigmaxx,value_dy_sigmaxy\n double precision value_dx_sigma2vxf,value_dy_sigma2vyf\n\n! for the source\n double precision a,t,source_term\n\n! for receivers\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sisp\n\n integer i,j,it,irec\n\n double precision Courant_number_bottom,Courant_number_top,velocnorm_all,max_amplitude\n double precision Dispersion_number_bottom,Dispersion_number_top\n\n!---\n!--- program starts here\n!---\n cp_bottom=(-b1_b+sqrt(delta_b))/(2.d0*a1_b);\n cps_bottom=(-b1_b-sqrt(delta_b))/(2.d0*a1_b);\n cp_bottom=sqrt(cp_bottom)\n cps_bottom=sqrt(cps_bottom)\n cs_bottom=sqrt(rmu_bottom/(ro11_b-ro12_b**2/ro22_b))\n\n cp_top=(-b1_t+sqrt(delta_t))/(2.d0*a1_t);\n cps_top=(-b1_t-sqrt(delta_t))/(2.d0*a1_t);\n cp_top=sqrt(cp_top)\n cps_top=sqrt(cps_top)\n cs_top=sqrt(rmu_top/(ro11_t-ro12_t**2/ro22_t))\n\n print *,'cp_bottom= ',cp_bottom\n print *,'cps_bottom=',cps_bottom\n print *,'cs_bottom= ',cs_bottom\n print *,'cp_top= ',cp_top\n print *,'cps_top=',cps_top\n print *,'cs_top= ',cs_top\n\n print *,'rho_bottom= ',rho_bottom\n print *,'rsm_bottom= ',rsm_bottom\n print *,'rho_top= ',rho_top\n print *,'rsm_top= ',rsm_top\n print *,'rmu_bottom= ',rmu_bottom\n print *,'rlambdac_bottom= ',rlambdac_bottom\n print *,'rlambdao_bottom= ',rlambdao_bottom\n print *,'alpha_bottom= ',alpha_bottom\n print *,'rbM_bottom= ',rbM_bottom\n print *,'etaokappa_bottom= ',etaokappa_bottom\n print *,'rmu_top= ',rmu_top\n print *,'rlambdac_top= ',rlambdac_top\n print *,'rlambdao_top= ',rlambdao_top\n print *,'alpha_top= ',alpha_top\n print *,'rbM_top= ',rbM_top\n print *,'etaokappa_top= ',etaokappa_top\n\n print *, 'DELTAT CPML=', DELTAT\n print *,'2D poroelastic finite-difference code in velocity and stress formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n if (HETEROGENEOUS_MODEL) then\n d0_x = - (NPOWER + 1) * max(cp_bottom,cp_top) * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * max(cp_bottom,cp_top) * log(Rcoef) / (2.d0 * thickness_PML_y)\n else\n d0_x = - (NPOWER + 1) * cp_bottom * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp_bottom * log(Rcoef) / (2.d0 * thickness_PML_y)\n endif\n\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n\n d_x(:) = ZERO\n d_x_half_x(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half_y(:) = ZERO\n\n K_x(:) = 1.d0\n K_x_half_x(:) = 1.d0\n\n K_y(:) = 1.d0\n K_y_half_y(:) = 1.d0\n\n alpha_x(:) = ZERO\n alpha_x_half_x(:) = ZERO\n\n alpha_y(:) = ZERO\n alpha_y_half_y(:) = ZERO\n\n a_x(:) = ZERO\n a_x_half_x(:) = ZERO\n\n a_y(:) = ZERO\n a_y_half_y(:) = ZERO\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!!!! ---------- left edge\n if (USE_PML_LEFT) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!!!! ---------- right edge\n if (USE_PML_RIGHT) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half_x(i) < ZERO) alpha_x_half_x(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half_x(i) = exp(- (d_x_half_x(i) / K_x_half_x(i) + alpha_x_half_x(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) /&\n (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i)))\n if (abs(d_x_half_x(i)) > 1.d-6) a_x_half_x(i) = d_x_half_x(i)&\n * (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)))\n\n enddo\n\n!!!!!!!!!!!!! added Y damping profile\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = NY*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!!!! ---------- bottom edge\n if (USE_PML_BOTTOM) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!!!! ---------- top edge\n if (USE_PML_TOP) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n! if (alpha_y(j) < ZERO) alpha_y(j) = ZERO\n! if (alpha_y_half_y(j) < ZERO) alpha_y_half_y(j) = ZERO\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half_y(j) = exp(- (d_y_half_y(j) / K_y_half_y(j) + alpha_y_half_y(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) &\n / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j)))\n if (abs(d_y_half_y(j)) > 1.d-6) a_y_half_y(j) = d_y_half_y(j)&\n * (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)))\n\n enddo\n\n! compute the Lame parameters and density\n do j = 0,NY+1\n do i = 0,NX+1\n if (HETEROGENEOUS_MODEL .and. DELTAY*dble(j-1) > INTERFACE_HEIGHT) then\n rho(i,j)= rho_top\n rhof(i,j) = rhof_top\n rsm(i,j) = rsm_top\n rmu(i,j)= rmu_top\n rlambdac(i,j) = rlambdac_top\n rbM(i,j) = rbM_top\n alpha(i,j)=alpha_top\n etaokappa(i,j)=etaokappa_top\n rlambdao(i,j) = rlambdao_top\n else\n rho(i,j)= rho_bottom\n rhof(i,j) = rhof_bottom\n rsm(i,j) = rsm_bottom\n rmu(i,j)= rmu_bottom\n rlambdac(i,j) = rlambdac_bottom\n rbM(i,j) = rbM_bottom\n alpha(i,j)=alpha_bottom\n etaokappa(i,j)=etaokappa_bottom\n rlambdao(i,j) = rlambdao_bottom\n endif\n enddo\n enddo\n\n! print position of the source\n print *\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *\n print *,'There are ',nrec,' receivers'\n print *\n xspacerec = (xfin-xdeb) / dble(NREC-1)\n yspacerec = (yfin-ydeb) / dble(NREC-1)\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number_bottom = cp_bottom * DELTAT / min(DELTAX,DELTAY)\n Dispersion_number_bottom=min(cs_bottom,cps_bottom)/(2.5d0*f0*max(DELTAX,DELTAY))\n print *,'Courant number at the bottom is ',Courant_number_bottom\n print *,'Dispersion number at the bottom is ',Dispersion_number_bottom\n print *\n if (Courant_number_bottom > 1.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable'\n\n if (HETEROGENEOUS_MODEL) then\n Courant_number_top = max(cp_top,cp_bottom) * DELTAT / min(DELTAX,DELTAY)\n Dispersion_number_top=min(cs_top,cs_bottom,cps_bottom,cps_top)/(2.5d0*f0*max(DELTAX,DELTAY))\n print *,'Courant number at the top is ',Courant_number_top\n print *\n print *,'Dispersion number at the top is ',Dispersion_number_top\n if (Courant_number_top > 6.d0/7.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable'\n endif\n\n! suppress old files\n! call system('rm -f Vx_*.dat Vy_*.dat vect*.ps image*.pnm image*.gif')\n\n! initialize arrays\n vx(:,:) = ZERO\n vy(:,:) = ZERO\n sigmaxx(:,:) = ZERO\n sigmayy(:,:) = ZERO\n sigmaxy(:,:) = ZERO\n sigma2(:,:) = ZERO\n alp_sigma2(:,:) = ZERO\n gamma11(:,:)=0.d0\n gamma22(:,:)=0.d0\n gamma12_1(:,:)=0.d0\n gamma12_1(:,:)=0.d0\n xi_1(:,:)=0.d0\n xi_2(:,:)=0.d0\n vxf(:,:) = ZERO\n vyf(:,:) = ZERO\n\n memory_dx_vx1(:,:)=0.d0\n memory_dx_vx2(:,:)=0.d0\n memory_dy_vx(:,:)=0.d0\n memory_dx_vy(:,:)=0.d0\n memory_dy_vy1(:,:)=0.d0\n memory_dy_vy2(:,:)=0.d0\n memory_dx_sigmaxx(:,:)=0.d0\n memory_dx_sigmayy(:,:)=0.d0\n memory_dx_sigmaxy(:,:)=0.d0\n memory_dx_sigma2vx(:,:)=0.d0\n memory_dx_sigma2vxf(:,:)=0.d0\n memory_dy_sigmaxx(:,:)=0.d0\n memory_dy_sigmayy(:,:)=0.d0\n memory_dy_sigmaxy(:,:)=0.d0\n memory_dy_sigma2vy(:,:)=0.d0\n memory_dy_sigma2vyf(:,:)=0.d0\n\n! initialize seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n sisp(:,:) = ZERO\n\n! initialize total energy\n total_energy_kinetic(:) = ZERO\n total_energy_potential(:) = ZERO\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!----------------------\n! compute stress sigma\n!----------------------\n\n!-----------------------------------\n! update memory variables for C-PML\n!-----------------------------------\n\n do j = 2,NY\n do i = 1,NX-1\n\n! memory of sigmaxx\n 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\n 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\n\n memory_dx_sigmaxx(i,j) = b_x_half_x(i) * memory_dx_sigmaxx(i,j) + a_x_half_x(i) * value_dx_sigmaxx\n memory_dy_sigmaxx(i,j) = b_y(j) * memory_dy_sigmaxx(i,j) + a_y(j) * value_dy_sigmaxx\n\n\n gamma11(i,j) = gamma11(i,j)+DELTAT*(value_dx_sigmaxx / K_x_half_x(i) + memory_dx_sigmaxx(i,j))\n\n gamma22(i,j) = gamma22(i,j)+DELTAT*(value_dy_sigmaxx / K_y(j) + memory_dy_sigmaxx(i,j))\n\n! sigma2\n 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\n 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\n\n memory_dx_sigma2vxf(i,j) = b_x_half_x(i) * memory_dx_sigma2vxf(i,j) + a_x_half_x(i) * value_dx_sigma2vxf\n memory_dy_sigma2vyf(i,j) = b_y(j) * memory_dy_sigma2vyf(i,j) + a_y(j) * value_dy_sigma2vyf\n\n xi_1(i,j) = xi_1(i,j) -(value_dx_sigma2vxf/ K_x_half_x(i) + memory_dx_sigma2vxf(i,j))*DELTAT\n\n xi_2(i,j) = xi_2(i,j) -(value_dy_sigma2vyf/K_y(j)+memory_dy_sigma2vyf(i,j))*DELTAT\n\n 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))\n\n enddo\n enddo\n\n! add the source (point source located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n source_term = factor * exp(-a*(t-t0)**2)/(-2.d0*a)\n\n! first derivative of a Gaussian\n! source_term = factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n! source_term = factor *(t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n! add the source term\n sigma2(i,j) = sigma2(i,j) + source_term*rbM(i,j)\n\n do j = 1,NY-1\n do i = 2,NX\n\n! interpolate material parameters at the right location in the staggered grid cell\n c33_half_y = 2.d0/(1.d0/rmu(i,j)+1.d0/rmu(i,j+1))\n c33_half_y = rmu(i,j+1)\n\n 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\n 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\n\n memory_dx_sigmaxy(i,j) = b_x(i) * memory_dx_sigmaxy(i,j) + a_x(i) * value_dx_sigmaxy\n memory_dy_sigmaxy(i,j) = b_y_half_y(j) * memory_dy_sigmaxy(i,j) + a_y_half_y(j) * value_dy_sigmaxy\n\n sigmaxy(i,j) = sigmaxy(i,j) + &\n c33_half_y/1.d0 * (value_dx_sigmaxy / K_x(i) + memory_dx_sigmaxy(i,j) + &\n value_dy_sigmaxy / K_y(j) + memory_dy_sigmaxy(i,j)) * DELTAT\n\n enddo\n enddo\n\n do j = 2,NY\n do i = 1,NX-1\n 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)\n 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)\n enddo\n enddo\n\n!------------------\n! compute velocity\n!------------------\n\n!-----------------------------------\n! update memory variables for C-PML\n!-----------------------------------\n\n do j = 2,NY\n do i = 2,NX\n co=(rho(i,j)*rsm(i,j)-rhof(i,j)*rhof(i,j))/DELTAT\n c1=co+rho(i,j)*etaokappa(i,j)*0.5d0\n c2=co-rho(i,j)*etaokappa(i,j)*0.5d0\n vtemp=vxf(i,j)\n value_dx_vx1 = (27.d0*sigmaxx(i,j) - 27.d0*sigmaxx(i-1,j)&\n -sigmaxx(i+1,j)+sigmaxx(i-2,j)) / DELTAX/24.D0\n 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\n 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\n\n memory_dx_vx1(i,j) = b_x(i) * memory_dx_vx1(i,j) + a_x(i) * value_dx_vx1\n memory_dx_vx2(i,j) = b_x(i) * memory_dx_vx2(i,j) + a_x(i) * value_dx_vx2\n memory_dy_vx(i,j) = b_y(j) * memory_dy_vx(i,j) + a_y(j) * value_dy_vx\n\n vxf(i,j) = (c2*vxf(i,j) + &\n (-rhof(i,j)*(value_dx_vx1/ K_x(i) + memory_dx_vx1(i,j) &\n + value_dy_vx / K_y(j) + memory_dy_vx(i,j)) &\n -rho(i,j)*(value_dx_vx2/ K_x(i) + memory_dx_vx2(i,j)) &\n )) /c1\n\n vtemp=(vtemp+vxf(i,j))*0.5d0\n\n vx(i,j) = vx(i,j) + &\n (rsm(i,j)*(value_dx_vx1/ K_x(i) + memory_dx_vx1(i,j)+ &\n value_dy_vx / K_y(j) + memory_dy_vx(i,j))+&\n rhof(i,j)*(value_dx_vx2/ K_x(i) + memory_dx_vx2(i,j)) + &\n rhof(i,j)*etaokappa(i,j)*vtemp)&\n /co\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n rho_half_x_half_y = rho(i,j+1)\n rsm_half_x_half_y = rsm(i,j+1)\n rhof_half_x_half_y = rhof(i,j+1)\n etaokappa_half_x_half_y = etaokappa(i,j+1)\n\n co=(rho_half_x_half_y*rsm_half_x_half_y-rhof_half_x_half_y**2)/DELTAT\n c1=co+rho_half_x_half_y*etaokappa_half_x_half_y*0.5d0\n c2=co-rho_half_x_half_y*etaokappa_half_x_half_y*0.5d0\n vtemp=vyf(i,j)\n\n 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\n value_dy_vy1 = (27.d0*sigmayy(i,j+1)- 27.d0*sigmayy(i,j)&\n -sigmayy(i,j+2)+sigmayy(i,j-1)) / DELTAY/24.D0\n 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\n\n memory_dx_vy(i,j) = b_x_half_x(i) * memory_dx_vy(i,j) + a_x_half_x(i) * value_dx_vy\n memory_dy_vy1(i,j) = b_y_half_y(j) * memory_dy_vy1(i,j) + a_y_half_y(j) * value_dy_vy1\n memory_dy_vy2(i,j) = b_y_half_y(j) * memory_dy_vy2(i,j) + a_y_half_y(j) * value_dy_vy2\n\n vyf(i,j) = (c2*vyf(i,j) + &\n (-rhof_half_x_half_y*(value_dx_vy / K_x_half_x(i) + memory_dx_vy(i,j) &\n +value_dy_vy1 / K_y_half_y(j) + memory_dy_vy1(i,j))&\n -rho_half_x_half_y*(value_dy_vy2 / K_y_half_y(j) + memory_dy_vy2(i,j)))&\n ) /c1\n vtemp=(vtemp+vyf(i,j))*0.5d0\n\n vy(i,j) = vy(i,j) + &\n (rsm_half_x_half_y*(value_dx_vy / K_x_half_x(i) + memory_dx_vy(i,j)&\n+ value_dy_vy1 / K_y_half_y(j) + memory_dy_vy1(i,j))&\n+ rhof_half_x_half_y*(value_dy_vy2 / K_y_half_y(j) + memory_dy_vy2(i,j))&\n+ rhof_half_x_half_y*etaokappa_half_x_half_y*vtemp)&\n /co\n\n enddo\n enddo\n\n! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers\n vx(1,:) = ZERO\n vx(NX,:) = ZERO\n\n vx(:,1) = ZERO\n vx(:,NY) = ZERO\n\n vy(1,:) = ZERO\n vy(NX,:) = ZERO\n\n vy(:,1) = ZERO\n vy(:,NY) = ZERO\n\n vxf(1,:) = ZERO\n vxf(NX,:) = ZERO\n\n vxf(:,1) = ZERO\n vxf(:,NY) = ZERO\n\n vyf(1,:) = ZERO\n vyf(NX,:) = ZERO\n\n vyf(:,1) = ZERO\n vyf(:,NY) = ZERO\n\n! store seismograms\n do irec = 1,NREC\n! x component\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec))\n! y component\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))\n! fluid pressure\n sisp(it,irec) = sigma2(ix_rec(irec),iy_rec(irec))\n enddo\n\n! compute total energy\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n! in principle we should use rho_half_x_half_y instead of rho for vy\n! in order to interpolate density at the right location in the staggered grid cell\n! but in a homogeneous medium we can safely ignore it\n total_energy_kinetic(it) = 0.5d0 * &\nsum(rho(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)&\n*(vx(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2&\n+vy(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2))&\n*DELTAX * DELTAY+&\n0.5d0*sum(rsm(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)&\n*(vxf(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2&\n+vyf(NPOINTS_PML:NX-NPOINTS_PML+1,NPOINTS_PML:NY-NPOINTS_PML+1)**2))&\n*DELTAX*DELTAY\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n! in principle we should interpolate the medium parameters at the right location\n! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n total_energy_potential(it) = ZERO\n\n do j = NPOINTS_PML,NY-NPOINTS_PML+1\n do i = NPOINTS_PML,NX-NPOINTS_PML+1\n epsilon_xx = ((rlambdao(i,j) + 2.d0*rmu(i,j)) * sigmaxx(i,j) - rlambdao(i,j) * sigmayy(i,j)) / &\n (4.d0 * rmu(i,j) * (rlambdao(i,j) + rmu(i,j)))\n epsilon_yy = ((rlambdao(i,j) + 2.d0*rmu(i,j)) * sigmayy(i,j) - rlambdao(i,j) * sigmaxx(i,j)) / &\n (4.d0 * rmu(i,j) * (rlambdao(i,j) + rmu(i,j)))\n epsilon_xy = sigmaxy(i,j) / (2.d0 * rmu(i,j))\n total_energy_potential(it) = total_energy_potential(it) + &\n 0.5d0 * (epsilon_xx * sigmaxx(i,j) + epsilon_yy * sigmayy(i,j) + 2.d0 * epsilon_xy * sigmaxy(i,j)&\n +sigma2(i,j)**2/rbM(i,j)&\n +2.d0*rhof(i,j)*(vx(i,j)*vxf(i,j)+vy(i,j)*vyf(i,j)))*DELTAX * DELTAY\n enddo\n enddo\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n! print maximum of norm of velocity\n velocnorm_all = maxval(sqrt(vx(:,:)**2 + vy(:,:)**2))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',velocnorm_all\n print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n print *\n\n! check stability of the code, exit if unstable\n if (velocnorm_all > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n vnorm(:,:)=sqrt(vx(:,:)**2+vy(:,:)**2)\n\n call create_color_image(vx,NX+2,NY+2,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM, &\n USE_PML_TOP,1,max_amplitude,JINTERFACE)\n\n call create_color_image(vy,NX+2,NY+2,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM, &\n USE_PML_TOP,2,max_amplitude,JINTERFACE)\n\n! save temporary partial seismograms to monitor the behavior of the simulation\n! while it is running\n call write_seismograms(sisvx,sisvy,sisp,NSTEP,NREC,DELTAT,t0)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,sisp,NSTEP,NREC,DELTAT,t0)\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT), sngl(total_energy_kinetic(it) + total_energy_potential(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*) '# set xrange [0:7]'\n write(20,*) '# set yrange [-4:4.5]'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) '# set output \"cpml_total_energy.eps\"'\n write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*) '#set xrange [0:7]'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) '#set yrange [-4:4.5]'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) '#set yrange [-15:19]'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) '#set yrange [-12:16]'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) '#set yrange [-7:10]'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_CPML_2D_poroelastic_fourth\n\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,sisp,nt,nrec,DELTAT,t0)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT,t0\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n double precision sisp(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Z component\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n! fluid pressure\n do irec=1,nrec\n write(file_name,\"('Pf_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisp(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM,USE_PML_TOP,field_number,max_amplitude,JINTERFACE)\n\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.25d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_LEFT,USE_PML_RIGHT,USE_PML_BOTTOM,USE_PML_TOP\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer ix,iy,irec,JINTERFACE\n\n double precision max_amplitude\n\n character(len=100) file_name,system_command\n\n double precision normalized_value\n integer :: R, G, B\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i5.5,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i5.5,'_Vx.pnm image',i5.5,'_Vx.gif ; rm image',i5.5,'_Vx.pnm')\") it,it,it\n endif\n if (field_number == 2) then\n write(file_name,\"('image',i5.5,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i5.5,'_Vy.pnm image',i5.5,'_Vy.gif ; rm image',i5.5,'_Vy.pnm')\") it,it,it\n endif\n if (field_number == 3) then\n write(file_name,\"('image',i5.5,'_Vnorm.pnm')\") it\n write(system_command,\"('convert image',i5.5,'_Vnorm.pnm image',i5.5,'_Vnorm.gif ; rm image',i5.5,'_Vnorm.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_LEFT .and. ix == NPOINTS_PML) .or. &\n (USE_PML_RIGHT .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_BOTTOM .and. iy == NPOINTS_PML) .or. &\n (USE_PML_TOP .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n else if (iy == JINTERFACE) then\n R = 0\n G = 0\n B = 0\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to JPEG\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_CPML_2D_pressure_and_velocity_fourth_order_viscoacoustic.f90", "content": "!\n! SEISMIC_CPML Version 1.1.3, July 2018.\n!\n! Copyright CNRS, France.\n! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional heterogeneous isotropic viscoacoustic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_2D_viscoacoust_fourth\n\n! 2D finite-difference code in velocity and pressure formulation\n! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic viscoacoustic medium\n\n! Dimitri Komatitsch, CNRS, Marseille, July 2018.\n\n! A fourth-order spatially-staggered grid formulation is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x pressure\n! R_dot (viscoacoustic memory variable)\n!\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these\n! articles:\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! include viscoacoustic attenuation or not\n logical, parameter :: VISCOACOUSTIC_ATTENUATION = .true.\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 2001\n integer, parameter :: NY = 2001\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 1.5d0\n double precision, parameter :: DELTAY = DELTAX\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! P-velocity and density\n! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity)\n double precision, parameter :: cp_unrelaxed = 2000.d0\n double precision, parameter :: density = 2000.d0\n\n! Time step in seconds.\n! The CFL stability number for the O(2,2) algorithm is 1 / sqrt(2) = 0.707\n! i.e. one must choose cp * deltat / deltax < 0.707.\n! For the O(2,4) algorithm used here it is a bit more restrictive,\n! it is cp * deltat / deltax < 0.606 (see Levander 1988 eq (7)).\n! However this only ensures that the scheme is stable. To have a scheme that is both stable and accurate,\n! for O(2,4) some numerical tests show that one needs to take about half of that,\n! i.e. choose deltat so that cp * deltat / deltax is equal to about 0.30 or so. (or any value below; but not above).\n! Since the time scheme is only second order, this also depends on how many time steps are performed in total\n! (i.e. what the value of NSTEP below is); for large values of NSTEP, of course numerical errors will start to accumulate.\n double precision, parameter :: DELTAT = 2.2d-4\n\n! total number of time steps\n integer, parameter :: NSTEP = 3600\n\n! parameters for the source\n double precision, parameter :: f0 = 35.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d0\n\n! source (in pressure, thus at a gridpoint rather than half a grid cell away)\n double precision, parameter :: xsource = 1500.d0\n double precision, parameter :: ysource = 1500.d0\n integer, parameter :: ISOURCE = xsource / DELTAX + 1\n integer, parameter :: JSOURCE = ysource / DELTAY + 1\n\n! receivers\n integer, parameter :: NREC = 1\n!! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point\n double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters\n double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters\n double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters\n\n! to compute energy curves for the whole medium (optional, but useful e.g. to produce\n! energy variation figures for articles); but expensive option, thus off by default\n logical, parameter :: COMPUTE_ENERGY = .false.\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 200\n\n! compute some constants once and for all for the fourth-order spatial scheme\n! These coefficients are given for instance by Levander, Geophysics, vol. 53(11), p. 1436, equation (A-2)\n double precision, parameter :: NINE_OVER_8_DELTAX = 9.d0 / (8.d0*DELTAX)\n double precision, parameter :: NINE_OVER_8_DELTAY = 9.d0 / (8.d0*DELTAY)\n double precision, parameter :: ONE_OVER_24_DELTAX = 1.d0 / (24.d0*DELTAX)\n double precision, parameter :: ONE_OVER_24_DELTAY = 1.d0 / (24.d0*DELTAY)\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n! in order to be able to use a fourth-order spatial operator on the edges of the model\n! here we define the arrays with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case\n double precision, dimension(0:NX+1,0:NY+1) :: vx,vy,pressure,kappa_unrelaxed,rho\n\n! to interpolate material parameters or velocity at the right location in the staggered grid cell\n double precision kappa_half_x,rho_half_x_half_y,vy_interpolated\n\n! for evolution of total energy in the medium\n double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(NX,NY) :: &\n memory_dvx_dx, &\n memory_dvx_dy, &\n memory_dvy_dx, &\n memory_dvy_dy, &\n memory_dpressure_dx, &\n memory_dpressure_dy\n\n double precision :: &\n value_dvx_dx, &\n value_dvy_dy, &\n value_dpressure_dx, &\n value_dpressure_dy\n\n! 1D arrays for the damping profiles\n 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, &\n one_over_K_x,one_over_K_x_half\n 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, &\n one_over_K_y,one_over_K_y_half\n\n double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n! for the source\n double precision :: a,t,pressure_source_term\n\n! for receivers\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n integer :: myNREC\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sispressure\n\n integer :: i,j,it,irec\n\n double precision :: Courant_number,velocnorm,pressurenorm\n\n! for attenuation (viscoacousticity)\n\n! attenuation quality factor Qkappa to use\n double precision, parameter :: QKappa = 65.d0\n\n! number of Zener standard linear solids in parallel\n integer, parameter :: N_SLS = 3\n\n! attenuation constants\n double precision, dimension(N_SLS) :: tau_epsilon_kappa,tau_sigma_kappa,one_over_tau_sigma_kappa, &\n HALF_DELTAT_over_tau_sigma_kappa,multiplication_factor_tau_sigma_kappa,DELTAT_delta_relaxed_over_tau_sigma_without_Kappa\n\n! memory variable for attenuation\n double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_dot,memory_variable_R_dot_old\n integer :: i_sls\n double precision :: sum_of_memory_variables_kappa\n\n! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band\n double precision :: f_min_attenuation,f_max_attenuation\n\n!---\n!--- program starts here\n!---\n\n print *\n print *,'2D viscoacoustic finite-difference code in velocity and pressure formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n! for attenuation (viscoacousticity)\n if (VISCOACOUSTIC_ATTENUATION) then\n\n print *,'QKappa quality factor used for attenuation = ',QKappa\n print *,'Number of Zener standard linear solids used to mimic the viscoacoustic behavior (N_SLS) = ',N_SLS\n print *\n\n! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band\n! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0)\n f_min_attenuation = exp(log(f0)-log(12.d0)/2.d0)\n f_max_attenuation = 12.d0 * f_min_attenuation\n\n! call the SolvOpt() nonlinear optimization routine to compute the tau_epsilon and tau_sigma values from a given Q factor\n call compute_attenuation_coeffs(N_SLS,QKappa,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_kappa,tau_sigma_kappa)\n\n else\n\n! dummy values in the non-dissipative case\n tau_epsilon_kappa(:) = 1.d0\n tau_sigma_kappa(:) = 1.d0\n\n endif\n\n! precompute the inverse once and for all, to save computation time in the time loop below\n! (on computers, a multiplication is very significantly cheaper than a division)\n one_over_tau_sigma_kappa(:) = 1.d0 / tau_sigma_kappa(:)\n HALF_DELTAT_over_tau_sigma_kappa(:) = 0.5d0 * DELTAT / tau_sigma_kappa(:)\n multiplication_factor_tau_sigma_kappa(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_kappa(:))\n\n! compute DELTAT_delta_relaxed_over_tau_sigma_without_Kappa, which is a term\n! needed to compute the evolution of the viscoacoustic memory variables\n if (VISCOACOUSTIC_ATTENUATION) then\n DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = (DELTAT / sum(tau_epsilon_kappa(:) / tau_sigma_kappa(:))) * &\n (tau_epsilon_kappa(:)/tau_sigma_kappa(:) - 1.d0) / tau_sigma_kappa(:)\n else\n DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = ZERO\n endif\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y)\n\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *\n\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- left edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- right edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- bottom edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- top edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! precompute the inverse once and for all, to save computation time in the time loop below\n! (on computers, a multiplication is very significantly cheaper than a division)\n one_over_K_x(:) = 1.d0 / K_x(:)\n one_over_K_x_half(:) = 1.d0 / K_x_half(:)\n one_over_K_y(:) = 1.d0 / K_y(:)\n one_over_K_y_half(:) = 1.d0 / K_y_half(:)\n\n! compute the Lame parameter and density\n do j = 1,NY\n do i = 1,NX\n rho(i,j) = density\n kappa_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed\n enddo\n enddo\n\n! print position of the source\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *,'There are ',nrec,' receivers'\n print *\n if (NREC > 1) then\n! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1\n myNREC = NREC\n xspacerec = (xfin-xdeb) / dble(myNREC-1)\n yspacerec = (yfin-ydeb) / dble(myNREC-1)\n else\n xspacerec = 0.d0\n yspacerec = 0.d0\n endif\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant, K. O. Friedrichs and H. Lewy (1928)\n! For this O(2,4) scheme, when DELTAX == DELTAY the Courant number is given by Levander, Geophysics, vol. 53(11), p. 1427,\n! 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,\n! 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.\n if (DELTAX == DELTAY) then\n Courant_number = cp_unrelaxed * DELTAT / DELTAX\n print *,'Courant number is ',Courant_number\n print *,' (the maximum possible value is 0.606; in practice for accuracy reasons a value not larger than 0.30 is recommended)'\n print *\n if (Courant_number > 0.606) stop 'time step is too large, simulation will be unstable'\n endif\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')\n\n! initialize arrays\n vx(:,:) = ZERO\n vy(:,:) = ZERO\n pressure(:,:) = ZERO\n memory_variable_R_dot(:,:,:) = ZERO\n memory_variable_R_dot_old(:,:,:) = ZERO\n\n! PML\n memory_dvx_dx(:,:) = ZERO\n memory_dvx_dy(:,:) = ZERO\n memory_dvy_dx(:,:) = ZERO\n memory_dvy_dy(:,:) = ZERO\n memory_dpressure_dx(:,:) = ZERO\n memory_dpressure_dy(:,:) = ZERO\n\n! initialize seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n sispressure(:,:) = ZERO\n\n! initialize total energy\n total_energy_kinetic(:) = ZERO\n total_energy_potential(:) = ZERO\n\n if (VISCOACOUSTIC_ATTENUATION) then\n print *,'adding VISCOACOUSTIC_ATTENUATION (i.e., running a viscoacoustic simulation)'\n else\n print *,'not adding VISCOACOUSTIC_ATTENUATION (i.e., running a purely acoustic simulation)'\n endif\n print *\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!-----------------------------------------------------------------------\n! compute pressure and update memory variables for C-PML\n! also update memory variables for viscoacoustic attenuation if needed\n!-----------------------------------------------------------------------\n\n! we purposely leave this \"if\" test outside of the loops to make sure the compiler can optimize these loops;\n! with an \"if\" test inside most compilers cannot\n if (.not. VISCOACOUSTIC_ATTENUATION) then\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j))\n\n 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\n 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\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j)\n\n pressure(i,j) = pressure(i,j) - kappa_half_x * (value_dvx_dx + value_dvy_dy) * DELTAT\n\n enddo\n enddo\n\n else\n\n! the present becomes the past for the memory variables.\n! in C or C++ we could replace this with an exchange of pointers on the arrays\n! in order to avoid a memory copy of the whole array.\n memory_variable_R_dot_old(:,:,:) = memory_variable_R_dot(:,:,:)\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j))\n\n 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\n 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\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j)\n\n! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following\n! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here\n sum_of_memory_variables_kappa = 0.d0\n do i_sls = 1,N_SLS\n! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n memory_variable_R_dot(i,j,i_sls) = (memory_variable_R_dot_old(i,j,i_sls) + &\n (value_dvx_dx + value_dvy_dy) * kappa_unrelaxed(i,j) * DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(i_sls) - &\n memory_variable_R_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_kappa(i_sls)) &\n * multiplication_factor_tau_sigma_kappa(i_sls)\n\n sum_of_memory_variables_kappa = sum_of_memory_variables_kappa + &\n memory_variable_R_dot(i,j,i_sls) + memory_variable_R_dot_old(i,j,i_sls)\n enddo\n\n pressure(i,j) = pressure(i,j) + (- kappa_half_x * (value_dvx_dx + value_dvy_dy) + &\n! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n 0.5d0 * sum_of_memory_variables_kappa) * DELTAT\n\n enddo\n enddo\n\n endif\n\n! add the source (pressure located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! pressure_source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a)\n\n! first derivative of a Gaussian\n pressure_source_term = factor * (t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! pressure_source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n! to get the right amplitude of the force, we need to divide by the area of a grid cell\n! (we checked that against the analytical solution in a homogeneous medium for a pressure source)\n pressure_source_term = pressure_source_term / (DELTAX * DELTAY)\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n! the pressure source is added to d(pressure)/dt in this split pressure / velocity scheme\n! and that is why we need to select the first derivative of a Gaussian as a source time wavelet\n! above instead of a Ricker (i.e. a second derivative) added to d2(pressure)/dt2\n! as in the unsplit equation written in pressure only.\n! Since the formula is d(pressure)/dt = (pressure_new - pressure_old) / DELTAT = pressure_source_term\n! we also need to multiply by DELTAT here to avoid having an amplitude of the seismogram\n! that varies when one changes the time step, i.e. we write:\n! pressure_new = pressure_old + pressure_source_term * DELTAT at the source grid point\n pressure(i,j) = pressure(i,j) + pressure_source_term * DELTAT\n\n!--------------------------------------------------------\n! compute velocity and update memory variables for C-PML\n!--------------------------------------------------------\n\n do j = 2,NY\n do i = 2,NX\n\n value_dpressure_dx = (pressure(i,j) - pressure(i-1,j)) * NINE_OVER_8_DELTAX + &\n (pressure(i-2,j) - pressure(i+1,j)) * ONE_OVER_24_DELTAX\n\n memory_dpressure_dx(i,j) = b_x(i) * memory_dpressure_dx(i,j) + a_x(i) * value_dpressure_dx\n\n value_dpressure_dx = value_dpressure_dx * one_over_K_x(i) + memory_dpressure_dx(i,j)\n\n vx(i,j) = vx(i,j) - value_dpressure_dx * DELTAT / rho(i,j)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n value_dpressure_dy = (pressure(i,j+1) - pressure(i,j)) * NINE_OVER_8_DELTAY + &\n (pressure(i,j-1) - pressure(i,j+2)) * ONE_OVER_24_DELTAY\n\n memory_dpressure_dy(i,j) = b_y_half(j) * memory_dpressure_dy(i,j) + a_y_half(j) * value_dpressure_dy\n\n value_dpressure_dy = value_dpressure_dy * one_over_K_y_half(j) + memory_dpressure_dy(i,j)\n\n vy(i,j) = vy(i,j) - value_dpressure_dy * DELTAT / rho_half_x_half_y\n\n enddo\n enddo\n\n! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers\n vx(1,:) = ZERO\n vx(NX,:) = ZERO\n\n vx(:,1) = ZERO\n vx(:,NY) = ZERO\n\n vy(1,:) = ZERO\n vy(NX,:) = ZERO\n\n vy(:,1) = ZERO\n vy(:,NY) = ZERO\n\n! store seismograms\n do irec = 1,NREC\n\n! beware here that the two components of the velocity vector are not defined at the same point\n! in a staggered grid, and thus the two components of the velocity vector are recorded at slightly different locations,\n! vy is staggered by half a grid cell along X and along Y with respect to vx\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec))\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))\n sispressure(it,irec) = pressure(ix_rec(irec),iy_rec(irec))\n enddo\n\n! compute total energy in the medium (without the PML layers)\n if (COMPUTE_ENERGY) then\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n total_energy_kinetic(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n! interpolate vy back at the location of vx, to be able to use both at the same location\n vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1))\n total_energy_kinetic(it) = total_energy_kinetic(it) + 0.5d0 * rho(i,j) * (vx(i,j)**2 + vy_interpolated**2)\n enddo\n enddo\n\n! add potential energy, defined as 1/2 pressure^2 / Kappa\n total_energy_potential(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n! interpolate material parameters at the right location in the staggered grid cell\n kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j))\n total_energy_potential(it) = total_energy_potential(it) + 0.5d0 * pressure(i,j)**2 / kappa_half_x\n enddo\n enddo\n\n endif\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n! print maximum of pressure and of norm of velocity\n pressurenorm = maxval(abs(pressure))\n velocnorm = maxval(sqrt(vx**2 + vy**2))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max absolute value of pressure = ',pressurenorm\n print *,'Max norm velocity vector V (m/s) = ',velocnorm\n if (COMPUTE_ENERGY) print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n print *\n! check stability of the code, exit if unstable\n if (pressurenorm > STABILITY_THRESHOLD .or. velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n! call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)\n! call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)\n call create_color_image(pressure,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,3)\n\n! save the part of the seismograms that has been computed so far, so that users can monitor the progress of the simulation\n call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)\n\n if (COMPUTE_ENERGY) then\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"cpml_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n endif\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_CPML_2D_viscoacoust_fourth\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,sispressure,nt,nrec,DELTAT,t0)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT,t0\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n double precision sispressure(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! pressure\n do irec=1,nrec\n write(file_name,\"('pressure_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n! in the scheme of eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n! pressure is defined at time t + DELTAT/2, i.e. staggered in time with respect to velocity.\n! Here we must thus take this shift of DELTAT/2 into account to save the seismograms at the right time\n write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec))\n enddo\n close(11)\n enddo\n\n! X component of velocity\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component of velocity\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n! in order to be able to use a fourth-order spatial operator on the edges of the model\n! here we define the array with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case\n double precision, dimension(0:NX+1,0:NY+1) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n else if (field_number == 3) then\n write(file_name,\"('image',i6.6,'_pressure.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')\") &\n it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n!\n!---- include the SolvOpt() routine that is used to compute the tau_epsilon and tau_sigma values from a given Q attenuation factor\n!\n\ninclude \"attenuation_model_with_SolvOpt.f90\"\n\n" }, { "path": "seismic_CPML_2D_pressure_and_velocity_second_order_viscoacoustic.f90", "content": "!\n! SEISMIC_CPML Version 1.1.3, July 2018.\n!\n! Copyright CNRS, France.\n! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional heterogeneous isotropic viscoacoustic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_2D_viscoacoust_second\n\n! 2D finite-difference code in velocity and pressure formulation\n! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic viscoacoustic medium\n\n! Dimitri Komatitsch, CNRS, Marseille, July 2018.\n\n! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x pressure\n! R_dot (viscoacoustic memory variable)\n!\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these\n! articles:\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! include viscoacoustic attenuation or not\n logical, parameter :: VISCOACOUSTIC_ATTENUATION = .true.\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 2001\n integer, parameter :: NY = 2001\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 1.5d0\n double precision, parameter :: DELTAY = DELTAX\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! P-velocity and density\n! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity)\n double precision, parameter :: cp_unrelaxed = 2000.d0\n double precision, parameter :: density = 2000.d0\n\n! Time step in seconds.\n! The CFL stability number for the O(2,2) algorithm is 1 / sqrt(2) = 0.707\n! i.e. one must choose cp * deltat / deltax < 0.707.\n! However this only ensures that the scheme is stable. To have a scheme that is both stable and accurate,\n! some numerical tests show that one needs to take about half of that,\n! i.e. choose deltat so that cp * deltat / deltax is equal to about 0.30 or so. (or any value below; but not above).\n! Since the time scheme is only second order, this also depends on how many time steps are performed in total\n! (i.e. what the value of NSTEP below is); for large values of NSTEP, of course numerical errors will start to accumulate.\n double precision, parameter :: DELTAT = 2.2d-4\n\n! total number of time steps\n integer, parameter :: NSTEP = 3600\n\n! parameters for the source\n double precision, parameter :: f0 = 35.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d0\n\n! source (in pressure, thus at a gridpoint rather than half a grid cell away)\n double precision, parameter :: xsource = 1500.d0\n double precision, parameter :: ysource = 1500.d0\n integer, parameter :: ISOURCE = xsource / DELTAX + 1\n integer, parameter :: JSOURCE = ysource / DELTAY + 1\n\n! receivers\n integer, parameter :: NREC = 1\n!! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point\n double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters\n double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters\n double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters\n\n! to compute energy curves for the whole medium (optional, but useful e.g. to produce\n! energy variation figures for articles); but expensive option, thus off by default\n logical, parameter :: COMPUTE_ENERGY = .false.\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 200\n\n! compute some constants once and for all for the second-order spatial scheme\n double precision, parameter :: ONE_OVER_DELTAX = 1.d0 / DELTAX\n double precision, parameter :: ONE_OVER_DELTAY = 1.d0 / DELTAY\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n double precision, dimension(NX,NY) :: vx,vy,pressure,kappa_unrelaxed,rho\n\n! to interpolate material parameters or velocity at the right location in the staggered grid cell\n double precision kappa_half_x,rho_half_x_half_y,vy_interpolated\n\n! for evolution of total energy in the medium\n double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(NX,NY) :: &\n memory_dvx_dx, &\n memory_dvx_dy, &\n memory_dvy_dx, &\n memory_dvy_dy, &\n memory_dpressure_dx, &\n memory_dpressure_dy\n\n double precision :: &\n value_dvx_dx, &\n value_dvy_dy, &\n value_dpressure_dx, &\n value_dpressure_dy\n\n! 1D arrays for the damping profiles\n 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, &\n one_over_K_x,one_over_K_x_half\n 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, &\n one_over_K_y,one_over_K_y_half\n\n double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n! for the source\n double precision :: a,t,pressure_source_term\n\n! for receivers\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n integer :: myNREC\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sispressure\n\n integer :: i,j,it,irec\n\n double precision :: Courant_number,velocnorm,pressurenorm\n\n! for attenuation (viscoacousticity)\n\n! attenuation quality factor Qkappa to use\n double precision, parameter :: QKappa = 65.d0\n\n! number of Zener standard linear solids in parallel\n integer, parameter :: N_SLS = 3\n\n! attenuation constants\n double precision, dimension(N_SLS) :: tau_epsilon_kappa,tau_sigma_kappa,one_over_tau_sigma_kappa, &\n HALF_DELTAT_over_tau_sigma_kappa,multiplication_factor_tau_sigma_kappa,DELTAT_delta_relaxed_over_tau_sigma_without_Kappa\n\n! memory variable for attenuation\n double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_dot,memory_variable_R_dot_old\n integer :: i_sls\n double precision :: sum_of_memory_variables_kappa\n\n! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band\n double precision :: f_min_attenuation,f_max_attenuation\n\n!---\n!--- program starts here\n!---\n\n print *\n print *,'2D viscoacoustic finite-difference code in velocity and pressure formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n! for attenuation (viscoacousticity)\n if (VISCOACOUSTIC_ATTENUATION) then\n\n print *,'QKappa quality factor used for attenuation = ',QKappa\n print *,'Number of Zener standard linear solids used to mimic the viscoacoustic behavior (N_SLS) = ',N_SLS\n print *\n\n! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band\n! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0)\n f_min_attenuation = exp(log(f0)-log(12.d0)/2.d0)\n f_max_attenuation = 12.d0 * f_min_attenuation\n\n! call the SolvOpt() nonlinear optimization routine to compute the tau_epsilon and tau_sigma values from a given Q factor\n call compute_attenuation_coeffs(N_SLS,QKappa,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_kappa,tau_sigma_kappa)\n\n else\n\n! dummy values in the non-dissipative case\n tau_epsilon_kappa(:) = 1.d0\n tau_sigma_kappa(:) = 1.d0\n\n endif\n\n! precompute the inverse once and for all, to save computation time in the time loop below\n! (on computers, a multiplication is very significantly cheaper than a division)\n one_over_tau_sigma_kappa(:) = 1.d0 / tau_sigma_kappa(:)\n HALF_DELTAT_over_tau_sigma_kappa(:) = 0.5d0 * DELTAT / tau_sigma_kappa(:)\n multiplication_factor_tau_sigma_kappa(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_kappa(:))\n\n! compute DELTAT_delta_relaxed_over_tau_sigma_without_Kappa, which is a term\n! needed to compute the evolution of the viscoacoustic memory variables\n if (VISCOACOUSTIC_ATTENUATION) then\n DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = (DELTAT / sum(tau_epsilon_kappa(:) / tau_sigma_kappa(:))) * &\n (tau_epsilon_kappa(:)/tau_sigma_kappa(:) - 1.d0) / tau_sigma_kappa(:)\n else\n DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = ZERO\n endif\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y)\n\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *\n\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- left edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- right edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- bottom edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- top edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! precompute the inverse once and for all, to save computation time in the time loop below\n! (on computers, a multiplication is very significantly cheaper than a division)\n one_over_K_x(:) = 1.d0 / K_x(:)\n one_over_K_x_half(:) = 1.d0 / K_x_half(:)\n one_over_K_y(:) = 1.d0 / K_y(:)\n one_over_K_y_half(:) = 1.d0 / K_y_half(:)\n\n! compute the Lame parameter and density\n do j = 1,NY\n do i = 1,NX\n rho(i,j) = density\n kappa_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed\n enddo\n enddo\n\n! print position of the source\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *,'There are ',nrec,' receivers'\n print *\n if (NREC > 1) then\n! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1\n myNREC = NREC\n xspacerec = (xfin-xdeb) / dble(myNREC-1)\n yspacerec = (yfin-ydeb) / dble(myNREC-1)\n else\n xspacerec = 0.d0\n yspacerec = 0.d0\n endif\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant, K. O. Friedrichs and H. Lewy (1928)\n! For this O(2,2) scheme, when DELTAX == DELTAY the Courant number is 1/sqrt(2) = 0.707\n if (DELTAX == DELTAY) then\n Courant_number = cp_unrelaxed * DELTAT / DELTAX\n print *,'Courant number is ',Courant_number\n print *,' (the maximum possible value is 1/sqrt(2) = 0.707; &\n &in practice for accuracy reasons a value not larger than 0.30 is recommended)'\n print *\n if (Courant_number > 1.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable'\n endif\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')\n\n! initialize arrays\n vx(:,:) = ZERO\n vy(:,:) = ZERO\n pressure(:,:) = ZERO\n memory_variable_R_dot(:,:,:) = ZERO\n memory_variable_R_dot_old(:,:,:) = ZERO\n\n! PML\n memory_dvx_dx(:,:) = ZERO\n memory_dvx_dy(:,:) = ZERO\n memory_dvy_dx(:,:) = ZERO\n memory_dvy_dy(:,:) = ZERO\n memory_dpressure_dx(:,:) = ZERO\n memory_dpressure_dy(:,:) = ZERO\n\n! initialize seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n sispressure(:,:) = ZERO\n\n! initialize total energy\n total_energy_kinetic(:) = ZERO\n total_energy_potential(:) = ZERO\n\n if (VISCOACOUSTIC_ATTENUATION) then\n print *,'adding VISCOACOUSTIC_ATTENUATION (i.e., running a viscoacoustic simulation)'\n else\n print *,'not adding VISCOACOUSTIC_ATTENUATION (i.e., running a purely acoustic simulation)'\n endif\n print *\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!-----------------------------------------------------------------------\n! compute pressure and update memory variables for C-PML\n! also update memory variables for viscoacoustic attenuation if needed\n!-----------------------------------------------------------------------\n\n! we purposely leave this \"if\" test outside of the loops to make sure the compiler can optimize these loops;\n! with an \"if\" test inside most compilers cannot\n if (.not. VISCOACOUSTIC_ATTENUATION) then\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j))\n\n value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX\n value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_DELTAY\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j)\n\n pressure(i,j) = pressure(i,j) - kappa_half_x * (value_dvx_dx + value_dvy_dy) * DELTAT\n\n enddo\n enddo\n\n else\n\n! the present becomes the past for the memory variables.\n! in C or C++ we could replace this with an exchange of pointers on the arrays\n! in order to avoid a memory copy of the whole array.\n memory_variable_R_dot_old(:,:,:) = memory_variable_R_dot(:,:,:)\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j))\n\n value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX\n value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_DELTAY\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j)\n\n! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following\n! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here\n sum_of_memory_variables_kappa = 0.d0\n do i_sls = 1,N_SLS\n! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n memory_variable_R_dot(i,j,i_sls) = (memory_variable_R_dot_old(i,j,i_sls) + &\n (value_dvx_dx + value_dvy_dy) * kappa_unrelaxed(i,j) * DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(i_sls) - &\n memory_variable_R_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_kappa(i_sls)) &\n * multiplication_factor_tau_sigma_kappa(i_sls)\n\n sum_of_memory_variables_kappa = sum_of_memory_variables_kappa + &\n memory_variable_R_dot(i,j,i_sls) + memory_variable_R_dot_old(i,j,i_sls)\n enddo\n\n pressure(i,j) = pressure(i,j) + (- kappa_half_x * (value_dvx_dx + value_dvy_dy) + &\n! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n 0.5d0 * sum_of_memory_variables_kappa) * DELTAT\n\n enddo\n enddo\n\n endif\n\n! add the source (pressure located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! pressure_source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a)\n\n! first derivative of a Gaussian\n pressure_source_term = factor * (t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! pressure_source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n! to get the right amplitude of the force, we need to divide by the area of a grid cell\n! (we checked that against the analytical solution in a homogeneous medium for a pressure source)\n pressure_source_term = pressure_source_term / (DELTAX * DELTAY)\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n! the pressure source is added to d(pressure)/dt in this split pressure / velocity scheme\n! and that is why we need to select the first derivative of a Gaussian as a source time wavelet\n! above instead of a Ricker (i.e. a second derivative) added to d2(pressure)/dt2\n! as in the unsplit equation written in pressure only.\n! Since the formula is d(pressure)/dt = (pressure_new - pressure_old) / DELTAT = pressure_source_term\n! we also need to multiply by DELTAT here to avoid having an amplitude of the seismogram\n! that varies when one changes the time step, i.e. we write:\n! pressure_new = pressure_old + pressure_source_term * DELTAT at the source grid point\n pressure(i,j) = pressure(i,j) + pressure_source_term * DELTAT\n\n!--------------------------------------------------------\n! compute velocity and update memory variables for C-PML\n!--------------------------------------------------------\n\n do j = 2,NY\n do i = 2,NX\n\n value_dpressure_dx = (pressure(i,j) - pressure(i-1,j)) * ONE_OVER_DELTAX\n\n memory_dpressure_dx(i,j) = b_x(i) * memory_dpressure_dx(i,j) + a_x(i) * value_dpressure_dx\n\n value_dpressure_dx = value_dpressure_dx * one_over_K_x(i) + memory_dpressure_dx(i,j)\n\n vx(i,j) = vx(i,j) - value_dpressure_dx * DELTAT / rho(i,j)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n value_dpressure_dy = (pressure(i,j+1) - pressure(i,j)) * ONE_OVER_DELTAY\n\n memory_dpressure_dy(i,j) = b_y_half(j) * memory_dpressure_dy(i,j) + a_y_half(j) * value_dpressure_dy\n\n value_dpressure_dy = value_dpressure_dy * one_over_K_y_half(j) + memory_dpressure_dy(i,j)\n\n vy(i,j) = vy(i,j) - value_dpressure_dy * DELTAT / rho_half_x_half_y\n\n enddo\n enddo\n\n! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers\n vx(1,:) = ZERO\n vx(NX,:) = ZERO\n\n vx(:,1) = ZERO\n vx(:,NY) = ZERO\n\n vy(1,:) = ZERO\n vy(NX,:) = ZERO\n\n vy(:,1) = ZERO\n vy(:,NY) = ZERO\n\n! store seismograms\n do irec = 1,NREC\n\n! beware here that the two components of the velocity vector are not defined at the same point\n! in a staggered grid, and thus the two components of the velocity vector are recorded at slightly different locations,\n! vy is staggered by half a grid cell along X and along Y with respect to vx\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec))\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))\n sispressure(it,irec) = pressure(ix_rec(irec),iy_rec(irec))\n enddo\n\n! compute total energy in the medium (without the PML layers)\n if (COMPUTE_ENERGY) then\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n total_energy_kinetic(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n! interpolate vy back at the location of vx, to be able to use both at the same location\n vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1))\n total_energy_kinetic(it) = total_energy_kinetic(it) + 0.5d0 * rho(i,j) * (vx(i,j)**2 + vy_interpolated**2)\n enddo\n enddo\n\n! add potential energy, defined as 1/2 pressure^2 / Kappa\n total_energy_potential(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n! interpolate material parameters at the right location in the staggered grid cell\n kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j))\n total_energy_potential(it) = total_energy_potential(it) + 0.5d0 * pressure(i,j)**2 / kappa_half_x\n enddo\n enddo\n\n endif\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n! print maximum of pressure and of norm of velocity\n pressurenorm = maxval(abs(pressure))\n velocnorm = maxval(sqrt(vx**2 + vy**2))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max absolute value of pressure = ',pressurenorm\n print *,'Max norm velocity vector V (m/s) = ',velocnorm\n if (COMPUTE_ENERGY) print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n print *\n! check stability of the code, exit if unstable\n if (pressurenorm > STABILITY_THRESHOLD .or. velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n! call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)\n! call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n! NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)\n call create_color_image(pressure,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,3)\n\n! save the part of the seismograms that has been computed so far, so that users can monitor the progress of the simulation\n call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)\n\n if (COMPUTE_ENERGY) then\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"cpml_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n endif\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_CPML_2D_viscoacoust_second\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,sispressure,nt,nrec,DELTAT,t0)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT,t0\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n double precision sispressure(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! pressure\n do irec=1,nrec\n write(file_name,\"('pressure_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n! in the scheme of eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n! pressure is defined at time t + DELTAT/2, i.e. staggered in time with respect to velocity.\n! Here we must thus take this shift of DELTAT/2 into account to save the seismograms at the right time\n write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec))\n enddo\n close(11)\n enddo\n\n! X component of velocity\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component of velocity\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n else if (field_number == 3) then\n write(file_name,\"('image',i6.6,'_pressure.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')\") &\n it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n!\n!---- include the SolvOpt() routine that is used to compute the tau_epsilon and tau_sigma values from a given Q attenuation factor\n!\n\ninclude \"attenuation_model_with_SolvOpt.f90\"\n\n" }, { "path": "seismic_CPML_2D_pressure_second_order.f90", "content": "!\n! SEISMIC_CPML Version 1.1.3, July 2018.\n!\n! Copyright CNRS, France.\n! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional heterogeneous isotropic acoustic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_2D_pressure\n\n! 2D acoustic finite-difference code in pressure formulation\n! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic acoustic medium\n\n! Dimitri Komatitsch, CNRS, Marseille, July 2018.\n\n! The pressure wave equation in an inviscid heterogeneous fluid is:\n!\n! 1/Kappa d2p / dt2 = div(grad(p) / rho) = d(1/rho dp/dx)/dx + d(1/rho dp/dy)/dy\n!\n! (see for instance Komatitsch and Tromp, Geophysical Journal International, vol. 149, p. 390-412 (2002), equations (19) and (21))\n!\n! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | |\n! dp/dy +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! p dp/dx\n!\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these\n! articles:\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 2001\n integer, parameter :: NY = 2001\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 1.5d0\n double precision, parameter :: DELTAY = DELTAX\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! P-velocity and density\n! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity)\n double precision, parameter :: cp_unrelaxed = 2000.d0\n double precision, parameter :: density = 2000.d0\n\n! total number of time steps\n integer, parameter :: NSTEP = 1500\n\n! time step in seconds\n double precision, parameter :: DELTAT = 5.2d-4\n\n! parameters for the source\n double precision, parameter :: f0 = 35.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d0\n\n! source (in pressure)\n double precision, parameter :: xsource = 1500.d0\n double precision, parameter :: ysource = 1500.d0\n integer, parameter :: ISOURCE = xsource / DELTAX + 1\n integer, parameter :: JSOURCE = ysource / DELTAY + 1\n\n! receivers\n integer, parameter :: NREC = 1\n!! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point\n double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters\n double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters\n double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 100\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n double precision, dimension(NX,NY) :: pressure_past,pressure_present,pressure_future, &\n pressure_xx,pressure_yy,dpressurexx_dx,dpressureyy_dy,kappa_unrelaxed,rho,Kronecker_source\n\n! to interpolate material parameters or velocity at the right location in the staggered grid cell\n double precision :: rho_half_x,rho_half_y\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(NX,NY) :: &\n memory_dpressure_dx, &\n memory_dpressure_dy, &\n memory_dpressurexx_dx, &\n memory_dpressureyy_dy\n\n double precision :: &\n value_dpressure_dx, &\n value_dpressure_dy, &\n value_dpressurexx_dx, &\n value_dpressureyy_dy\n\n! 1D arrays for the damping profiles\n 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\n 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\n\n double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n! for the source\n double precision :: a,t,source_term\n\n! for receivers\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n integer :: myNREC\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sispressure\n\n integer :: i,j,it,irec\n\n double precision :: Courant_number,pressurenorm\n\n!---\n!--- program starts here\n!---\n\n print *\n print *,'2D acoustic finite-difference code in pressure formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y)\n\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *\n\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- left edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- right edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- bottom edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- top edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! compute the Lame parameter and density\n do j = 1,NY\n do i = 1,NX\n rho(i,j) = density\n kappa_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed\n enddo\n enddo\n\n! print position of the source\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of the source\n Kronecker_source(:,:) = 0.d0\n Kronecker_source(ISOURCE,JSOURCE) = 1.d0\n\n! define location of receivers\n print *,'There are ',nrec,' receivers'\n print *\n if (NREC > 1) then\n! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1\n myNREC = NREC\n xspacerec = (xfin-xdeb) / dble(myNREC-1)\n yspacerec = (yfin-ydeb) / dble(myNREC-1)\n else\n xspacerec = 0.d0\n yspacerec = 0.d0\n endif\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number = cp_unrelaxed * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2)\n print *,'Courant number is ',Courant_number\n print *\n if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable'\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')\n\n! initialize arrays\n pressure_present(:,:) = ZERO\n pressure_past(:,:) = ZERO\n\n! PML\n memory_dpressure_dx(:,:) = ZERO\n memory_dpressure_dy(:,:) = ZERO\n memory_dpressurexx_dx(:,:) = ZERO\n memory_dpressureyy_dy(:,:) = ZERO\n\n! initialize seismograms\n sispressure(:,:) = ZERO\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n! compute the first spatial derivatives divided by density\n\n do j = 1,NY\n do i = 1,NX-1\n value_dpressure_dx = (pressure_present(i+1,j) - pressure_present(i,j)) / DELTAX\n\n memory_dpressure_dx(i,j) = b_x_half(i) * memory_dpressure_dx(i,j) + a_x_half(i) * value_dpressure_dx\n\n value_dpressure_dx = value_dpressure_dx / K_x_half(i) + memory_dpressure_dx(i,j)\n\n rho_half_x = 0.5d0 * (rho(i+1,j) + rho(i,j))\n pressure_xx(i,j) = value_dpressure_dx / rho_half_x\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX\n value_dpressure_dy = (pressure_present(i,j+1) - pressure_present(i,j)) / DELTAY\n\n memory_dpressure_dy(i,j) = b_y_half(j) * memory_dpressure_dy(i,j) + a_y_half(j) * value_dpressure_dy\n\n value_dpressure_dy = value_dpressure_dy / K_y_half(j) + memory_dpressure_dy(i,j)\n\n rho_half_y = 0.5d0 * (rho(i,j+1) + rho(i,j))\n pressure_yy(i,j) = value_dpressure_dy / rho_half_y\n enddo\n enddo\n\n! compute the second spatial derivatives\n\n do j = 1,NY\n do i = 2,NX\n value_dpressurexx_dx = (pressure_xx(i,j) - pressure_xx(i-1,j)) / DELTAX\n\n memory_dpressurexx_dx(i,j) = b_x(i) * memory_dpressurexx_dx(i,j) + a_x(i) * value_dpressurexx_dx\n\n value_dpressurexx_dx = value_dpressurexx_dx / K_x(i) + memory_dpressurexx_dx(i,j)\n\n dpressurexx_dx(i,j) = value_dpressurexx_dx\n enddo\n enddo\n\n do j = 2,NY\n do i = 1,NX\n value_dpressureyy_dy = (pressure_yy(i,j) - pressure_yy(i,j-1)) / DELTAY\n\n memory_dpressureyy_dy(i,j) = b_y(j) * memory_dpressureyy_dy(i,j) + a_y(j) * value_dpressureyy_dy\n\n value_dpressureyy_dy = value_dpressureyy_dy / K_y(j) + memory_dpressureyy_dy(i,j)\n\n dpressureyy_dy(i,j) = value_dpressureyy_dy\n enddo\n enddo\n\n! add the source (pressure located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a)\n\n! first derivative of a Gaussian\n! source_term = factor * (t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n! apply the time evolution scheme\n! we apply it everywhere, including at some points on the edges of the domain that have not be calculated above,\n! which is of course wrong (or more precisely undefined), but this does not matter because these values\n! will be erased by the Dirichlet conditions set on these edges below\n pressure_future(:,:) = - pressure_past(:,:) + 2.d0 * pressure_present(:,:) + &\n DELTAT*DELTAT * ((dpressurexx_dx(:,:) + dpressureyy_dy(:,:)) * kappa_unrelaxed(:,:) + &\n 4.d0 * PI * cp_unrelaxed**2 * source_term * Kronecker_source(:,:))\n\n! apply Dirichlet conditions at the bottom of the C-PML layers,\n! which is the right condition to implement in order for C-PML to remain stable at long times\n\n! Dirichlet condition for pressure on the left boundary\n pressure_future(1,:) = ZERO\n\n! Dirichlet condition for pressure on the right boundary\n pressure_future(NX,:) = ZERO\n\n! Dirichlet condition for pressure on the bottom boundary\n pressure_future(:,1) = ZERO\n\n! Dirichlet condition for pressure on the top boundary\n pressure_future(:,NY) = ZERO\n\n! store seismograms\n do irec = 1,NREC\n sispressure(it,irec) = pressure_future(ix_rec(irec),iy_rec(irec))\n enddo\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n! print maximum of pressure and of norm of velocity\n pressurenorm = maxval(abs(pressure_future))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max absolute value of pressure = ',pressurenorm\n print *\n! check stability of the code, exit if unstable\n if (pressurenorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n call create_color_image(pressure_future,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,3)\n\n endif\n\n! move new values to old values (the present becomes the past, the future becomes the present)\n pressure_past(:,:) = pressure_present(:,:)\n pressure_present(:,:) = pressure_future(:,:)\n\n enddo ! end of the time loop\n\n! save seismograms\n call write_seismograms(sispressure,NSTEP,NREC,DELTAT,t0)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_CPML_2D_pressure\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sispressure,nt,nrec,DELTAT,t0)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT,t0\n\n double precision sispressure(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! pressure\n do irec=1,nrec\n write(file_name,\"('pressure_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n! write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sispressure(it,irec))\n write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec))\n! write(11,*) sngl(dble(it-1)*DELTAT - DELTAT - t0),' ',sngl(sispressure(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n else if (field_number == 3) then\n write(file_name,\"('image',i6.6,'_pressure.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')\") &\n it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_CPML_2D_velocity_and_stress_fourth_order_viscoelastic.f90", "content": "!\n! SEISMIC_CPML Version 1.1.3, July 2018.\n!\n! Copyright CNRS, France.\n! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional heterogeneous isotropic viscoelastic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_2D_viscoelast_fourth\n\n! 2D finite-difference code in velocity and stress formulation\n! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic viscoelastic medium\n\n! Dimitri Komatitsch, CNRS, Marseille, July 2018.\n\n! A fourth-order spatially-staggered grid formulation is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! e13 | | |\n! (memory | | |\n! variable) | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n! e1 (viscoelastic memory variable)\n! e11 (viscoelastic memory variable)\n!\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these\n! articles:\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! include viscoelastic attenuation or not\n logical, parameter :: VISCOELASTIC_ATTENUATION = .true.\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 2001\n integer, parameter :: NY = 2001\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 1.5d0\n double precision, parameter :: DELTAY = DELTAX\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! P-velocity and density\n! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity)\n double precision, parameter :: cp_unrelaxed = 2000.d0\n double precision, parameter :: cs_unrelaxed = cp_unrelaxed / 1.732d0\n double precision, parameter :: density = 2000.d0\n\n! Time step in seconds.\n! The CFL stability number for the O(2,2) algorithm is 1 / sqrt(2) = 0.707\n! i.e. one must choose cp * deltat / deltax < 0.707.\n! For the O(2,4) algorithm used here it is a bit more restrictive,\n! it is cp * deltat / deltax < 0.606 (see Levander 1988 eq (7)).\n! However this only ensures that the scheme is stable. To have a scheme that is both stable and accurate,\n! for O(2,4) some numerical tests show that one needs to take about half of that,\n! i.e. choose deltat so that cp * deltat / deltax is equal to about 0.30 or so. (or any value below; but not above).\n! Since the time scheme is only second order, this also depends on how many time steps are performed in total\n! (i.e. what the value of NSTEP below is); for large values of NSTEP, of course numerical errors will start to accumulate.\n double precision, parameter :: DELTAT = 2.2d-4\n\n! total number of time steps\n integer, parameter :: NSTEP = 5200\n\n! parameters for the source\n double precision, parameter :: f0 = 35.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d0\n\n! source (force)\n double precision, parameter :: xsource = 1500.d0\n double precision, parameter :: ysource = 1500.d0\n integer, parameter :: ISOURCE = xsource / DELTAX + 1\n integer, parameter :: JSOURCE = ysource / DELTAY + 1\n! angle of source force in degrees and clockwise, with respect to the vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 0.d0\n\n! receivers\n integer, parameter :: NREC = 1\n!! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point\n double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters\n double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters\n double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters\n\n! to compute energy curves for the whole medium (optional, but useful e.g. to produce\n! energy variation figures for articles); but expensive option, thus off by default\n logical, parameter :: COMPUTE_ENERGY = .false.\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 200\n\n! compute some constants once and for all for the fourth-order spatial scheme\n! These coefficients are given for instance by Levander, Geophysics, vol. 53(11), p. 1436, equation (A-2)\n double precision, parameter :: NINE_OVER_8_DELTAX = 9.d0 / (8.d0*DELTAX)\n double precision, parameter :: NINE_OVER_8_DELTAY = 9.d0 / (8.d0*DELTAY)\n double precision, parameter :: ONE_OVER_24_DELTAX = 1.d0 / (24.d0*DELTAX)\n double precision, parameter :: ONE_OVER_24_DELTAY = 1.d0 / (24.d0*DELTAY)\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n double precision, parameter :: TWO_THIRDS = 2.d0 / 3.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n! in order to be able to use a fourth-order spatial operator on the edges of the model\n! here we define the arrays with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case\n double precision, dimension(0:NX+1,0:NY+1) :: vx,vy,sigma_xx,sigma_yy,sigma_xy,lambda_unrelaxed,mu_unrelaxed,rho\n\n! to interpolate material parameters or velocity at the right location in the staggered grid cell\n double precision :: lambda_half_x,mu_half_x,lambda_plus_mu_half_x,lambda_plus_two_mu_half_x,mu_half_y\n double precision :: rho_half_x_half_y,vy_interpolated\n\n! for evolution of total energy in the medium\n double precision :: epsilon_xx,epsilon_yy,epsilon_xy\n double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(NX,NY) :: &\n memory_dvx_dx, &\n memory_dvx_dy, &\n memory_dvy_dx, &\n memory_dvy_dy, &\n memory_dsigma_xx_dx, &\n memory_dsigma_yy_dy, &\n memory_dsigma_xy_dx, &\n memory_dsigma_xy_dy\n\n double precision :: &\n value_dvx_dx, &\n value_dvx_dy, &\n value_dvy_dx, &\n value_dvy_dy, &\n value_dsigma_xx_dx, &\n value_dsigma_yy_dy, &\n value_dsigma_xy_dx, &\n value_dsigma_xy_dy\n\n! 1D arrays for the damping profiles\n 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, &\n one_over_K_x,one_over_K_x_half\n 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, &\n one_over_K_y,one_over_K_y_half\n\n double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n! for the source\n double precision :: a,t,force_x,force_y,force_source_term\n\n! for receivers\n! Please note something important: the two components of the velocity vector are not defined at the same location,\n! Vy is half a grid cell away from Vx (see ASCII figure at the beginning of this program).\n! Thus this means there are \"two receivers\" rather than one, one recording Vx and another one, half a grid cell away, recording Vy.\n! If you need to use both components in real applications (and of course we will),\n! you will need to interpolate Vy to the location of Vx using:\n!\n! interpolate vy back at the location of vx, to be able to use both at the same location\n! vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1))\n!\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n integer :: myNREC\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sispressure\n\n integer :: i,j,it,irec\n\n double precision :: Courant_number,velocnorm\n\n! for attenuation (viscoelasticity)\n\n! attenuation quality factors Qp and Qs to use\n! BEWARE: we use Qp and Qs here, not QKappa and Qmu.\n! BEWARE: While Qmu is always equal to Qs, QKappa is not equal to Qp,\n! BEWARE: to convert from one to the other if your input data have Qkappa and Qmu you can use\n! BEWARE: the program conversion_between_Qp_Qs_and_Qkappa_Qmu_from_Dahlen_Tromp_959_960_in_3D_and_in_2D_plane_strain.f90\n! BEWARE: that is included in this software package.\n double precision, parameter :: Qp = 65.d0\n double precision, parameter :: Qs = 55.d0\n\n! number of Zener standard linear solids in parallel\n integer, parameter :: N_SLS = 3\n\n! attenuation constants\n double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,one_over_tau_sigma_nu1, &\n HALF_DELTAT_over_tau_sigma_nu1,multiplication_factor_tau_sigma_nu1,DELTAT_phi_nu1\n double precision, dimension(N_SLS) :: tau_epsilon_nu2,tau_sigma_nu2,one_over_tau_sigma_nu2, &\n HALF_DELTAT_over_tau_sigma_nu2,multiplication_factor_tau_sigma_nu2,DELTAT_phi_nu2\n\n! memory variable and other arrays for attenuation\n double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e1_dot,memory_variable_R_e1_dot_old\n double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e11_dot,memory_variable_R_e11_dot_old\n double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e13_dot,memory_variable_R_e13_dot_old\n integer :: i_sls\n double precision :: sum_of_memory_variables_e1,sum_of_memory_variables_e11,sum_of_memory_variables_e13\n\n! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band\n double precision :: f_min_attenuation,f_max_attenuation\n\n!---\n!--- program starts here\n!---\n\n print *\n print *,'2D viscoelastic finite-difference code in velocity and stress formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n! for attenuation (viscoelasticity)\n if (VISCOELASTIC_ATTENUATION) then\n\n print *,'Qp quality factor used for attenuation = ',Qp\n print *,'Qs quality factor used for attenuation = ',Qs\n print *,'Number of Zener standard linear solids used to mimic the viscoelastic behavior (N_SLS) = ',N_SLS\n print *\n\n! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band\n! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0)\n f_min_attenuation = exp(log(f0)-log(12.d0)/2.d0)\n f_max_attenuation = 12.d0 * f_min_attenuation\n\n! call the SolvOpt() nonlinear optimization routine to compute the tau_epsilon and tau_sigma values from a given Q factor\n print *,'Values for Qp:'\n print *\n call compute_attenuation_coeffs(N_SLS,Qp,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu1,tau_sigma_nu1)\n print *,'Values for Qs:'\n print *\n call compute_attenuation_coeffs(N_SLS,Qs,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu2,tau_sigma_nu2)\n\n else\n\n! dummy values in the non-dissipative case\n tau_epsilon_nu1(:) = 1.d0\n tau_sigma_nu1(:) = 1.d0\n\n tau_epsilon_nu2(:) = 1.d0\n tau_sigma_nu2(:) = 1.d0\n\n endif\n\n! precompute the inverse once and for all, to save computation time in the time loop below\n! (on computers, a multiplication is very significantly cheaper than a division)\n one_over_tau_sigma_nu1(:) = 1.d0 / tau_sigma_nu1(:)\n one_over_tau_sigma_nu2(:) = 1.d0 / tau_sigma_nu2(:)\n\n HALF_DELTAT_over_tau_sigma_nu1(:) = 0.5d0 * DELTAT / tau_sigma_nu1(:)\n HALF_DELTAT_over_tau_sigma_nu2(:) = 0.5d0 * DELTAT / tau_sigma_nu2(:)\n\n multiplication_factor_tau_sigma_nu1(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu1(:))\n multiplication_factor_tau_sigma_nu2(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu2(:))\n\n ! use the right formula with 1/N included\n DELTAT_phi_nu1(:) = DELTAT * (1.d0 - tau_epsilon_nu1(:)/tau_sigma_nu1(:)) / tau_sigma_nu1(:) / sum(tau_epsilon_nu1/tau_sigma_nu1)\n DELTAT_phi_nu2(:) = DELTAT * (1.d0 - tau_epsilon_nu2(:)/tau_sigma_nu2(:)) / tau_sigma_nu2(:) / sum(tau_epsilon_nu2/tau_sigma_nu2)\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y)\n\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *\n\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- left edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- right edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- bottom edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- top edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! precompute the inverse once and for all, to save computation time in the time loop below\n! (on computers, a multiplication is very significantly cheaper than a division)\n one_over_K_x(:) = 1.d0 / K_x(:)\n one_over_K_x_half(:) = 1.d0 / K_x_half(:)\n one_over_K_y(:) = 1.d0 / K_y(:)\n one_over_K_y_half(:) = 1.d0 / K_y_half(:)\n\n! compute the Lame parameter and density\n do j = 1,NY\n do i = 1,NX\n rho(i,j) = density\n mu_unrelaxed(i,j) = density*cs_unrelaxed*cs_unrelaxed\n lambda_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed - 2.d0*mu_unrelaxed(i,j)\n enddo\n enddo\n\n! print position of the source\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *,'There are ',nrec,' receivers'\n print *\n if (NREC > 1) then\n! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1\n myNREC = NREC\n xspacerec = (xfin-xdeb) / dble(myNREC-1)\n yspacerec = (yfin-ydeb) / dble(myNREC-1)\n else\n xspacerec = 0.d0\n yspacerec = 0.d0\n endif\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant, K. O. Friedrichs and H. Lewy (1928)\n! For this O(2,4) scheme, when DELTAX == DELTAY the Courant number is given by Levander, Geophysics, vol. 53(11), p. 1427,\n! 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,\n! 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.\n if (DELTAX == DELTAY) then\n Courant_number = cp_unrelaxed * DELTAT / DELTAX\n print *,'Courant number is ',Courant_number\n print *,' (the maximum possible value is 0.606; in practice for accuracy reasons a value not larger than 0.30 is recommended)'\n print *\n if (Courant_number > 0.606) stop 'time step is too large, simulation will be unstable'\n endif\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n call system('rm -f Vx_file*.dat Vy_file*.dat image*.pnm image*.gif')\n\n! initialize arrays\n vx(:,:) = ZERO\n vy(:,:) = ZERO\n sigma_xx(:,:) = ZERO\n sigma_yy(:,:) = ZERO\n sigma_xy(:,:) = ZERO\n memory_variable_R_e1_dot(:,:,:) = ZERO\n memory_variable_R_e1_dot_old(:,:,:) = ZERO\n memory_variable_R_e11_dot(:,:,:) = ZERO\n memory_variable_R_e11_dot_old(:,:,:) = ZERO\n memory_variable_R_e13_dot(:,:,:) = ZERO\n memory_variable_R_e13_dot_old(:,:,:) = ZERO\n\n! PML\n memory_dvx_dx(:,:) = ZERO\n memory_dvx_dy(:,:) = ZERO\n memory_dvy_dx(:,:) = ZERO\n memory_dvy_dy(:,:) = ZERO\n memory_dsigma_xx_dx(:,:) = ZERO\n memory_dsigma_yy_dy(:,:) = ZERO\n memory_dsigma_xy_dx(:,:) = ZERO\n memory_dsigma_xy_dy(:,:) = ZERO\n\n! initialize seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n sispressure(:,:) = ZERO\n\n! initialize total energy\n total_energy_kinetic(:) = ZERO\n total_energy_potential(:) = ZERO\n\n if (VISCOELASTIC_ATTENUATION) then\n print *,'adding VISCOELASTIC_ATTENUATION (i.e., running a viscoelastic simulation)'\n else\n print *,'not adding VISCOELASTIC_ATTENUATION (i.e., running a purely elastic simulation)'\n endif\n print *\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!-----------------------------------------------------------------------\n! compute the stress tensor and update memory variables for C-PML\n! also update memory variables for viscoelastic attenuation if needed\n!-----------------------------------------------------------------------\n\n! we purposely leave this \"if\" test outside of the loops to make sure the compiler can optimize these loops;\n! with an \"if\" test inside most compilers cannot\n if (.not. VISCOELASTIC_ATTENUATION) then\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))\n mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))\n lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x\n\n 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\n 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\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j)\n\n sigma_xx(i,j) = sigma_xx(i,j) + (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) * DELTAT\n\n sigma_yy(i,j) = sigma_yy(i,j) + (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) * DELTAT\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 2,NX\n\n! interpolate material parameters at the right location in the staggered grid cell\n mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j))\n\n 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\n 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\n\n memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx\n memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy\n\n value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)\n value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j)\n\n sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy) * DELTAT\n\n enddo\n enddo\n\n else\n\n! the present becomes the past for the memory variables.\n! in C or C++ we could replace this with an exchange of pointers on the arrays\n! in order to avoid a memory copy of the whole array.\n memory_variable_R_e1_dot_old(:,:,:) = memory_variable_R_e1_dot(:,:,:)\n memory_variable_R_e11_dot_old(:,:,:) = memory_variable_R_e11_dot(:,:,:)\n memory_variable_R_e13_dot_old(:,:,:) = memory_variable_R_e13_dot(:,:,:)\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))\n mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))\n lambda_plus_mu_half_x = lambda_half_x + mu_half_x\n lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x\n\n 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\n 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\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j)\n\n! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following\n! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here\n sum_of_memory_variables_e1 = 0.d0\n sum_of_memory_variables_e11 = 0.d0\n do i_sls = 1,N_SLS\n! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n memory_variable_R_e1_dot(i,j,i_sls) = (memory_variable_R_e1_dot_old(i,j,i_sls) + &\n (value_dvx_dx + value_dvy_dy) * DELTAT_phi_nu1(i_sls) - &\n memory_variable_R_e1_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu1(i_sls)) &\n * multiplication_factor_tau_sigma_nu1(i_sls)\n\n memory_variable_R_e11_dot(i,j,i_sls) = (memory_variable_R_e11_dot_old(i,j,i_sls) + &\n 0.5d0 * (value_dvx_dx - value_dvy_dy) * DELTAT_phi_nu2(i_sls) - &\n memory_variable_R_e11_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) &\n * multiplication_factor_tau_sigma_nu2(i_sls)\n\n sum_of_memory_variables_e1 = sum_of_memory_variables_e1 + &\n memory_variable_R_e1_dot(i,j,i_sls) + memory_variable_R_e1_dot_old(i,j,i_sls)\n\n sum_of_memory_variables_e11 = sum_of_memory_variables_e11 + &\n memory_variable_R_e11_dot(i,j,i_sls) + memory_variable_R_e11_dot_old(i,j,i_sls)\n enddo\n\n sigma_xx(i,j) = sigma_xx(i,j) + &\n (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy &\n! use the right formula with 1/N included\n! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189))\n! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n + (0.5d0 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 + mu_half_x * sum_of_memory_variables_e11)) * DELTAT\n\n sigma_yy(i,j) = sigma_yy(i,j) + &\n (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy &\n! use the right formula with 1/N included\n! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189))\n! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n + (0.5d0 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 - mu_half_x * sum_of_memory_variables_e11)) * DELTAT\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 2,NX\n\n! interpolate material parameters at the right location in the staggered grid cell\n mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j))\n\n 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\n 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\n\n memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx\n memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy\n\n value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)\n value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j)\n\n! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following\n! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here\n sum_of_memory_variables_e13 = 0.d0\n do i_sls = 1,N_SLS\n! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n memory_variable_R_e13_dot(i,j,i_sls) = (memory_variable_R_e13_dot_old(i,j,i_sls) + &\n (value_dvy_dx + value_dvx_dy) * DELTAT_phi_nu2(i_sls) - &\n memory_variable_R_e13_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) &\n * multiplication_factor_tau_sigma_nu2(i_sls)\n\n sum_of_memory_variables_e13 = sum_of_memory_variables_e13 + &\n memory_variable_R_e13_dot(i,j,i_sls) + memory_variable_R_e13_dot_old(i,j,i_sls)\n enddo\n\n sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy &\n! use the right formula with 1/N included\n! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189))\n! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n + 0.5d0 * sum_of_memory_variables_e13) * DELTAT\n\n enddo\n enddo\n\n endif\n\n!--------------------------------------------------------\n! compute velocity and update memory variables for C-PML\n!--------------------------------------------------------\n\n do j = 2,NY\n do i = 2,NX\n\n value_dsigma_xx_dx = (sigma_xx(i,j) - sigma_xx(i-1,j)) * NINE_OVER_8_DELTAX + &\n (sigma_xx(i-2,j) - sigma_xx(i+1,j)) * ONE_OVER_24_DELTAX\n value_dsigma_xy_dy = (sigma_xy(i,j) - sigma_xy(i,j-1)) * NINE_OVER_8_DELTAY + &\n (sigma_xy(i,j-2) - sigma_xy(i,j+1)) * ONE_OVER_24_DELTAY\n\n memory_dsigma_xx_dx(i,j) = b_x(i) * memory_dsigma_xx_dx(i,j) + a_x(i) * value_dsigma_xx_dx\n memory_dsigma_xy_dy(i,j) = b_y(j) * memory_dsigma_xy_dy(i,j) + a_y(j) * value_dsigma_xy_dy\n\n value_dsigma_xx_dx = value_dsigma_xx_dx / K_x(i) + memory_dsigma_xx_dx(i,j)\n value_dsigma_xy_dy = value_dsigma_xy_dy / K_y(j) + memory_dsigma_xy_dy(i,j)\n\n vx(i,j) = vx(i,j) + (value_dsigma_xx_dx + value_dsigma_xy_dy) * DELTAT / rho(i,j)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n value_dsigma_xy_dx = (sigma_xy(i+1,j) - sigma_xy(i,j)) * NINE_OVER_8_DELTAX + &\n (sigma_xy(i-1,j) - sigma_xy(i+2,j)) * ONE_OVER_24_DELTAX\n\n value_dsigma_yy_dy = (sigma_yy(i,j+1) - sigma_yy(i,j)) * NINE_OVER_8_DELTAY + &\n (sigma_yy(i,j-1) - sigma_yy(i,j+2)) * ONE_OVER_24_DELTAY\n\n memory_dsigma_xy_dx(i,j) = b_x_half(i) * memory_dsigma_xy_dx(i,j) + a_x_half(i) * value_dsigma_xy_dx\n memory_dsigma_yy_dy(i,j) = b_y_half(j) * memory_dsigma_yy_dy(i,j) + a_y_half(j) * value_dsigma_yy_dy\n\n value_dsigma_xy_dx = value_dsigma_xy_dx / K_x_half(i) + memory_dsigma_xy_dx(i,j)\n value_dsigma_yy_dy = value_dsigma_yy_dy / K_y_half(j) + memory_dsigma_yy_dy(i,j)\n\n vy(i,j) = vy(i,j) + (value_dsigma_xy_dx + value_dsigma_yy_dy) * DELTAT / rho_half_x_half_y\n\n enddo\n enddo\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! force_source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a)\n\n! first derivative of a Gaussian\n! force_source_term = factor * (t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n force_source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n! to get the right amplitude of the force, we need to divide by the area of a grid cell\n! (we checked that against the analytical solution in a homogeneous medium for a force source)\n force_source_term = force_source_term / (DELTAX * DELTAY)\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n! we want seismograms to be representing velocity, for the case of the seismic wave equation\n! representing displacement for a Ricker (i.e., second derivative of a Gaussian) source in displacement.\n! Since the force source is added to d(velocity)/dt in this split velocity and stress scheme\n! we need to select the second derivative of a Gaussian as a source time wavelet\n! by analogy with a Ricker (i.e. a second derivative) added to d2(displacement)/dt2\n! as in the unsplit equation written in displacement only.\n! Since the formula is d(velocity)/dt = (velocity_new - velocity_old) / DELTAT = force_source_term\n! we also need to multiply by DELTAT here to avoid having an amplitude of the seismogram\n! that varies when one changes the time step, i.e. we write:\n! velocity_new = velocity_old + force_source_term * DELTAT at the source grid point\n vx(i,j) = vx(i,j) + force_x * DELTAT / rho(i,j)\n vy(i,j) = vy(i,j) + force_y * DELTAT / rho_half_x_half_y\n\n! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers\n vx(1,:) = ZERO\n vx(NX,:) = ZERO\n\n vx(:,1) = ZERO\n vx(:,NY) = ZERO\n\n vy(1,:) = ZERO\n vy(NX,:) = ZERO\n\n vy(:,1) = ZERO\n vy(:,NY) = ZERO\n\n! store seismograms\n do irec = 1,NREC\n\n! beware here that the two components of the velocity vector are not defined at the same point\n! in a staggered grid, and thus the two components of the velocity vector are recorded at slightly different locations,\n! vy is staggered by half a grid cell along X and along Y with respect to vx\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec))\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))\n\n! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,\n! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5):\n! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as\n! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor.\n\n! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3\n! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij\n! = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij\n! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx\n! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy\n! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz\n! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon)\n!\n! to compute pressure in 2D in an elastic solid in the plane strain convention i.e. in the P-SV case,\n! one still uses pressure = - trace(sigma) / 3 but taking into account the fact\n! that the off-plane strain epsilon_zz is zero by definition of the plane strain convention\n! but thus the off-plane stress sigma_zz is not equal to zero,\n! one has instead: sigma_zz = lambda * (epsilon_xx + epsilon_yy), thus\n! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij\n! = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij\n! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx\n! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy\n! sigma_zz = lambda * (epsilon_xx + epsilon_yy)\n! pressure = - trace(sigma) / 3 = - (lambda + 2*mu/3) (epsilon_xx + epsilon_yy)\n\n i = ix_rec(irec)\n j = iy_rec(irec)\n\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))\n mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))\n epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * &\n sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))\n epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * &\n sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))\n\n sispressure(it,irec) = - (lambda_half_x + TWO_THIRDS*mu_half_x) * (epsilon_xx + epsilon_yy)\n\n enddo\n\n! compute total energy in the medium (without the PML layers)\n if (COMPUTE_ENERGY) then\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n total_energy_kinetic(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n! interpolate vy back at the location of vx, to be able to use both at the same location\n vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1))\n total_energy_kinetic(it) = total_energy_kinetic(it) + 0.5d0 * rho(i,j) * (vx(i,j)**2 + vy_interpolated**2)\n enddo\n enddo\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n total_energy_potential(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))\n mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))\n mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j))\n epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * &\n sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))\n epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * &\n sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))\n epsilon_xy = sigma_xy(i,j) / (2.d0 * mu_half_y)\n total_energy_potential(it) = total_energy_potential(it) + &\n 0.5d0 * (epsilon_xx * sigma_xx(i,j) + epsilon_yy * sigma_yy(i,j) + 2.d0 * epsilon_xy * sigma_xy(i,j))\n enddo\n enddo\n\n endif\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n! print maximum of norm of velocity\n velocnorm = maxval(sqrt(vx**2 + vy**2))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',velocnorm\n if (COMPUTE_ENERGY) print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n print *\n! check stability of the code, exit if unstable\n if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)\n call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)\n\n! save the part of the seismograms that has been computed so far, so that users can monitor the progress of the simulation\n call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)\n\n if (COMPUTE_ENERGY) then\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"cpml_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n endif\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_CPML_2D_viscoelast_fourth\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,sispressure,nt,nrec,DELTAT,t0)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT,t0\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n double precision sispressure(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! pressure\n do irec=1,nrec\n write(file_name,\"('pressure_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n! in the scheme of eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n! pressure is defined at time t + DELTAT/2, i.e. staggered in time with respect to velocity.\n! Here we must thus take this shift of DELTAT/2 into account to save the seismograms at the right time\n write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec))\n enddo\n close(11)\n enddo\n\n! X component of velocity\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component of velocity\n do irec=1,nrec\n write(file_name,\"('Vy_file_half_a_grid_cell_away_from_Vx_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n! in order to be able to use a fourth-order spatial operator on the edges of the model\n! here we define the array with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case\n double precision, dimension(0:NX+1,0:NY+1) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n else if (field_number == 3) then\n write(file_name,\"('image',i6.6,'_pressure.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')\") &\n it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n!\n!---- include the SolvOpt() routine that is used to compute the tau_epsilon and tau_sigma values from a given Q attenuation factor\n!\n\ninclude \"attenuation_model_with_SolvOpt.f90\"\n\n" }, { "path": "seismic_CPML_2D_velocity_and_stress_second_order_viscoelastic.f90", "content": "!\n! SEISMIC_CPML Version 1.1.3, July 2018.\n!\n! Copyright CNRS, France.\n! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional heterogeneous isotropic viscoelastic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_2D_viscoelast_second\n\n! 2D finite-difference code in velocity and stress formulation\n! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic viscoelastic medium\n\n! Dimitri Komatitsch, CNRS, Marseille, July 2018.\n\n! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! e13 | | |\n! (memory | | |\n! variable) | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n! e1 (viscoelastic memory variable)\n! e11 (viscoelastic memory variable)\n!\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these\n! articles:\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n!\n! To display the 2D results as color images, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! include viscoelastic attenuation or not\n logical, parameter :: VISCOELASTIC_ATTENUATION = .true.\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 2001\n integer, parameter :: NY = 2001\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 1.5d0\n double precision, parameter :: DELTAY = DELTAX\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! P-velocity and density\n! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity)\n double precision, parameter :: cp_unrelaxed = 2000.d0\n double precision, parameter :: cs_unrelaxed = cp_unrelaxed / 1.732d0\n double precision, parameter :: density = 2000.d0\n\n! Time step in seconds.\n! The CFL stability number for the O(2,2) algorithm is 1 / sqrt(2) = 0.707\n! i.e. one must choose cp * deltat / deltax < 0.707.\n! For the O(2,4) algorithm used here it is a bit more restrictive,\n! it is cp * deltat / deltax < 0.606 (see Levander 1988 eq (7)).\n! However this only ensures that the scheme is stable. To have a scheme that is both stable and accurate,\n! for O(2,4) some numerical tests show that one needs to take about half of that,\n! i.e. choose deltat so that cp * deltat / deltax is equal to about 0.30 or so. (or any value below; but not above).\n! Since the time scheme is only second order, this also depends on how many time steps are performed in total\n! (i.e. what the value of NSTEP below is); for large values of NSTEP, of course numerical errors will start to accumulate.\n double precision, parameter :: DELTAT = 2.2d-4\n\n! total number of time steps\n integer, parameter :: NSTEP = 5200\n\n! parameters for the source\n double precision, parameter :: f0 = 35.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d0\n\n! source (force)\n double precision, parameter :: xsource = 1500.d0\n double precision, parameter :: ysource = 1500.d0\n integer, parameter :: ISOURCE = xsource / DELTAX + 1\n integer, parameter :: JSOURCE = ysource / DELTAY + 1\n! angle of source force in degrees and clockwise, with respect to the vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 0.d0\n\n! receivers\n integer, parameter :: NREC = 1\n!! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point\n double precision, parameter :: xdeb = 2301.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2301.d0 ! first receiver y in meters\n double precision, parameter :: xfin = 2301.d0 ! last receiver x in meters\n double precision, parameter :: yfin = 2301.d0 ! last receiver y in meters\n\n! to compute energy curves for the whole medium (optional, but useful e.g. to produce\n! energy variation figures for articles); but expensive option, thus off by default\n logical, parameter :: COMPUTE_ENERGY = .false.\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 200\n\n! compute some constants once and for all for the second-order spatial scheme\n double precision, parameter :: ONE_OVER_DELTAX = 1.d0 / DELTAX\n double precision, parameter :: ONE_OVER_DELTAY = 1.d0 / DELTAY\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n double precision, parameter :: TWO_THIRDS = 2.d0 / 3.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n double precision, dimension(NX,NY) :: vx,vy,sigma_xx,sigma_yy,sigma_xy,lambda_unrelaxed,mu_unrelaxed,rho\n\n! to interpolate material parameters or velocity at the right location in the staggered grid cell\n double precision :: lambda_half_x,mu_half_x,lambda_plus_mu_half_x,lambda_plus_two_mu_half_x,mu_half_y\n double precision :: rho_half_x_half_y,vy_interpolated\n\n! for evolution of total energy in the medium\n double precision :: epsilon_xx,epsilon_yy,epsilon_xy\n double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(NX,NY) :: &\n memory_dvx_dx, &\n memory_dvx_dy, &\n memory_dvy_dx, &\n memory_dvy_dy, &\n memory_dsigma_xx_dx, &\n memory_dsigma_yy_dy, &\n memory_dsigma_xy_dx, &\n memory_dsigma_xy_dy\n\n double precision :: &\n value_dvx_dx, &\n value_dvx_dy, &\n value_dvy_dx, &\n value_dvy_dy, &\n value_dsigma_xx_dx, &\n value_dsigma_yy_dy, &\n value_dsigma_xy_dx, &\n value_dsigma_xy_dy\n\n! 1D arrays for the damping profiles\n 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, &\n one_over_K_x,one_over_K_x_half\n 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, &\n one_over_K_y,one_over_K_y_half\n\n double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop\n double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized\n\n! for the source\n double precision :: a,t,force_x,force_y,force_source_term\n\n! for receivers\n! Please note something important: the two components of the velocity vector are not defined at the same location,\n! Vy is half a grid cell away from Vx (see ASCII figure at the beginning of this program).\n! Thus this means there are \"two receivers\" rather than one, one recording Vx and another one, half a grid cell away, recording Vy.\n! If you need to use both components in real applications (and of course we will),\n! you will need to interpolate Vy to the location of Vx using:\n!\n! interpolate vy back at the location of vx, to be able to use both at the same location\n! vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1))\n!\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n integer :: myNREC\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sispressure\n\n integer :: i,j,it,irec\n\n double precision :: Courant_number,velocnorm\n\n! for attenuation (viscoelasticity)\n\n! attenuation quality factors Qp and Qs to use\n! BEWARE: we use Qp and Qs here, not QKappa and Qmu.\n! BEWARE: While Qmu is always equal to Qs, QKappa is not equal to Qp,\n! BEWARE: to convert from one to the other if your input data have Qkappa and Qmu you can use\n! BEWARE: the program conversion_between_Qp_Qs_and_Qkappa_Qmu_from_Dahlen_Tromp_959_960_in_3D_and_in_2D_plane_strain.f90\n! BEWARE: that is included in this software package.\n double precision, parameter :: Qp = 65.d0\n double precision, parameter :: Qs = 55.d0\n\n! number of Zener standard linear solids in parallel\n integer, parameter :: N_SLS = 3\n\n! attenuation constants\n double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,one_over_tau_sigma_nu1, &\n HALF_DELTAT_over_tau_sigma_nu1,multiplication_factor_tau_sigma_nu1,DELTAT_phi_nu1\n double precision, dimension(N_SLS) :: tau_epsilon_nu2,tau_sigma_nu2,one_over_tau_sigma_nu2, &\n HALF_DELTAT_over_tau_sigma_nu2,multiplication_factor_tau_sigma_nu2,DELTAT_phi_nu2\n\n! memory variable and other arrays for attenuation\n double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e1_dot,memory_variable_R_e1_dot_old\n double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e11_dot,memory_variable_R_e11_dot_old\n double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e13_dot,memory_variable_R_e13_dot_old\n integer :: i_sls\n double precision :: sum_of_memory_variables_e1,sum_of_memory_variables_e11,sum_of_memory_variables_e13\n\n! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band\n double precision :: f_min_attenuation,f_max_attenuation\n\n!---\n!--- program starts here\n!---\n\n print *\n print *,'2D viscoelastic finite-difference code in velocity and stress formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n! for attenuation (viscoelasticity)\n if (VISCOELASTIC_ATTENUATION) then\n\n print *,'Qp quality factor used for attenuation = ',Qp\n print *,'Qs quality factor used for attenuation = ',Qs\n print *,'Number of Zener standard linear solids used to mimic the viscoelastic behavior (N_SLS) = ',N_SLS\n print *\n\n! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band\n! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0)\n f_min_attenuation = exp(log(f0)-log(12.d0)/2.d0)\n f_max_attenuation = 12.d0 * f_min_attenuation\n\n! call the SolvOpt() nonlinear optimization routine to compute the tau_epsilon and tau_sigma values from a given Q factor\n print *,'Values for Qp:'\n print *\n call compute_attenuation_coeffs(N_SLS,Qp,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu1,tau_sigma_nu1)\n print *,'Values for Qs:'\n print *\n call compute_attenuation_coeffs(N_SLS,Qs,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu2,tau_sigma_nu2)\n\n else\n\n! dummy values in the non-dissipative case\n tau_epsilon_nu1(:) = 1.d0\n tau_sigma_nu1(:) = 1.d0\n\n tau_epsilon_nu2(:) = 1.d0\n tau_sigma_nu2(:) = 1.d0\n\n endif\n\n! precompute the inverse once and for all, to save computation time in the time loop below\n! (on computers, a multiplication is very significantly cheaper than a division)\n one_over_tau_sigma_nu1(:) = 1.d0 / tau_sigma_nu1(:)\n one_over_tau_sigma_nu2(:) = 1.d0 / tau_sigma_nu2(:)\n\n HALF_DELTAT_over_tau_sigma_nu1(:) = 0.5d0 * DELTAT / tau_sigma_nu1(:)\n HALF_DELTAT_over_tau_sigma_nu2(:) = 0.5d0 * DELTAT / tau_sigma_nu2(:)\n\n multiplication_factor_tau_sigma_nu1(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu1(:))\n multiplication_factor_tau_sigma_nu2(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu2(:))\n\n ! use the right formula with 1/N included\n DELTAT_phi_nu1(:) = DELTAT * (1.d0 - tau_epsilon_nu1(:)/tau_sigma_nu1(:)) / tau_sigma_nu1(:) / sum(tau_epsilon_nu1/tau_sigma_nu1)\n DELTAT_phi_nu2(:) = DELTAT * (1.d0 - tau_epsilon_nu2(:)/tau_sigma_nu2(:)) / tau_sigma_nu2(:) / sum(tau_epsilon_nu2/tau_sigma_nu2)\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y)\n\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *\n\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- left edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- right edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- bottom edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- top edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! precompute the inverse once and for all, to save computation time in the time loop below\n! (on computers, a multiplication is very significantly cheaper than a division)\n one_over_K_x(:) = 1.d0 / K_x(:)\n one_over_K_x_half(:) = 1.d0 / K_x_half(:)\n one_over_K_y(:) = 1.d0 / K_y(:)\n one_over_K_y_half(:) = 1.d0 / K_y_half(:)\n\n! compute the Lame parameter and density\n do j = 1,NY\n do i = 1,NX\n rho(i,j) = density\n mu_unrelaxed(i,j) = density*cs_unrelaxed*cs_unrelaxed\n lambda_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed - 2.d0*mu_unrelaxed(i,j)\n enddo\n enddo\n\n! print position of the source\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *,'There are ',nrec,' receivers'\n print *\n if (NREC > 1) then\n! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1\n myNREC = NREC\n xspacerec = (xfin-xdeb) / dble(myNREC-1)\n yspacerec = (yfin-ydeb) / dble(myNREC-1)\n else\n xspacerec = 0.d0\n yspacerec = 0.d0\n endif\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant, K. O. Friedrichs and H. Lewy (1928)\n! For this O(2,2) scheme, when DELTAX == DELTAY the Courant number is 1/sqrt(2) = 0.707\n if (DELTAX == DELTAY) then\n Courant_number = cp_unrelaxed * DELTAT / DELTAX\n print *,'Courant number is ',Courant_number\n print *,' (the maximum possible value is 1/sqrt(2) = 0.707; &\n &in practice for accuracy reasons a value not larger than 0.30 is recommended)'\n print *\n if (Courant_number > 1.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable'\n endif\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n call system('rm -f Vx_file*.dat Vy_file*.dat image*.pnm image*.gif')\n\n! initialize arrays\n vx(:,:) = ZERO\n vy(:,:) = ZERO\n sigma_xx(:,:) = ZERO\n sigma_yy(:,:) = ZERO\n sigma_xy(:,:) = ZERO\n memory_variable_R_e1_dot(:,:,:) = ZERO\n memory_variable_R_e1_dot_old(:,:,:) = ZERO\n memory_variable_R_e11_dot(:,:,:) = ZERO\n memory_variable_R_e11_dot_old(:,:,:) = ZERO\n memory_variable_R_e13_dot(:,:,:) = ZERO\n memory_variable_R_e13_dot_old(:,:,:) = ZERO\n\n! PML\n memory_dvx_dx(:,:) = ZERO\n memory_dvx_dy(:,:) = ZERO\n memory_dvy_dx(:,:) = ZERO\n memory_dvy_dy(:,:) = ZERO\n memory_dsigma_xx_dx(:,:) = ZERO\n memory_dsigma_yy_dy(:,:) = ZERO\n memory_dsigma_xy_dx(:,:) = ZERO\n memory_dsigma_xy_dy(:,:) = ZERO\n\n! initialize seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n sispressure(:,:) = ZERO\n\n! initialize total energy\n total_energy_kinetic(:) = ZERO\n total_energy_potential(:) = ZERO\n\n if (VISCOELASTIC_ATTENUATION) then\n print *,'adding VISCOELASTIC_ATTENUATION (i.e., running a viscoelastic simulation)'\n else\n print *,'not adding VISCOELASTIC_ATTENUATION (i.e., running a purely elastic simulation)'\n endif\n print *\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!-----------------------------------------------------------------------\n! compute the stress tensor and update memory variables for C-PML\n! also update memory variables for viscoelastic attenuation if needed\n!-----------------------------------------------------------------------\n\n! we purposely leave this \"if\" test outside of the loops to make sure the compiler can optimize these loops;\n! with an \"if\" test inside most compilers cannot\n if (.not. VISCOELASTIC_ATTENUATION) then\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))\n mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))\n lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x\n\n value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX\n value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_DELTAY\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j)\n\n sigma_xx(i,j) = sigma_xx(i,j) + (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) * DELTAT\n\n sigma_yy(i,j) = sigma_yy(i,j) + (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) * DELTAT\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 2,NX\n\n! interpolate material parameters at the right location in the staggered grid cell\n mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j))\n\n value_dvy_dx = (vy(i,j) - vy(i-1,j)) * ONE_OVER_DELTAX\n value_dvx_dy = (vx(i,j+1) - vx(i,j)) * ONE_OVER_DELTAY\n\n memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx\n memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy\n\n value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)\n value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j)\n\n sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy) * DELTAT\n\n enddo\n enddo\n\n else\n\n! the present becomes the past for the memory variables.\n! in C or C++ we could replace this with an exchange of pointers on the arrays\n! in order to avoid a memory copy of the whole array.\n memory_variable_R_e1_dot_old(:,:,:) = memory_variable_R_e1_dot(:,:,:)\n memory_variable_R_e11_dot_old(:,:,:) = memory_variable_R_e11_dot(:,:,:)\n memory_variable_R_e13_dot_old(:,:,:) = memory_variable_R_e13_dot(:,:,:)\n\n do j = 2,NY\n do i = 1,NX-1\n\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))\n mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))\n lambda_plus_mu_half_x = lambda_half_x + mu_half_x\n lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x\n\n value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX\n value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_DELTAY\n\n memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy\n\n value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j)\n value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j)\n\n! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following\n! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here\n sum_of_memory_variables_e1 = 0.d0\n sum_of_memory_variables_e11 = 0.d0\n do i_sls = 1,N_SLS\n! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n memory_variable_R_e1_dot(i,j,i_sls) = (memory_variable_R_e1_dot_old(i,j,i_sls) + &\n (value_dvx_dx + value_dvy_dy) * DELTAT_phi_nu1(i_sls) - &\n memory_variable_R_e1_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu1(i_sls)) &\n * multiplication_factor_tau_sigma_nu1(i_sls)\n\n memory_variable_R_e11_dot(i,j,i_sls) = (memory_variable_R_e11_dot_old(i,j,i_sls) + &\n 0.5d0 * (value_dvx_dx - value_dvy_dy) * DELTAT_phi_nu2(i_sls) - &\n memory_variable_R_e11_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) &\n * multiplication_factor_tau_sigma_nu2(i_sls)\n\n sum_of_memory_variables_e1 = sum_of_memory_variables_e1 + &\n memory_variable_R_e1_dot(i,j,i_sls) + memory_variable_R_e1_dot_old(i,j,i_sls)\n\n sum_of_memory_variables_e11 = sum_of_memory_variables_e11 + &\n memory_variable_R_e11_dot(i,j,i_sls) + memory_variable_R_e11_dot_old(i,j,i_sls)\n enddo\n\n sigma_xx(i,j) = sigma_xx(i,j) + &\n (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy &\n! use the right formula with 1/N included\n! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189))\n! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n + (0.5d0 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 + mu_half_x * sum_of_memory_variables_e11)) * DELTAT\n\n sigma_yy(i,j) = sigma_yy(i,j) + &\n (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy &\n! use the right formula with 1/N included\n! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189))\n! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n + (0.5d0 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 - mu_half_x * sum_of_memory_variables_e11)) * DELTAT\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 2,NX\n\n! interpolate material parameters at the right location in the staggered grid cell\n mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j))\n\n value_dvy_dx = (vy(i,j) - vy(i-1,j)) * ONE_OVER_DELTAX\n value_dvx_dy = (vx(i,j+1) - vx(i,j)) * ONE_OVER_DELTAY\n\n memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx\n memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy\n\n value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)\n value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j)\n\n! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following\n! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here\n sum_of_memory_variables_e13 = 0.d0\n do i_sls = 1,N_SLS\n! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n memory_variable_R_e13_dot(i,j,i_sls) = (memory_variable_R_e13_dot_old(i,j,i_sls) + &\n (value_dvy_dx + value_dvx_dy) * DELTAT_phi_nu2(i_sls) - &\n memory_variable_R_e13_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) &\n * multiplication_factor_tau_sigma_nu2(i_sls)\n\n sum_of_memory_variables_e13 = sum_of_memory_variables_e13 + &\n memory_variable_R_e13_dot(i,j,i_sls) + memory_variable_R_e13_dot_old(i,j,i_sls)\n enddo\n\n sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy &\n! use the right formula with 1/N included\n! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189))\n! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n + 0.5d0 * sum_of_memory_variables_e13) * DELTAT\n\n enddo\n enddo\n\n endif\n\n!--------------------------------------------------------\n! compute velocity and update memory variables for C-PML\n!--------------------------------------------------------\n\n do j = 2,NY\n do i = 2,NX\n\n value_dsigma_xx_dx = (sigma_xx(i,j) - sigma_xx(i-1,j)) * ONE_OVER_DELTAX\n value_dsigma_xy_dy = (sigma_xy(i,j) - sigma_xy(i,j-1)) * ONE_OVER_DELTAY\n\n memory_dsigma_xx_dx(i,j) = b_x(i) * memory_dsigma_xx_dx(i,j) + a_x(i) * value_dsigma_xx_dx\n memory_dsigma_xy_dy(i,j) = b_y(j) * memory_dsigma_xy_dy(i,j) + a_y(j) * value_dsigma_xy_dy\n\n value_dsigma_xx_dx = value_dsigma_xx_dx / K_x(i) + memory_dsigma_xx_dx(i,j)\n value_dsigma_xy_dy = value_dsigma_xy_dy / K_y(j) + memory_dsigma_xy_dy(i,j)\n\n vx(i,j) = vx(i,j) + (value_dsigma_xx_dx + value_dsigma_xy_dy) * DELTAT / rho(i,j)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n value_dsigma_xy_dx = (sigma_xy(i+1,j) - sigma_xy(i,j)) * ONE_OVER_DELTAX\n value_dsigma_yy_dy = (sigma_yy(i,j+1) - sigma_yy(i,j)) * ONE_OVER_DELTAY\n\n memory_dsigma_xy_dx(i,j) = b_x_half(i) * memory_dsigma_xy_dx(i,j) + a_x_half(i) * value_dsigma_xy_dx\n memory_dsigma_yy_dy(i,j) = b_y_half(j) * memory_dsigma_yy_dy(i,j) + a_y_half(j) * value_dsigma_yy_dy\n\n value_dsigma_xy_dx = value_dsigma_xy_dx / K_x_half(i) + memory_dsigma_xy_dx(i,j)\n value_dsigma_yy_dy = value_dsigma_yy_dy / K_y_half(j) + memory_dsigma_yy_dy(i,j)\n\n vy(i,j) = vy(i,j) + (value_dsigma_xy_dx + value_dsigma_yy_dy) * DELTAT / rho_half_x_half_y\n\n enddo\n enddo\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! force_source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a)\n\n! first derivative of a Gaussian\n! force_source_term = factor * (t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n force_source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n! to get the right amplitude of the force, we need to divide by the area of a grid cell\n! (we checked that against the analytical solution in a homogeneous medium for a force source)\n force_source_term = force_source_term / (DELTAX * DELTAY)\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term\n\n! interpolate density at the right location in the staggered grid cell\n rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))\n\n! we want seismograms to be representing velocity, for the case of the seismic wave equation\n! representing displacement for a Ricker (i.e., second derivative of a Gaussian) source in displacement.\n! Since the force source is added to d(velocity)/dt in this split velocity and stress scheme\n! we need to select the second derivative of a Gaussian as a source time wavelet\n! by analogy with a Ricker (i.e. a second derivative) added to d2(displacement)/dt2\n! as in the unsplit equation written in displacement only.\n! Since the formula is d(velocity)/dt = (velocity_new - velocity_old) / DELTAT = force_source_term\n! we also need to multiply by DELTAT here to avoid having an amplitude of the seismogram\n! that varies when one changes the time step, i.e. we write:\n! velocity_new = velocity_old + force_source_term * DELTAT at the source grid point\n vx(i,j) = vx(i,j) + force_x * DELTAT / rho(i,j)\n vy(i,j) = vy(i,j) + force_y * DELTAT / rho_half_x_half_y\n\n! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers\n vx(1,:) = ZERO\n vx(NX,:) = ZERO\n\n vx(:,1) = ZERO\n vx(:,NY) = ZERO\n\n vy(1,:) = ZERO\n vy(NX,:) = ZERO\n\n vy(:,1) = ZERO\n vy(:,NY) = ZERO\n\n! store seismograms\n do irec = 1,NREC\n\n! beware here that the two components of the velocity vector are not defined at the same point\n! in a staggered grid, and thus the two components of the velocity vector are recorded at slightly different locations,\n! vy is staggered by half a grid cell along X and along Y with respect to vx\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec))\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))\n\n! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,\n! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5):\n! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as\n! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor.\n\n! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3\n! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij\n! = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij\n! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx\n! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy\n! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz\n! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon)\n!\n! to compute pressure in 2D in an elastic solid in the plane strain convention i.e. in the P-SV case,\n! one still uses pressure = - trace(sigma) / 3 but taking into account the fact\n! that the off-plane strain epsilon_zz is zero by definition of the plane strain convention\n! but thus the off-plane stress sigma_zz is not equal to zero,\n! one has instead: sigma_zz = lambda * (epsilon_xx + epsilon_yy), thus\n! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij\n! = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij\n! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx\n! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy\n! sigma_zz = lambda * (epsilon_xx + epsilon_yy)\n! pressure = - trace(sigma) / 3 = - (lambda + 2*mu/3) (epsilon_xx + epsilon_yy)\n\n i = ix_rec(irec)\n j = iy_rec(irec)\n\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))\n mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))\n epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * &\n sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))\n epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * &\n sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))\n\n sispressure(it,irec) = - (lambda_half_x + TWO_THIRDS*mu_half_x) * (epsilon_xx + epsilon_yy)\n\n enddo\n\n! compute total energy in the medium (without the PML layers)\n if (COMPUTE_ENERGY) then\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n total_energy_kinetic(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n! interpolate vy back at the location of vx, to be able to use both at the same location\n vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1))\n total_energy_kinetic(it) = total_energy_kinetic(it) + 0.5d0 * rho(i,j) * (vx(i,j)**2 + vy_interpolated**2)\n enddo\n enddo\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n total_energy_potential(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n! interpolate material parameters at the right location in the staggered grid cell\n lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))\n mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))\n mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j))\n epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * &\n sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))\n epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * &\n sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))\n epsilon_xy = sigma_xy(i,j) / (2.d0 * mu_half_y)\n total_energy_potential(it) = total_energy_potential(it) + &\n 0.5d0 * (epsilon_xx * sigma_xx(i,j) + epsilon_yy * sigma_yy(i,j) + 2.d0 * epsilon_xy * sigma_xy(i,j))\n enddo\n enddo\n\n endif\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n! print maximum of norm of velocity\n velocnorm = maxval(sqrt(vx**2 + vy**2))\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',velocnorm\n if (COMPUTE_ENERGY) print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n print *\n! check stability of the code, exit if unstable\n if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)\n call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)\n\n! save the part of the seismograms that has been computed so far, so that users can monitor the progress of the simulation\n call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)\n\n if (COMPUTE_ENERGY) then\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"cpml_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n endif\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_CPML_2D_viscoelast_second\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,sispressure,nt,nrec,DELTAT,t0)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT,t0\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n double precision sispressure(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! pressure\n do irec=1,nrec\n write(file_name,\"('pressure_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n! in the scheme of eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)\n! pressure is defined at time t + DELTAT/2, i.e. staggered in time with respect to velocity.\n! Here we must thus take this shift of DELTAT/2 into account to save the seismograms at the right time\n write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec))\n enddo\n close(11)\n enddo\n\n! X component of velocity\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component of velocity\n do irec=1,nrec\n write(file_name,\"('Vy_file_half_a_grid_cell_away_from_Vx_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n else if (field_number == 3) then\n write(file_name,\"('image',i6.6,'_pressure.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')\") &\n it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n!\n!---- include the SolvOpt() routine that is used to compute the tau_epsilon and tau_sigma values from a given Q attenuation factor\n!\n\ninclude \"attenuation_model_with_SolvOpt.f90\"\n\n" }, { "path": "seismic_CPML_3D_isotropic_MPI_OpenMP.f90", "content": "!\n! SEISMIC_CPML Version 1.1.1, November 2009.\n!\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the three-dimensional isotropic elastic wave equation\n! using a finite-difference method with Convolutional Perfectly Matched\n! Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_CPML_3D_iso_MPI_OpenMP\n\n! 3D elastic finite-difference code in velocity and stress formulation\n! with Convolutional-PML (C-PML) absorbing conditions.\n\n! Dimitri Komatitsch, University of Pau, France, April 2007.\n\n! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used.\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n!\n! Parallel implementation based on both MPI and OpenMP.\n! Type for instance \"setenv OMP_NUM_THREADS 4\" before running in OpenMP if you want 4 tasks.\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these\n! articles:\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n! To display the results as color images in the selected 2D cut plane, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n! header which contains standard MPI declarations\n include 'mpif.h'\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 101\n integer, parameter :: NY = 641\n integer, parameter :: NZ = 640 ! even number in order to cut along Z axis\n\n! number of processes used in the MPI run\n! and local number of points (for simplicity we cut the mesh along Z only)\n integer, parameter :: NPROC = 64\n integer, parameter :: NZ_LOCAL = NZ / NPROC\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 10.d0, ONE_OVER_DELTAX = 1.d0 / DELTAX\n double precision, parameter :: DELTAY = DELTAX, DELTAZ = DELTAX\n double precision, parameter :: ONE_OVER_DELTAY = ONE_OVER_DELTAX, ONE_OVER_DELTAZ = ONE_OVER_DELTAX\n\n! P-velocity, S-velocity and density\n double precision, parameter :: cp = 3300.d0\n double precision, parameter :: cs = cp / 1.732d0\n double precision, parameter :: rho = 2800.d0\n double precision, parameter :: mu = rho*cs*cs\n double precision, parameter :: lambda = rho*(cp*cp - 2.d0*cs*cs)\n double precision, parameter :: lambdaplustwomu = rho*cp*cp\n\n! total number of time steps\n integer, parameter :: NSTEP = 2500\n\n! time step in seconds\n double precision, parameter :: DELTAT = 1.6d-3\n\n! parameters for the source\n double precision, parameter :: f0 = 7.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d7\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n logical, parameter :: USE_PML_ZMIN = .true.\n logical, parameter :: USE_PML_ZMAX = .true.\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! source\n! Since we cut the domain into slices along the Z direction in order to implement MPI,\n! we have to tell the code in which MPI slice of the mesh the source is,\n! 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.\n! Here in this demo code we put the source in the middle of the model in the Z direction,\n! i.e. in NZ/2, which means putting it in the cut plane (i.e. only the processor for which\n! rank == rank_cut_plane will do it, and it will put it in its last point along Z, in NZ_LOCAL.\n! if one wants to put the source at another location, one can invert the formulas below\n! and define the grid point (ISOURCE, JSOURCE) to use as:\n! double precision, parameter :: xsource = ...put here the coordinate you want...\n! double precision, parameter :: ysource = ...put here the coordinate you want...\n! integer, parameter :: ISOURCE = xsource / DELTAX + 1\n! integer, parameter :: JSOURCE = ysource / DELTAY + 1\n integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1\n integer, parameter :: JSOURCE = 2 * NY / 3 + 1\n double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX\n double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY\n! angle of source force clockwise with respect to vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 135.d0\n\n! receivers\n integer, parameter :: NREC = 2\n double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters\n double precision, parameter :: xfin = xsource ! last receiver x in meters\n double precision, parameter :: yfin = 300.d0 ! last receiver y in meters\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 100\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 1.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(NX,NY,NZ_LOCAL) :: &\n memory_dvx_dx, &\n memory_dvx_dy, &\n memory_dvx_dz, &\n memory_dvy_dx, &\n memory_dvy_dy, &\n memory_dvy_dz, &\n memory_dvz_dx, &\n memory_dvz_dy, &\n memory_dvz_dz, &\n memory_dsigmaxx_dx, &\n memory_dsigmayy_dy, &\n memory_dsigmazz_dz, &\n memory_dsigmaxy_dx, &\n memory_dsigmaxy_dy, &\n memory_dsigmaxz_dx, &\n memory_dsigmaxz_dz, &\n memory_dsigmayz_dy, &\n memory_dsigmayz_dz\n\n double precision :: &\n value_dvx_dx, &\n value_dvx_dy, &\n value_dvx_dz, &\n value_dvy_dx, &\n value_dvy_dy, &\n value_dvy_dz, &\n value_dvz_dx, &\n value_dvz_dy, &\n value_dvz_dz, &\n value_dsigmaxx_dx, &\n value_dsigmayy_dy, &\n value_dsigmazz_dz, &\n value_dsigmaxy_dx, &\n value_dsigmaxy_dy, &\n value_dsigmaxz_dx, &\n value_dsigmaxz_dz, &\n value_dsigmayz_dy, &\n value_dsigmayz_dz\n\n! 1D arrays for the damping profiles\n 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\n 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\n 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\n\n! PML\n double precision thickness_PML_x,thickness_PML_y,thickness_PML_z\n double precision xoriginleft,xoriginright,yoriginbottom,yorigintop,zoriginbottom,zorigintop\n double precision Rcoef,d0_x,d0_y,d0_z,xval,yval,zval,abscissa_in_PML,abscissa_normalized\n\n! change dimension of Z axis to add two planes for MPI\n double precision, dimension(NX,NY,0:NZ_LOCAL+1) :: vx,vy,vz,sigmaxx,sigmayy,sigmazz,sigmaxy,sigmaxz,sigmayz\n\n integer, parameter :: number_of_arrays = 9 + 2*9\n\n! for the source\n double precision a,t,force_x,force_y,source_term\n\n! for receivers\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy\n\n! for evolution of total energy in the medium\n double precision :: epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz\n double precision :: total_energy_kinetic,total_energy_potential\n double precision, dimension(NSTEP) :: total_energy\n\n integer :: irec\n\n! precompute some parameters once and for all\n double precision, parameter :: DELTAT_lambda = DELTAT*lambda\n double precision, parameter :: DELTAT_mu = DELTAT*mu\n double precision, parameter :: DELTAT_lambdaplus2mu = DELTAT*lambdaplustwomu\n\n double precision, parameter :: DELTAT_over_rho = DELTAT/rho\n\n integer :: i,j,k,it\n\n double precision :: Vsolidnorm,Courant_number\n\n! timer to count elapsed time\n character(len=8) datein\n character(len=10) timein\n character(len=5) :: zone\n integer, dimension(8) :: time_values\n integer ihours,iminutes,iseconds,int_tCPU\n double precision :: time_start,time_end,tCPU\n\n! names of the time stamp files\n character(len=150) outputname\n\n! main I/O file\n integer, parameter :: IOUT = 41\n\n! array needed for MPI_RECV\n integer, dimension(MPI_STATUS_SIZE) :: message_status\n\n! tag of the message to send\n integer, parameter :: message_tag = 0\n\n! number of values to send or receive\n integer, parameter :: number_of_values = NX*NY\n\n integer :: nb_procs,rank,code,rank_cut_plane,kmin,kmax,kglobal,offset_k,k2begin,kminus1end\n integer :: sender_right_shift,receiver_right_shift,sender_left_shift,receiver_left_shift\n\n!---\n!--- program starts here\n!---\n\n! start MPI processes\n call MPI_INIT(code)\n\n! get total number of MPI processes in variable nb_procs\n call MPI_COMM_SIZE(MPI_COMM_WORLD, nb_procs, code)\n\n! get the rank of our process from 0 (master) to nb_procs-1 (workers)\n call MPI_COMM_RANK(MPI_COMM_WORLD, rank, code)\n\n! slice number for the cut plane in the middle of the mesh\n rank_cut_plane = nb_procs/2 - 1\n\n if (rank == rank_cut_plane) then\n\n print *\n print *,'3D elastic finite-difference code in velocity and stress formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *,'NZ = ',NZ\n print *\n print *,'NZ_LOCAL = ',NZ_LOCAL\n print *,'NPROC = ',NPROC\n print *\n print *,'size of the model along X = ',(NX - 1) * DELTAX\n print *,'size of the model along Y = ',(NY - 1) * DELTAY\n print *,'size of the model along Y = ',(NZ - 1) * DELTAZ\n print *\n print *,'Total number of grid points = ',NX * NY * NZ\n print *,'Number of points of all the arrays = ',dble(NX)*dble(NY)*dble(NZ)*number_of_arrays\n 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)\n print *\n print *,'In each slice:'\n print *\n print *,'Total number of grid points = ',NX * NY * NZ_LOCAL\n print *,'Number of points of the arrays = ',dble(NX)*dble(NY)*dble(NZ_LOCAL)*number_of_arrays\n 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)\n print *\n\n endif\n\n! check that code was compiled with the right number of slices\n if (nb_procs /= NPROC) then\n print *,'nb_procs,NPROC = ',nb_procs,NPROC\n stop 'nb_procs must be equal to NPROC'\n endif\n\n! we restrict ourselves to an even number of slices\n! in order to have a cut plane in the middle of the mesh for visualization purposes\n if (mod(nb_procs,2) /= 0) stop 'nb_procs must be even'\n\n! check that we can cut along Z in an exact number of slices\n if (mod(NZ,nb_procs) /= 0) stop 'NZ must be a multiple of nb_procs'\n\n! check that a slice is at least as thick as a PML layer\n if (NZ_LOCAL < NPOINTS_PML) stop 'NZ_LOCAL must be greater than NPOINTS_PML'\n\n! offset of this slice when we cut along Z\n offset_k = rank * NZ_LOCAL\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n thickness_PML_z = NPOINTS_PML * DELTAZ\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_y)\n d0_z = - (NPOWER + 1) * cp * log(Rcoef) / (2.d0 * thickness_PML_z)\n\n if (rank == rank_cut_plane) then\n print *\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *,'d0_z = ',d0_z\n endif\n\n! PML\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n d_z(:) = ZERO\n d_z_half(:) = ZERO\n K_z(:) = 1.d0\n K_z_half(:) = 1.d0\n alpha_z(:) = ZERO\n alpha_z_half(:) = ZERO\n a_z(:) = ZERO\n a_z_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- xmin edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- xmax edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- ymin edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- ymax edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! damping in the Z direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n zoriginbottom = thickness_PML_z\n zorigintop = (NZ-1)*DELTAZ - thickness_PML_z\n\n do k = 1,NZ\n\n! abscissa of current grid point along the damping profile\n zval = DELTAZ * dble(k-1)\n\n!---------- zmin edge\n if (USE_PML_ZMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = zoriginbottom - zval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_z\n d_z(k) = d0_z * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_z(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_z(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = zoriginbottom - (zval + DELTAZ/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_z\n d_z_half(k) = d0_z * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_z_half(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_z_half(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- zmax edge\n if (USE_PML_ZMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = zval - zorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_z\n d_z(k) = d0_z * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_z(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_z(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = zval + DELTAZ/2.d0 - zorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_z\n d_z_half(k) = d0_z * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_z_half(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_z_half(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_z(k) = exp(- (d_z(k) / K_z(k) + alpha_z(k)) * DELTAT)\n b_z_half(k) = exp(- (d_z_half(k) / K_z_half(k) + alpha_z_half(k)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_z_half(k)) > 1.d-6) a_z_half(k) = d_z_half(k) * &\n (b_z_half(k) - 1.d0) / (K_z_half(k) * (d_z_half(k) + K_z_half(k) * alpha_z_half(k)))\n\n enddo\n\n if (rank == rank_cut_plane) then\n\n! print position of the source\n print *\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *\n print *,'There are ',nrec,' receivers'\n print *\n xspacerec = (xfin-xdeb) / dble(NREC-1)\n yspacerec = (yfin-ydeb) / dble(NREC-1)\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n endif\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number = cp * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2 + 1.d0/DELTAZ**2)\n if (rank == rank_cut_plane) then\n print *,'Courant number is ',Courant_number\n print *\n endif\n if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable'\n\n! erase main arrays\n vx(:,:,:) = ZERO\n vy(:,:,:) = ZERO\n vz(:,:,:) = ZERO\n\n sigmaxy(:,:,:) = ZERO\n sigmayy(:,:,:) = ZERO\n sigmazz(:,:,:) = ZERO\n sigmaxz(:,:,:) = ZERO\n sigmazz(:,:,:) = ZERO\n sigmayz(:,:,:) = ZERO\n\n! PML\n memory_dvx_dx(:,:,:) = ZERO\n memory_dvx_dy(:,:,:) = ZERO\n memory_dvx_dz(:,:,:) = ZERO\n memory_dvy_dx(:,:,:) = ZERO\n memory_dvy_dy(:,:,:) = ZERO\n memory_dvy_dz(:,:,:) = ZERO\n memory_dvz_dx(:,:,:) = ZERO\n memory_dvz_dy(:,:,:) = ZERO\n memory_dvz_dz(:,:,:) = ZERO\n memory_dsigmaxx_dx(:,:,:) = ZERO\n memory_dsigmayy_dy(:,:,:) = ZERO\n memory_dsigmazz_dz(:,:,:) = ZERO\n memory_dsigmaxy_dx(:,:,:) = ZERO\n memory_dsigmaxy_dy(:,:,:) = ZERO\n memory_dsigmaxz_dx(:,:,:) = ZERO\n memory_dsigmaxz_dz(:,:,:) = ZERO\n memory_dsigmayz_dy(:,:,:) = ZERO\n memory_dsigmayz_dz(:,:,:) = ZERO\n\n! erase seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n\n! initialize total energy\n total_energy(:) = ZERO\n\n call date_and_time(datein,timein,zone,time_values)\n! time_values(3): day of the month\n! time_values(5): hour of the day\n! time_values(6): minutes of the hour\n! time_values(7): seconds of the minute\n! time_values(8): milliseconds of the second\n! this fails if we cross the end of the month\n time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &\n 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0\n\n!---\n\n! we receive from the process on the left, and send to the process on the right\n sender_right_shift = rank - 1\n receiver_right_shift = rank + 1\n\n! if we are the first process, there is no neighbor on the left\n if (rank == 0) sender_right_shift = MPI_PROC_NULL\n\n! if we are the last process, there is no neighbor on the right\n if (rank == nb_procs - 1) receiver_right_shift = MPI_PROC_NULL\n\n!---\n\n! we receive from the process on the right, and send to the process on the left\n sender_left_shift = rank + 1\n receiver_left_shift = rank - 1\n\n! if we are the first process, there is no neighbor on the left\n if (rank == 0) receiver_left_shift = MPI_PROC_NULL\n\n! if we are the last process, there is no neighbor on the right\n if (rank == nb_procs - 1) sender_left_shift = MPI_PROC_NULL\n\n k2begin = 1\n if (rank == 0) k2begin = 2\n\n kminus1end = NZ_LOCAL\n if (rank == nb_procs - 1) kminus1end = NZ_LOCAL - 1\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n if (rank == rank_cut_plane) print *,'it = ',it\n\n!----------------------\n! compute stress sigma\n!----------------------\n\n! vx(k+1), left shift\n call MPI_SENDRECV(vx(:,:,1),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_left_shift,message_tag,vx(:,:,NZ_LOCAL+1),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n! vy(k+1), left shift\n call MPI_SENDRECV(vy(:,:,1),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_left_shift,message_tag,vy(:,:,NZ_LOCAL+1),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n! vz(k-1), right shift\n call MPI_SENDRECV(vz(:,:,NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_right_shift,message_tag,vz(:,:,0),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, &\n!$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, &\n!$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, &\n!$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, &\n!$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, &\n!$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, &\n!$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, &\n!$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, &\n!$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, &\n!$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, &\n!$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)\n do k=k2begin,NZ_LOCAL\n kglobal = k + offset_k\n do j=2,NY\n do i=1,NX-1\n\n value_dvx_dx = (vx(i+1,j,k)-vx(i,j,k)) * ONE_OVER_DELTAX\n value_dvy_dy = (vy(i,j,k)-vy(i,j-1,k)) * ONE_OVER_DELTAY\n value_dvz_dz = (vz(i,j,k)-vz(i,j,k-1)) * ONE_OVER_DELTAZ\n\n memory_dvx_dx(i,j,k) = b_x_half(i) * memory_dvx_dx(i,j,k) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j,k) = b_y(j) * memory_dvy_dy(i,j,k) + a_y(j) * value_dvy_dy\n memory_dvz_dz(i,j,k) = b_z(kglobal) * memory_dvz_dz(i,j,k) + a_z(kglobal) * value_dvz_dz\n\n value_dvx_dx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j,k)\n value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j,k)\n value_dvz_dz = value_dvz_dz / K_z(kglobal) + memory_dvz_dz(i,j,k)\n\n sigmaxx(i,j,k) = DELTAT_lambdaplus2mu*value_dvx_dx + &\n DELTAT_lambda*(value_dvy_dy + value_dvz_dz) + sigmaxx(i,j,k)\n\n sigmayy(i,j,k) = DELTAT_lambda*(value_dvx_dx + value_dvz_dz) + &\n DELTAT_lambdaplus2mu*value_dvy_dy + sigmayy(i,j,k)\n\n sigmazz(i,j,k) = DELTAT_lambda*(value_dvx_dx + value_dvy_dy) + DELTAT_lambdaplus2mu*value_dvz_dz + sigmazz(i,j,k)\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, &\n!$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, &\n!$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, &\n!$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, &\n!$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, &\n!$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, &\n!$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, &\n!$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, &\n!$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, &\n!$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, &\n!$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)\n do k=1,NZ_LOCAL\n do j=1,NY-1\n do i=2,NX\n\n value_dvy_dx = (vy(i,j,k)-vy(i-1,j,k)) * ONE_OVER_DELTAX\n value_dvx_dy = (vx(i,j+1,k)-vx(i,j,k)) * ONE_OVER_DELTAY\n\n memory_dvy_dx(i,j,k) = b_x(i) * memory_dvy_dx(i,j,k) + a_x(i) * value_dvy_dx\n memory_dvx_dy(i,j,k) = b_y_half(j) * memory_dvx_dy(i,j,k) + a_y_half(j) * value_dvx_dy\n\n value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j,k)\n value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j,k)\n\n sigmaxy(i,j,k) = DELTAT_mu*(value_dvy_dx + value_dvx_dy) + sigmaxy(i,j,k)\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, &\n!$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, &\n!$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, &\n!$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, &\n!$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, &\n!$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, &\n!$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, &\n!$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, &\n!$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, &\n!$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, &\n!$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)\n do k=1,kminus1end\n kglobal = k + offset_k\n do j=1,NY\n do i=2,NX\n\n value_dvz_dx = (vz(i,j,k)-vz(i-1,j,k)) * ONE_OVER_DELTAX\n value_dvx_dz = (vx(i,j,k+1)-vx(i,j,k)) * ONE_OVER_DELTAZ\n\n memory_dvz_dx(i,j,k) = b_x(i) * memory_dvz_dx(i,j,k) + a_x(i) * value_dvz_dx\n memory_dvx_dz(i,j,k) = b_z_half(kglobal) * memory_dvx_dz(i,j,k) + a_z_half(kglobal) * value_dvx_dz\n\n value_dvz_dx = value_dvz_dx / K_x(i) + memory_dvz_dx(i,j,k)\n value_dvx_dz = value_dvx_dz / K_z_half(kglobal) + memory_dvx_dz(i,j,k)\n\n sigmaxz(i,j,k) = DELTAT_mu*(value_dvz_dx + value_dvx_dz) + sigmaxz(i,j,k)\n\n enddo\n enddo\n\n do j=1,NY-1\n do i=1,NX\n\n value_dvz_dy = (vz(i,j+1,k)-vz(i,j,k)) * ONE_OVER_DELTAY\n value_dvy_dz = (vy(i,j,k+1)-vy(i,j,k)) * ONE_OVER_DELTAZ\n\n memory_dvz_dy(i,j,k) = b_y_half(j) * memory_dvz_dy(i,j,k) + a_y_half(j) * value_dvz_dy\n memory_dvy_dz(i,j,k) = b_z_half(kglobal) * memory_dvy_dz(i,j,k) + a_z_half(kglobal) * value_dvy_dz\n\n value_dvz_dy = value_dvz_dy / K_y_half(j) + memory_dvz_dy(i,j,k)\n value_dvy_dz = value_dvy_dz / K_z_half(kglobal) + memory_dvy_dz(i,j,k)\n\n sigmayz(i,j,k) = DELTAT_mu*(value_dvz_dy + value_dvy_dz) + sigmayz(i,j,k)\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n!------------------\n! compute velocity\n!------------------\n\n! sigmazz(k+1), left shift\n call MPI_SENDRECV(sigmazz(:,:,1),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_left_shift,message_tag,sigmazz(:,:,NZ_LOCAL+1),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n! sigmayz(k-1), right shift\n call MPI_SENDRECV(sigmayz(:,:,NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_right_shift,message_tag,sigmayz(:,:,0),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n! sigmaxz(k-1), right shift\n call MPI_SENDRECV(sigmaxz(:,:,NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_right_shift,message_tag,sigmaxz(:,:,0),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, &\n!$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, &\n!$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, &\n!$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, &\n!$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, &\n!$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, &\n!$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, &\n!$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, &\n!$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, &\n!$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, &\n!$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)\n do k=k2begin,NZ_LOCAL\n kglobal = k + offset_k\n do j=2,NY\n do i=2,NX\n\n value_dsigmaxx_dx = (sigmaxx(i,j,k)-sigmaxx(i-1,j,k)) * ONE_OVER_DELTAX\n value_dsigmaxy_dy = (sigmaxy(i,j,k)-sigmaxy(i,j-1,k)) * ONE_OVER_DELTAY\n value_dsigmaxz_dz = (sigmaxz(i,j,k)-sigmaxz(i,j,k-1)) * ONE_OVER_DELTAZ\n\n memory_dsigmaxx_dx(i,j,k) = b_x(i) * memory_dsigmaxx_dx(i,j,k) + a_x(i) * value_dsigmaxx_dx\n memory_dsigmaxy_dy(i,j,k) = b_y(j) * memory_dsigmaxy_dy(i,j,k) + a_y(j) * value_dsigmaxy_dy\n memory_dsigmaxz_dz(i,j,k) = b_z(kglobal) * memory_dsigmaxz_dz(i,j,k) + a_z(kglobal) * value_dsigmaxz_dz\n\n value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j,k)\n value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j,k)\n value_dsigmaxz_dz = value_dsigmaxz_dz / K_z(kglobal) + memory_dsigmaxz_dz(i,j,k)\n\n vx(i,j,k) = DELTAT_over_rho*(value_dsigmaxx_dx + value_dsigmaxy_dy + value_dsigmaxz_dz) + vx(i,j,k)\n\n enddo\n enddo\n\n do j=1,NY-1\n do i=1,NX-1\n\n value_dsigmaxy_dx = (sigmaxy(i+1,j,k)-sigmaxy(i,j,k)) * ONE_OVER_DELTAX\n value_dsigmayy_dy = (sigmayy(i,j+1,k)-sigmayy(i,j,k)) * ONE_OVER_DELTAY\n value_dsigmayz_dz = (sigmayz(i,j,k)-sigmayz(i,j,k-1)) * ONE_OVER_DELTAZ\n\n memory_dsigmaxy_dx(i,j,k) = b_x_half(i) * memory_dsigmaxy_dx(i,j,k) + a_x_half(i) * value_dsigmaxy_dx\n memory_dsigmayy_dy(i,j,k) = b_y_half(j) * memory_dsigmayy_dy(i,j,k) + a_y_half(j) * value_dsigmayy_dy\n memory_dsigmayz_dz(i,j,k) = b_z(kglobal) * memory_dsigmayz_dz(i,j,k) + a_z(kglobal) * value_dsigmayz_dz\n\n value_dsigmaxy_dx = value_dsigmaxy_dx / K_x_half(i) + memory_dsigmaxy_dx(i,j,k)\n value_dsigmayy_dy = value_dsigmayy_dy / K_y_half(j) + memory_dsigmayy_dy(i,j,k)\n value_dsigmayz_dz = value_dsigmayz_dz / K_z(kglobal) + memory_dsigmayz_dz(i,j,k)\n\n vy(i,j,k) = DELTAT_over_rho*(value_dsigmaxy_dx + value_dsigmayy_dy + value_dsigmayz_dz) + vy(i,j,k)\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(kglobal,i,j,k,value_dvx_dx,value_dvx_dy, &\n!$OMP value_dvx_dz,value_dvy_dx,value_dvy_dy,value_dvy_dz,value_dvz_dx,value_dvz_dy, &\n!$OMP value_dvz_dz,value_dsigmaxx_dx,value_dsigmayy_dy,value_dsigmazz_dz, &\n!$OMP value_dsigmaxy_dx,value_dsigmaxy_dy,value_dsigmaxz_dx,value_dsigmaxz_dz, &\n!$OMP value_dsigmayz_dy,value_dsigmayz_dz) SHARED(vx,vy,vz,sigmaxx,sigmayy,sigmazz, &\n!$OMP sigmaxy,sigmaxz,sigmayz,memory_dvx_dx,memory_dvx_dy,memory_dvx_dz, &\n!$OMP memory_dvy_dx,memory_dvy_dy,memory_dvy_dz,memory_dvz_dx,memory_dvz_dy, &\n!$OMP memory_dvz_dz,memory_dsigmaxx_dx,memory_dsigmayy_dy,memory_dsigmazz_dz, &\n!$OMP memory_dsigmaxy_dx,memory_dsigmaxy_dy,memory_dsigmaxz_dx,memory_dsigmaxz_dz, &\n!$OMP memory_dsigmayz_dy,memory_dsigmayz_dz,a_x,b_x,K_x,a_x_half,b_x_half,K_x_half, &\n!$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)\n do k=1,kminus1end\n kglobal = k + offset_k\n do j=2,NY\n do i=1,NX-1\n\n value_dsigmaxz_dx = (sigmaxz(i+1,j,k)-sigmaxz(i,j,k)) * ONE_OVER_DELTAX\n value_dsigmayz_dy = (sigmayz(i,j,k)-sigmayz(i,j-1,k)) * ONE_OVER_DELTAY\n value_dsigmazz_dz = (sigmazz(i,j,k+1)-sigmazz(i,j,k)) * ONE_OVER_DELTAZ\n\n memory_dsigmaxz_dx(i,j,k) = b_x_half(i) * memory_dsigmaxz_dx(i,j,k) + a_x_half(i) * value_dsigmaxz_dx\n memory_dsigmayz_dy(i,j,k) = b_y(j) * memory_dsigmayz_dy(i,j,k) + a_y(j) * value_dsigmayz_dy\n memory_dsigmazz_dz(i,j,k) = b_z_half(kglobal) * memory_dsigmazz_dz(i,j,k) + a_z_half(kglobal) * value_dsigmazz_dz\n\n value_dsigmaxz_dx = value_dsigmaxz_dx / K_x_half(i) + memory_dsigmaxz_dx(i,j,k)\n value_dsigmayz_dy = value_dsigmayz_dy / K_y(j) + memory_dsigmayz_dy(i,j,k)\n value_dsigmazz_dz = value_dsigmazz_dz / K_z_half(kglobal) + memory_dsigmazz_dz(i,j,k)\n\n vz(i,j,k) = DELTAT_over_rho*(value_dsigmaxz_dx + value_dsigmayz_dy + value_dsigmazz_dz) + vz(i,j,k)\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n if (rank == rank_cut_plane) then\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! source_term = factor * exp(-a*(t-t0)**2)\n\n! first derivative of a Gaussian\n source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n! here in this demo code we put the source in the middle of the model in the Z direction,\n! i.e. in NZ/2, which means putting it in the cut plane (i.e. only the processor for which\n! rank == rank_cut_plane will do it, and it will put it in its last point along Z, in NZ_LOCAL\n vx(i,j,NZ_LOCAL) = vx(i,j,NZ_LOCAL) + force_x * DELTAT / rho\n vy(i,j,NZ_LOCAL) = vy(i,j,NZ_LOCAL) + force_y * DELTAT / rho\n\n endif\n\n! implement Dirichlet boundary conditions on the six edges of the grid\n\n!$OMP PARALLEL WORKSHARE\n! xmin\n vx(1,:,:) = ZERO\n vy(1,:,:) = ZERO\n vz(1,:,:) = ZERO\n\n! xmax\n vx(NX,:,:) = ZERO\n vy(NX,:,:) = ZERO\n vz(NX,:,:) = ZERO\n\n! ymin\n vx(:,1,:) = ZERO\n vy(:,1,:) = ZERO\n vz(:,1,:) = ZERO\n\n! ymax\n vx(:,NY,:) = ZERO\n vy(:,NY,:) = ZERO\n vz(:,NY,:) = ZERO\n!$OMP END PARALLEL WORKSHARE\n\n! zmin\n if (rank == 0) then\n vx(:,:,1) = ZERO\n vy(:,:,1) = ZERO\n vz(:,:,1) = ZERO\n endif\n\n! zmax\n if (rank == nb_procs-1) then\n vx(:,:,NZ_LOCAL) = ZERO\n vy(:,:,NZ_LOCAL) = ZERO\n vz(:,:,NZ_LOCAL) = ZERO\n endif\n\n! store seismograms\n if (rank == rank_cut_plane) then\n do irec = 1,NREC\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec),NZ_LOCAL)\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec),NZ_LOCAL)\n enddo\n endif\n\n! compute total energy in the medium (without the PML layers)\n total_energy_kinetic = ZERO\n total_energy_potential = ZERO\n\n kmin = 1\n kmax = NZ_LOCAL\n if (rank == 0) kmin = NPOINTS_PML+1\n if (rank == nb_procs-1) kmax = NZ_LOCAL-NPOINTS_PML\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz) &\n!$OMP SHARED(kmin,kmax,vx,vy,vz,sigmaxx,sigmayy,sigmazz, &\n!$OMP sigmaxy,sigmaxz,sigmayz) REDUCTION(+:total_energy_kinetic,total_energy_potential)\n do k = kmin,kmax\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n! in principle we should use rho_half_x_half_y instead of rho for vy\n! in order to interpolate density at the right location in the staggered grid cell\n! but in a homogeneous medium we can safely ignore it\n total_energy_kinetic = total_energy_kinetic + 0.5d0 * rho*( &\n vx(i,j,k)**2 + vy(i,j,k)**2 + vz(i,j,k)**2)\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n! in principle we should interpolate the medium parameters at the right location\n! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n\n! compute total field from split components\n epsilon_xx = (2.d0*(lambda + mu) * sigmaxx(i,j,k) - lambda * sigmayy(i,j,k) - &\n lambda*sigmazz(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu))\n epsilon_yy = (2.d0*(lambda + mu) * sigmayy(i,j,k) - lambda * sigmaxx(i,j,k) - &\n lambda*sigmazz(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu))\n epsilon_zz = (2.d0*(lambda + mu) * sigmazz(i,j,k) - lambda * sigmaxx(i,j,k) - &\n lambda*sigmayy(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu))\n epsilon_xy = sigmaxy(i,j,k) / (2.d0 * mu)\n epsilon_xz = sigmaxz(i,j,k) / (2.d0 * mu)\n epsilon_yz = sigmayz(i,j,k) / (2.d0 * mu)\n\n total_energy_potential = total_energy_potential + &\n 0.5d0 * (epsilon_xx * sigmaxx(i,j,k) + epsilon_yy * sigmayy(i,j,k) + &\n epsilon_yy * sigmayy(i,j,k)+ 2.d0 * epsilon_xy * sigmaxy(i,j,k) + &\n 2.d0*epsilon_xz * sigmaxz(i,j,k)+2.d0*epsilon_yz * sigmayz(i,j,k))\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n call MPI_REDUCE(total_energy_kinetic + total_energy_potential,total_energy(it),1, &\n MPI_DOUBLE_PRECISION,MPI_SUM,rank_cut_plane,MPI_COMM_WORLD,code)\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n call MPI_REDUCE(maxval(sqrt(vx(:,:,1:NZ_LOCAL)**2 + vy(:,:,1:NZ_LOCAL)**2 + &\n vz(:,:,1:NZ_LOCAL)**2)),Vsolidnorm,1,MPI_DOUBLE_PRECISION,MPI_MAX,rank_cut_plane,MPI_COMM_WORLD,code)\n\n if (rank == rank_cut_plane) then\n\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',Vsolidnorm\n print *,'Total energy = ',total_energy(it)\n! check stability of the code, exit if unstable\n if (Vsolidnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up in solid'\n\n! count elapsed wall-clock time\n call date_and_time(datein,timein,zone,time_values)\n! time_values(3): day of the month\n! time_values(5): hour of the day\n! time_values(6): minutes of the hour\n! time_values(7): seconds of the minute\n! time_values(8): milliseconds of the second\n! this fails if we cross the end of the month\n time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &\n 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0\n\n! elapsed time since beginning of the simulation\n tCPU = time_end - time_start\n int_tCPU = int(tCPU)\n ihours = int_tCPU / 3600\n iminutes = (int_tCPU - 3600*ihours) / 60\n iseconds = int_tCPU - 3600*ihours - 60*iminutes\n write(*,*) 'Elapsed time in seconds = ',tCPU\n write(*,\"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')\") ihours,iminutes,iseconds\n write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)\n write(*,*)\n\n! write time stamp file to give information about progression of simulation\n write(outputname,\"('timestamp',i6.6)\") it\n open(unit=IOUT,file=outputname,status='unknown')\n write(IOUT,*) 'Time step # ',it\n write(IOUT,*) 'Time: ',sngl((it-1)*DELTAT),' seconds'\n write(IOUT,*) 'Max norm velocity vector V (m/s) = ',Vsolidnorm\n write(IOUT,*) 'Total energy = ',total_energy(it)\n write(IOUT,*) 'Elapsed time in seconds = ',tCPU\n write(IOUT,\"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')\") ihours,iminutes,iseconds\n write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)\n close(IOUT)\n\n! save seismograms\n print *,'saving seismograms'\n print *\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n\n call create_color_image(vx(:,:,NZ_LOCAL),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)\n call create_color_image(vy(:,:,NZ_LOCAL),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)\n\n endif\n endif\n\n! --- end of time loop\n enddo\n\n if (rank == rank_cut_plane) then\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),total_energy(it)\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"CPML3D_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" t ''Total energy'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vz_receiver_001.eps\"'\n write(20,*) 'plot \"Vz_file_001.dat\" t ''Vz C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vz_receiver_002.eps\"'\n write(20,*) 'plot \"Vz_file_002.dat\" t ''Vz C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n endif\n\n! close MPI program\n call MPI_FINALIZE(code)\n\n end program seismic_CPML_3D_iso_MPI_OpenMP\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_CPML_3D_viscoelastic_MPI.f90", "content": "!\n! SEISMIC_CPML Version 1.2, April 2015.\n!\n! Copyright CNRS, France.\n! Contributors: Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr\n! and Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! April 2015: Dimitri Komatitsch added support for the SolvOpt algorithm to compute\n! the attenuation parameters in an optimized way. If you use it please cite:\n!\n! @Article{BlKoChLoXi15,\n! Title = {Positivity-preserving highly-accurate optimization of the {Z}ener viscoelastic model, with application\n! to wave propagation in the presence of strong attenuation},\n! Author = {\\'Emilie Blanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard and Zhinan Xie},\n! Journal = {Geophysical Journal International},\n! Year = {2015},\n! Note = {in press.}}\n!\n! This software is a computer program whose purpose is to solve\n! the three-dimensional isotropic viscoelastic wave equation\n! using a fourth order finite-difference method with Convolutional Perfectly Matched Layer (C-PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_visco_CPML_3D_MPI_OpenMP\n\n! 3D fourth order viscoelastic finite-difference code in velocity and stress formulation\n! with Convolutional-PML (C-PML) absorbing conditions using 2 mechanisms of attenuation\n! with 6 equations per mechanism.\n\n! Roland Martin, University of Pau, France, October 2009.\n! based on the elastic code of Komatitsch and Martin, 2007.\n! April 2015: Dimitri Komatitsch added support for the SolvOpt algorithm to compute\n! the attenuation parameters in an optimized way.\n\n! The fourth-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used.\n\n! *BEWARE* that the attenuation model implemented below is that of J. M. Carcione,\n! Seismic modeling in viscoelastic media, Geophysics, vol. 58(1), p. 110-120 (1993), which is NON causal,\n! i.e., waves speed up instead of slowing down when turning attenuation on.\n! This comes from the fact that in that model the relaxed state at zero frequency is used as a reference instead of\n! the unrelaxed state at infinite frequency. These days a causal model should be used instead,\n! i.e. one using the unrelaxed state at infinite frequency as a reference.\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n!\n! Parallel implementation based on MPI.\n\n! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).\n! If you use this code for your own research, please cite some (or all) of these articles:\n!\n! @Article{BlKoChLoXi15,\n! Title = {Positivity-preserving highly-accurate optimization of the {Z}ener viscoelastic model, with application\n! to wave propagation in the presence of strong attenuation},\n! Author = {\\'Emilie Blanc and Dimitri Komatitsch and Emmanuel Chaljub and Bruno Lombard and Zhinan Xie},\n! Journal = {Geophysical Journal International},\n! Year = {2015},\n! Note = {in press.}}\n!\n! @ARTICLE{MaKo09,\n! author = {Roland Martin and Dimitri Komatitsch},\n! title = {An unsplit convolutional perfectly matched layer technique improved\n! at grazing incidence for the viscoelastic wave equation},\n! journal = {Geophysical Journal International},\n! year = {2009},\n! volume = {179},\n! pages = {333-344},\n! number = {1},\n! doi = {10.1111/j.1365-246X.2009.04278.x}}\n!\n! @ARTICLE{MaKoEz08,\n! author = {Roland Martin and Dimitri Komatitsch and Abdela\\^aziz Ezziani},\n! title = {An unsplit convolutional perfectly matched layer improved at grazing\n! incidence for seismic wave equation in poroelastic media},\n! journal = {Geophysics},\n! year = {2008},\n! volume = {73},\n! pages = {T51-T61},\n! number = {4},\n! doi = {10.1190/1.2939484}}\n!\n! @ARTICLE{MaKoGe08,\n! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},\n! title = {A variational formulation of a stabilized unsplit convolutional perfectly\n! matched layer for the isotropic or anisotropic seismic wave equation},\n! journal = {Computer Modeling in Engineering and Sciences},\n! year = {2008},\n! volume = {37},\n! pages = {274-304},\n! number = {3}}\n!\n! @ARTICLE{KoMa07,\n! author = {Dimitri Komatitsch and Roland Martin},\n! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved\n! at grazing incidence for the seismic wave equation},\n! journal = {Geophysics},\n! year = {2007},\n! volume = {72},\n! number = {5},\n! pages = {SM155-SM167},\n! doi = {10.1190/1.2757586}}\n!\n! The original CPML technique for Maxwell's equations is described in:\n!\n! @ARTICLE{RoGe00,\n! author = {J. A. Roden and S. D. Gedney},\n! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation\n! of the {CFS}-{PML} for Arbitrary Media},\n! journal = {Microwave and Optical Technology Letters},\n! year = {2000},\n! volume = {27},\n! number = {5},\n! pages = {334-339},\n! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}\n\n!\n! To display the results as color images in the selected 2D cut plane, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n use mpi\n\n implicit none\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 210\n integer, parameter :: NY = 800\n integer, parameter :: NZ = 220 ! even number in order to cut along Z axis\n\n! number of processes used in the MPI run\n! and local number of points (for simplicity we cut the mesh along Z only)\n integer, parameter :: NPROC = 4 !! 20\n integer, parameter :: NZ_LOCAL = NZ / NPROC\n\n! size of a grid cell\n double precision, parameter :: DELTAX = 4.d0, ONE_OVER_DELTAX = 1.d0 / DELTAX\n double precision, parameter :: DELTAY = DELTAX, DELTAZ = DELTAX\n double precision, parameter :: ONE_OVER_DELTAY = ONE_OVER_DELTAX, ONE_OVER_DELTAZ = ONE_OVER_DELTAX\n double precision, parameter :: ONE=1.d0,TWO=2.d0, DIM=3.d0\n\n! P-velocity, S-velocity and density\n double precision, parameter :: cp = 3000.d0\n double precision, parameter :: cs = 2000.d0\n double precision, parameter :: rho = 2000.d0\n double precision, parameter :: mu = rho*cs*cs\n double precision, parameter :: lambda = rho*(cp*cp - 2.d0*cs*cs)\n double precision, parameter :: lambdaplustwomu = rho*cp*cp\n\n! total number of time steps\n integer, parameter :: NSTEP = 100000\n\n! time step in seconds\n double precision, parameter :: DELTAT = 4.d-4\n\n! parameters for the source\n double precision, parameter :: f0 = 18.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d7\n\n! parameters for attenuation\n! number of standard linear solids\n integer, parameter :: N_SLS = 2\n\n! Qp approximately equal to 13, Qkappa approximately to 20 and Qmu / Qs approximately to 10\n double precision, parameter :: QKappa_att = 20.d0, QMu_att = 10.d0\n double precision, parameter :: f0_attenuation = 16 ! in Hz\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n logical, parameter :: USE_PML_ZMIN = .true.\n logical, parameter :: USE_PML_ZMAX = .true.\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! source\n! integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1\n integer, parameter :: ISOURCE = NPOINTS_PML+20\n integer, parameter :: JSOURCE = NY / 5 + 1\n double precision, parameter :: xsource = (ISOURCE) * DELTAX\n double precision, parameter :: ysource = (JSOURCE) * DELTAY\n! angle of source force clockwise with respect to vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 0.d0\n\n! receivers\n integer, parameter :: NREC = 3\n double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters\n double precision, parameter :: xfin = xsource ! last receiver x in meters\n double precision, parameter :: yfin = 300.d0 ! last receiver y in meters\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 10000\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! power to compute d0 profile\n double precision, parameter :: NPOWER = 2.d0\n\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11\n double precision, parameter :: K_MAX_PML = 7.d0\n double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte\n\n! arrays for the memory variables\n! could declare these arrays in PML only to save a lot of memory, but proof of concept only here\n double precision, dimension(0:NX+1,0:NY+1,-1:NZ_LOCAL+2) :: &\n memory_dvx_dx, &\n memory_dvx_dy, &\n memory_dvx_dz, &\n memory_dvy_dx, &\n memory_dvy_dy, &\n memory_dvy_dz, &\n memory_dvz_dx, &\n memory_dvz_dy, &\n memory_dvz_dz, &\n memory_dsigmaxx_dx, &\n memory_dsigmayy_dy, &\n memory_dsigmazz_dz, &\n memory_dsigmaxy_dx, &\n memory_dsigmaxy_dy, &\n memory_dsigmaxz_dx, &\n memory_dsigmaxz_dz, &\n memory_dsigmayz_dy, &\n memory_dsigmayz_dz\n\n double precision :: &\n value_dvx_dx, &\n value_dvx_dy, &\n value_dvx_dz, &\n value_dvy_dx, &\n value_dvy_dy, &\n value_dvy_dz, &\n value_dvz_dx, &\n value_dvz_dy, &\n value_dvz_dz, &\n value_dsigmaxx_dx, &\n value_dsigmayy_dy, &\n value_dsigmazz_dz, &\n value_dsigmaxy_dx, &\n value_dsigmaxy_dy, &\n value_dsigmaxz_dx, &\n value_dsigmaxz_dz, &\n value_dsigmayz_dy, &\n value_dsigmayz_dz\n\n double precision :: duxdx,duxdy,duxdz,duydx,duydy,duydz,duzdx,duzdy,duzdz,div\n\n! 1D arrays for the damping profiles\n 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\n 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\n 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\n\n! PML\n double precision thickness_PML_x,thickness_PML_y,thickness_PML_z\n double precision xoriginleft,xoriginright,yoriginbottom,yorigintop,zoriginbottom,zorigintop\n double precision Rcoef,d0_x,d0_y,d0_z,xval,yval,zval,abscissa_in_PML,abscissa_normalized\n\n! change dimension of Z axis to add two planes for MPI\n double precision, dimension(0:NX+1,0:NY+1,-1:NZ_LOCAL+2) :: vx,vy,vz,sigmaxx,sigmayy,sigmazz,sigmaxy,sigmaxz,sigmayz\n 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\n double precision, dimension(N_SLS,0:NX+1,0:NY+1,-1:NZ_LOCAL+2) :: e1,e11,e22,e12,e13,e23\n\n integer, parameter :: number_of_arrays = 9 + 2*9 + 12\n\n! for the source\n double precision a,t,force_x,force_y,source_term\n\n! for attenuation\n double precision :: f_min_attenuation, f_max_attenuation\n double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,tau_epsilon_nu2,tau_sigma_nu2\n\n! for receivers\n double precision distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n\n! for seismograms\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy\n\n! max amplitude for color snapshots\n double precision max_amplitudeVx\n double precision max_amplitudeVy\n\n! for evolution of total energy in the medium\n double precision :: epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz\n double precision, dimension(NSTEP) :: total_energy,total_energy_kinetic,total_energy_potential\n double precision :: local_energy_kinetic,local_energy_potential\n\n integer :: irec\n\n! precompute some parameters once and for all\n double precision, parameter :: DELTAT_lambda = DELTAT*lambda\n double precision, parameter :: DELTAT_mu = DELTAT*mu\n double precision, parameter :: DELTAT_lambdaplus2mu = DELTAT*lambdaplustwomu\n\n double precision, parameter :: DELTAT_over_rho = DELTAT/rho\n double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed\n double precision :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed\n double precision :: Un,Sn,Unp1,Mu_nu1,Mu_nu2\n double precision :: phi_nu1(N_SLS)\n double precision :: phi_nu2(N_SLS)\n double precision :: tauinv,inv_tau_sigma_nu1(N_SLS)\n double precision :: taumin,taumax,tau1,tau2,tau3,tau4\n double precision :: inv_tau_sigma_nu2(N_SLS)\n double precision :: tauinvUn\n\n integer :: i,j,k,it,it2\n\n double precision :: Vsolidnorm,Courant_number\n\n! timer to count elapsed time\n character(len=8) datein\n character(len=10) timein\n character(len=5) :: zone\n integer, dimension(8) :: time_values\n integer ihours,iminutes,iseconds,int_tCPU\n double precision :: time_start,time_end,tCPU\n\n! names of the time stamp files\n character(len=150) outputname\n\n! main I/O file\n integer, parameter :: IOUT = 41\n\n! array needed for MPI_RECV\n integer, dimension(MPI_STATUS_SIZE) :: message_status\n\n! tag of the message to send\n integer, parameter :: message_tag = 0\n\n! number of values to send or receive\n integer, parameter :: number_of_values = 2*(NX+2)*(NY+2)\n\n integer :: nb_procs,rank,code,rank_cut_plane,kmin,kmax,kglobal,offset_k,k2begin,kminus1end\n integer :: sender_right_shift,receiver_right_shift,sender_left_shift,receiver_left_shift\n\n!---\n!--- program starts here\n!---\n\n! start MPI processes\n call MPI_INIT(code)\n\n! get total number of MPI processes in variable nb_procs\n call MPI_COMM_SIZE(MPI_COMM_WORLD, nb_procs, code)\n\n! get the rank of our process from 0 (master) to nb_procs-1 (workers)\n call MPI_COMM_RANK(MPI_COMM_WORLD, rank, code)\n\n! attenuation constants for standard linear solids\n! nu1 is the dilatation/incompressibility mode (QKappa)\n! nu2 is the shear mode (Qmu)\n! array index (1) is the first standard linear solid, (2) is the second etc.\n\n! from J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,\n! vol. 58(1), p. 110-120 (1993) for two memory-variable mechanisms (page 112).\n! Beware: these values implement specific values of the quality factors:\n! Qp approximately equal to 13, Qkappa approximately to 20 and Qmu / Qs approximately to 10,\n! which means very high attenuation, see that paper for details.\n! tau_epsilon_nu1(1) = 0.0334d0\n! tau_sigma_nu1(1) = 0.0303d0\n\n! tau_epsilon_nu2(1) = 0.0352d0\n! tau_sigma_nu2(1) = 0.0287d0\n\n! tau_epsilon_nu1(2) = 0.0028d0\n! tau_sigma_nu1(2) = 0.0025d0\n\n! tau_epsilon_nu2(2) = 0.0029d0\n! tau_sigma_nu2(2) = 0.0024d0\n\n! from J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation\n! in a linear viscoelastic medium, Geophysical Journal International,\n! vol. 95, p. 597-611 (1988) for two memory-variable mechanisms (page 604).\n! Beware: these values implement specific values of the quality factors:\n! Qkappa approximately to 27 and Qmu / Qs approximately to 20,\n! which means very high attenuation, see that paper for details.\n\n! tau_epsilon_nu1(1) = 0.0325305d0\n! tau_sigma_nu1(1) = 0.0311465d0\n\n! tau_epsilon_nu2(1) = 0.0332577d0\n! tau_sigma_nu2(1) = 0.0304655d0\n\n! tau_epsilon_nu1(2) = 0.0032530d0\n! tau_sigma_nu1(2) = 0.0031146d0\n\n! tau_epsilon_nu2(2) = 0.0033257d0\n! tau_sigma_nu2(2) = 0.0030465d0\n\n! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0)\n f_min_attenuation = exp(log(f0_attenuation)-log(12.d0)/2.d0)\n f_max_attenuation = 12.d0 * f_min_attenuation\n\n! use new SolvOpt nonlinear optimization with constraints from Emilie Blanc, Bruno Lombard and Dimitri Komatitsch\n! to compute attenuation mechanisms\n call compute_attenuation_coeffs(N_SLS,QKappa_att,f0_attenuation,f_min_attenuation,f_max_attenuation, &\n tau_epsilon_nu1,tau_sigma_nu1)\n\n call compute_attenuation_coeffs(N_SLS,QMu_att,f0_attenuation,f_min_attenuation,f_max_attenuation, &\n tau_epsilon_nu2,tau_sigma_nu2)\n\n if (rank == 0) then\n print *\n print *,'with new SolvOpt routine for attenuation:'\n print *\n print *,'N_SLS, QKappa_att, QMu_att = ',N_SLS, QKappa_att, QMu_att\n print *,'f0_attenuation,f_min_attenuation,f_max_attenuation = ',f0_attenuation,f_min_attenuation,f_max_attenuation\n print *,'tau_epsilon_nu1 = ',tau_epsilon_nu1\n print *,'tau_sigma_nu1 = ',tau_sigma_nu1\n print *,'tau_epsilon_nu2 = ',tau_epsilon_nu2\n print *,'tau_sigma_nu2 = ',tau_sigma_nu2\n print *\n endif\n\n tau1 = tau_sigma_nu1(1)/tau_epsilon_nu1(1)\n tau2 = tau_sigma_nu2(1)/tau_epsilon_nu2(1)\n tau3 = tau_sigma_nu1(2)/tau_epsilon_nu1(2)\n tau4 = tau_sigma_nu2(2)/tau_epsilon_nu2(2)\n\n taumax = max(1.d0/tau1,1.d0/tau2,1.d0/tau3,1.d0/tau4)\n taumin = min(1.d0/tau1,1.d0/tau2,1.d0/tau3,1.d0/tau4)\n\n inv_tau_sigma_nu1(1) = ONE / tau_sigma_nu1(1)\n inv_tau_sigma_nu2(1) = ONE / tau_sigma_nu2(1)\n inv_tau_sigma_nu1(2) = ONE / tau_sigma_nu1(2)\n inv_tau_sigma_nu2(2) = ONE / tau_sigma_nu2(2)\n\n phi_nu1(1) = (ONE - tau_epsilon_nu1(1)/tau_sigma_nu1(1)) / tau_sigma_nu1(1)\n phi_nu2(1) = (ONE - tau_epsilon_nu2(1)/tau_sigma_nu2(1)) / tau_sigma_nu2(1)\n phi_nu1(2) = (ONE - tau_epsilon_nu1(2)/tau_sigma_nu1(2)) / tau_sigma_nu1(2)\n phi_nu2(2) = (ONE - tau_epsilon_nu2(2)/tau_sigma_nu2(2)) / tau_sigma_nu2(2)\n\n Mu_nu1 = ONE - (ONE - tau_epsilon_nu1(1)/tau_sigma_nu1(1)) - (ONE - tau_epsilon_nu1(2)/tau_sigma_nu1(2))\n Mu_nu2 = ONE - (ONE - tau_epsilon_nu2(1)/tau_sigma_nu2(1)) - (ONE - tau_epsilon_nu2(2)/tau_sigma_nu2(2))\n\n! slice number for the cut plane in the middle of the mesh\n rank_cut_plane = nb_procs/2 - 1\n\n if (rank == rank_cut_plane) then\n\n print *\n print *,'3D elastic finite-difference code in velocity and stress formulation with C-PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *,'NZ = ',NZ\n print *\n print *,'NZ_LOCAL = ',NZ_LOCAL\n print *,'NPROC = ',NPROC\n print *\n print *,'size of the model along X = ',(NX+1) * DELTAX\n print *,'size of the model along Y = ',(NY+1) * DELTAY\n print *,'size of the model along Y = ',(NZ+1) * DELTAZ\n print *\n print *,'Total number of grid points = ',(NX+2) * (NY+2) * (NZ+2)\n print *,'Number of points of all the arrays = ',dble(NX+2)*dble(NY+2)*dble(NZ+2)*number_of_arrays\n 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)\n print *\n print *,'In each slice:'\n print *\n print *,'Total number of grid points = ',(NX+2) * (NY+2) * NZ_LOCAL\n print *,'Number of points of the arrays = ',dble(NX+2)*dble(NY+2)*dble(NZ_LOCAL)*number_of_arrays\n 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)\n print *\n\n endif\n\n! check that code was compiled with the right number of slices\n if (nb_procs /= NPROC) then\n print *,'error in MPI number of slices: nb_procs,NPROC = ',nb_procs,NPROC,' but they should be equal'\n stop 'nb_procs must be equal to NPROC'\n endif\n\n! we restrict ourselves to an even number of slices\n! in order to have a cut plane in the middle of the mesh for visualization purposes\n if (mod(nb_procs,2) /= 0) stop 'nb_procs must be even'\n\n! check that we can cut along Z in an exact number of slices\n if (mod(NZ,nb_procs) /= 0) stop 'NZ must be a multiple of nb_procs'\n\n! check that a slice is at least as thick as a PML layer\n if (NZ_LOCAL < NPOINTS_PML) stop 'NZ_LOCAL must be greater than NPOINTS_PML'\n\n! offset of this slice when we cut along Z\n offset_k = rank * NZ_LOCAL\n\n!--- define profile of absorption in PML region\n\n! thickness of the PML layer in meters\n thickness_PML_x = NPOINTS_PML * DELTAX\n thickness_PML_y = NPOINTS_PML * DELTAY\n thickness_PML_z = NPOINTS_PML * DELTAZ\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.0001d0\n\n! check that NPOWER is okay\n if (NPOWER < 1) stop 'NPOWER must be greater than 1'\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0_x = - (NPOWER + 1) * cp *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_x)\n d0_y = - (NPOWER + 1) * cp *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_y)\n d0_z = - (NPOWER + 1) * cp *dsqrt(taumax)* log(Rcoef) / (2.d0 * thickness_PML_z)\n\n if (rank == rank_cut_plane) then\n print *\n print *,'d0_x = ',d0_x\n print *,'d0_y = ',d0_y\n print *,'d0_z = ',d0_z\n endif\n\n! PML\n d_x(:) = ZERO\n d_x_half(:) = ZERO\n K_x(:) = 1.d0\n K_x_half(:) = 1.d0\n alpha_x(:) = ZERO\n alpha_x_half(:) = ZERO\n a_x(:) = ZERO\n a_x_half(:) = ZERO\n\n d_y(:) = ZERO\n d_y_half(:) = ZERO\n K_y(:) = 1.d0\n K_y_half(:) = 1.d0\n alpha_y(:) = ZERO\n alpha_y_half(:) = ZERO\n a_y(:) = ZERO\n a_y_half(:) = ZERO\n\n d_z(:) = ZERO\n d_z_half(:) = ZERO\n K_z(:) = 1.d0\n K_z_half(:) = 1.d0\n alpha_z(:) = ZERO\n alpha_z_half(:) = ZERO\n a_z(:) = ZERO\n a_z_half(:) = ZERO\n\n! damping in the X direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = thickness_PML_x\n xoriginright = (NX-1)*DELTAX - thickness_PML_x\n\n do i = 1,NX\n\n! abscissa of current grid point along the damping profile\n xval = DELTAX * dble(i-1)\n\n!---------- xmin edge\n if (USE_PML_XMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xoriginleft - xval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- xmax edge\n if (USE_PML_XMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = xval - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_x\n d_x_half(i) = d0_x * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n! just in case, for -5 at the end\n if (alpha_x(i) < ZERO) alpha_x(i) = ZERO\n if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO\n\n b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)\n b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &\n (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))\n\n enddo\n\n! damping in the Y direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n yoriginbottom = thickness_PML_y\n yorigintop = (NY-1)*DELTAY - thickness_PML_y\n\n do j = 1,NY\n\n! abscissa of current grid point along the damping profile\n yval = DELTAY * dble(j-1)\n\n!---------- ymin edge\n if (USE_PML_YMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yoriginbottom - yval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- ymax edge\n if (USE_PML_YMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = yval - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_y\n d_y_half(j) = d0_y * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)\n b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &\n (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))\n\n enddo\n\n! damping in the Z direction\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n zoriginbottom = thickness_PML_z\n zorigintop = (NZ-1)*DELTAZ - thickness_PML_z\n\n do k = 1,NZ\n\n! abscissa of current grid point along the damping profile\n zval = DELTAZ * dble(k-1)\n\n!---------- zmin edge\n if (USE_PML_ZMIN) then\n\n! define damping profile at the grid points\n abscissa_in_PML = zoriginbottom - zval\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_z\n d_z(k) = d0_z * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_z(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_z(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = zoriginbottom - (zval + DELTAZ/2.d0)\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_z\n d_z_half(k) = d0_z * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_z_half(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_z_half(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n!---------- zmax edge\n if (USE_PML_ZMAX) then\n\n! define damping profile at the grid points\n abscissa_in_PML = zval - zorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_z\n d_z(k) = d0_z * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_z(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_z(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n! define damping profile at half the grid points\n abscissa_in_PML = zval + DELTAZ/2.d0 - zorigintop\n if (abscissa_in_PML >= ZERO) then\n abscissa_normalized = abscissa_in_PML / thickness_PML_z\n d_z_half(k) = d0_z * abscissa_normalized**NPOWER\n! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2\n K_z_half(k) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER\n alpha_z_half(k) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)\n endif\n\n endif\n\n b_z(k) = exp(- (d_z(k) / K_z(k) + alpha_z(k)) * DELTAT)\n b_z_half(k) = exp(- (d_z_half(k) / K_z_half(k) + alpha_z_half(k)) * DELTAT)\n\n! this to avoid division by zero outside the PML\n 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)))\n if (abs(d_z_half(k)) > 1.d-6) a_z_half(k) = d_z_half(k) * &\n (b_z_half(k) - 1.d0) / (K_z_half(k) * (d_z_half(k) + K_z_half(k) * alpha_z_half(k)))\n\n enddo\n\n if (rank == rank_cut_plane) then\n\n! print position of the source\n print *\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *\n print *,'There are ',nrec,' receivers'\n print *\n\n! xspacerec = (xfin-xdeb) / dble(NREC-1)\n! yspacerec = (yfin-ydeb) / dble(NREC-1)\n! do irec=1,nrec\n! xrec(irec) = xdeb + dble(irec-1)*xspacerec\n! yrec(irec) = ydeb + dble(irec-1)*yspacerec\n! enddo\n\n xrec(1)=xsource+500.d0 ! first receiver x in meters\n yrec(1)=ysource+500.d0 ! first receiver y in meters\n xrec(2)=xsource ! first receiver x in meters\n yrec(2)=ysource+2260.d0 ! first receiver y in meters\n xrec(3)=xsource+500.d0 ! first receiver x in meters\n yrec(3)=ysource+2260.d0 ! first receiver y in meters\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((DELTAX*dble(i) - xrec(irec))**2 + (DELTAY*dble(j) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n endif\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number = cp * dsqrt(taumax)* DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2 + 1.d0/DELTAZ**2)\n if (rank == rank_cut_plane) then\n print *,'Courant number is ',Courant_number\n print *,'Vpmax=',cp*dsqrt(taumax)\n endif\n if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable'\n print *, \"Number of points per wavelength =\",cs*dsqrt(taumin)/(2.5d0*f0)/DELTAX,'Vsmin=',cs*dsqrt(taumin)\n\n! erase main arrays\n vx(:,:,:) = ZERO\n vy(:,:,:) = ZERO\n vz(:,:,:) = ZERO\n\n sigmaxy(:,:,:) = ZERO\n sigmayy(:,:,:) = ZERO\n sigmazz(:,:,:) = ZERO\n sigmaxz(:,:,:) = ZERO\n sigmazz(:,:,:) = ZERO\n sigmayz(:,:,:) = ZERO\n\n e1(:,:,:,:) = ZERO\n e11(:,:,:,:) = ZERO\n e12(:,:,:,:) = ZERO\n e13(:,:,:,:) = ZERO\n e23(:,:,:,:) = ZERO\n e22(:,:,:,:) = ZERO\n\n! PML\n memory_dvx_dx(:,:,:) = ZERO\n memory_dvx_dy(:,:,:) = ZERO\n memory_dvx_dz(:,:,:) = ZERO\n memory_dvy_dx(:,:,:) = ZERO\n memory_dvy_dy(:,:,:) = ZERO\n memory_dvy_dz(:,:,:) = ZERO\n memory_dvz_dx(:,:,:) = ZERO\n memory_dvz_dy(:,:,:) = ZERO\n memory_dvz_dz(:,:,:) = ZERO\n memory_dsigmaxx_dx(:,:,:) = ZERO\n memory_dsigmayy_dy(:,:,:) = ZERO\n memory_dsigmazz_dz(:,:,:) = ZERO\n memory_dsigmaxy_dx(:,:,:) = ZERO\n memory_dsigmaxy_dy(:,:,:) = ZERO\n memory_dsigmaxz_dx(:,:,:) = ZERO\n memory_dsigmaxz_dz(:,:,:) = ZERO\n memory_dsigmayz_dy(:,:,:) = ZERO\n memory_dsigmayz_dz(:,:,:) = ZERO\n\n! erase seismograms\n sisvx(:,:) = ZERO\n sisvy(:,:) = ZERO\n\n! initialize total energy\n total_energy(:) = ZERO\n total_energy_kinetic(:) = ZERO\n total_energy_potential(:) = ZERO\n\n call date_and_time(datein,timein,zone,time_values)\n! time_values(3): day of the month\n! time_values(5): hour of the day\n! time_values(6): minutes of the hour\n! time_values(7): seconds of the minute\n! time_values(8): milliseconds of the second\n! this fails if we cross the end of the month\n time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &\n 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0\n\n!---\n\n! we receive from the process on the left, and send to the process on the right\n sender_right_shift = rank - 1\n receiver_right_shift = rank + 1\n\n! if we are the first process, there is no neighbor on the left\n if (rank == 0) sender_right_shift = MPI_PROC_NULL\n\n! if we are the last process, there is no neighbor on the right\n if (rank == nb_procs - 1) receiver_right_shift = MPI_PROC_NULL\n\n!---\n\n! we receive from the process on the right, and send to the process on the left\n sender_left_shift = rank + 1\n receiver_left_shift = rank - 1\n\n! if we are the first process, there is no neighbor on the left\n if (rank == 0) receiver_left_shift = MPI_PROC_NULL\n\n! if we are the last process, there is no neighbor on the right\n if (rank == nb_procs - 1) sender_left_shift = MPI_PROC_NULL\n\n k2begin = 1\n if (rank == 0) k2begin = 2\n\n kminus1end = NZ_LOCAL\n if (rank == nb_procs - 1) kminus1end = NZ_LOCAL - 1\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n if (rank == rank_cut_plane .and. mod(it,20) == 0) print *,'it = ',it\n\n!----------------------\n! compute stress sigma\n!----------------------\n\n! vx(k+1), left shift\n call MPI_SENDRECV(vx(:,:,1:2),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_left_shift,message_tag,vx(:,:,NZ_LOCAL+1:NZ_LOCAL+2),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n! vy(k+1), left shift\n call MPI_SENDRECV(vy(:,:,1:2),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_left_shift,message_tag,vy(:,:,NZ_LOCAL+1:NZ_LOCAL+2),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n! vz(k-1), right shift\n call MPI_SENDRECV(vz(:,:,NZ_LOCAL-1:NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_right_shift,message_tag,vz(:,:,-1:0),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n do k=k2begin,NZ_LOCAL\n kglobal = k + offset_k\n do j=2,NY\n do i=1,NX-1\n\n mul_relaxed = mu\n lambdal_relaxed = lambda\n lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed\n lambdal_unrelaxed = (lambdal_relaxed + 2.d0/DIM*mul_relaxed) * Mu_nu1 - 2.d0/DIM*mul_relaxed * Mu_nu2\n mul_unrelaxed = mul_relaxed * Mu_nu2\n lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed\n\n 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\n 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\n 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\n\n memory_dvx_dx(i,j,k) = b_x_half(i) * memory_dvx_dx(i,j,k) + a_x_half(i) * value_dvx_dx\n memory_dvy_dy(i,j,k) = b_y(j) * memory_dvy_dy(i,j,k) + a_y(j) * value_dvy_dy\n memory_dvz_dz(i,j,k) = b_z(kglobal) * memory_dvz_dz(i,j,k) + a_z(kglobal) * value_dvz_dz\n\n duxdx = value_dvx_dx / K_x_half(i) + memory_dvx_dx(i,j,k)\n duydy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j,k)\n duzdz = value_dvz_dz / K_z(kglobal) + memory_dvz_dz(i,j,k)\n\n div=duxdx+duydy+duzdz\n\n! evolution e1(1)\n tauinv = - inv_tau_sigma_nu1(1)\n Un = e1(1,i,j,k)\n Sn = div * phi_nu1(1)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e1(1,i,j,k) = Unp1\n\n! evolution e1(2)\n tauinv = - inv_tau_sigma_nu1(2)\n Un = e1(2,i,j,k)\n Sn = div * phi_nu1(2)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e1(2,i,j,k) = Unp1\n\n! evolution e11(1)\n tauinv = - inv_tau_sigma_nu2(1)\n Un = e11(1,i,j,k)\n Sn = (duxdx - div/DIM) * phi_nu2(1)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e11(1,i,j,k) = Unp1\n\n! evolution e11(2)\n tauinv = - inv_tau_sigma_nu2(2)\n Un = e11(2,i,j,k)\n Sn = (duxdx - div/DIM) * phi_nu2(2)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e11(2,i,j,k) = Unp1\n\n! evolution e22(1)\n tauinv = - inv_tau_sigma_nu2(1)\n Un = e22(1,i,j,k)\n Sn = (duydy - div/DIM) * phi_nu2(1)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e22(1,i,j,k) = Unp1\n\n! evolution e22(2)\n tauinv = - inv_tau_sigma_nu2(2)\n Un = e22(2,i,j,k)\n Sn = (duydy - div/DIM) * phi_nu2(2)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e22(2,i,j,k) = Unp1\n\n\n!add the memory variables using the relaxed parameters (Carcione page 111)\n! : there is a bug in Carcione's equation for sigma_zz\n sigmaxx(i,j,k) = sigmaxx(i,j,k)+deltat*((lambdal_relaxed + 2.d0/DIM*mul_relaxed)* &\n (e1(1,i,j,k) + e1(2,i,j,k)) + TWO * mul_relaxed * (e11(1,i,j,k) + e11(2,i,j,k)))\n sigmayy(i,j,k) = sigmayy(i,j,k)+deltat*((lambdal_relaxed + 2.d0/DIM*mul_relaxed)* &\n (e1(1,i,j,k) + e1(2,i,j,k)) + TWO * mul_relaxed * (e22(1,i,j,k) + e22(2,i,j,k)))\n sigmazz(i,j,k) = sigmazz(i,j,k)+deltat*((lambdal_relaxed + 2.d0*mul_relaxed)* &\n (e1(1,i,j,k) + e1(2,i,j,k)) - TWO/DIM * mul_relaxed * (e11(1,i,j,k) + e11(2,i,j,k)&\n +e22(1,i,j,k) + e22(2,i,j,k)))\n\n! compute the stress using the unrelaxed Lame parameters (Carcione page 111)\n\n sigmaxx(i,j,k) = sigmaxx(i,j,k) + &\n (lambdalplus2mul_unrelaxed * (duxdx) + &\n lambdal_unrelaxed* (duydy) + &\n lambdal_unrelaxed* (duzdz) )* DELTAT\n\n sigmayy(i,j,k) = sigmayy(i,j,k) + &\n (lambdal_unrelaxed * (duxdx) + &\n lambdalplus2mul_unrelaxed* (duydy) +&\n lambdal_unrelaxed* (duzdz)) * DELTAT\n\n sigmazz(i,j,k) = sigmazz(i,j,k) + &\n (lambdal_unrelaxed * (duxdx) + &\n lambdal_unrelaxed* (duydy) + &\n lambdalplus2mul_unrelaxed* (duzdz)) * DELTAT\n\n sigmaxx_R(i,j,k) = sigmaxx_R(i,j,k) + &\n (lambdalplus2mul_relaxed * (duxdx) + &\n lambdal_relaxed* (duydy) + &\n lambdal_relaxed* (duzdz) )* DELTAT\n\n sigmayy_R(i,j,k) = sigmayy_R(i,j,k) + &\n (lambdal_relaxed * (duxdx) + &\n lambdalplus2mul_relaxed* (duydy) +&\n lambdal_relaxed* (duzdz)) * DELTAT\n\n sigmazz_R(i,j,k) = sigmazz_R(i,j,k) + &\n (lambdal_relaxed * (duxdx) + &\n lambdal_relaxed* (duydy) + &\n lambdalplus2mul_relaxed* (duzdz)) * DELTAT\n\n enddo\n enddo\n enddo\n\n do k=1,NZ_LOCAL\n do j=1,NY-1\n do i=2,NX\n mul_relaxed = mu\n mul_unrelaxed = mul_relaxed * Mu_nu2\n\n 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\n 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\n\n memory_dvy_dx(i,j,k) = b_x(i) * memory_dvy_dx(i,j,k) + a_x(i) * value_dvy_dx\n memory_dvx_dy(i,j,k) = b_y_half(j) * memory_dvx_dy(i,j,k) + a_y_half(j) * value_dvx_dy\n\n duydx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j,k)\n duxdy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j,k)\n\n! evolution e12(1)\n tauinv = - inv_tau_sigma_nu2(1)\n Un = e12(1,i,j,k)\n Sn = (duxdy+duydx) * phi_nu2(1)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e12(1,i,j,k) = Unp1\n\n! evolution e12(2)\n tauinv = - inv_tau_sigma_nu2(2)\n Un = e12(2,i,j,k)\n Sn = (duxdy+duydx) * phi_nu2(2)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e12(2,i,j,k) = Unp1\n\n sigmaxy(i,j,k) = sigmaxy(i,j,k)+deltat*mul_relaxed * (e12(1,i,j,k) + e12(2,i,j,k))\n\n sigmaxy(i,j,k) = sigmaxy(i,j,k) + &\n mul_unrelaxed * (duxdy+duydx) * DELTAT\n\n sigmaxy_R(i,j,k) = sigmaxy_R(i,j,k) + &\n mul_relaxed * (duxdy+duydx) * DELTAT\n\n enddo\n enddo\n enddo\n\n do k=1,kminus1end\n kglobal = k + offset_k\n do j=1,NY\n do i=2,NX\n mul_relaxed = mu\n mul_unrelaxed = mul_relaxed * Mu_nu2\n\n 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\n 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\n\n memory_dvz_dx(i,j,k) = b_x(i) * memory_dvz_dx(i,j,k) + a_x(i) * value_dvz_dx\n memory_dvx_dz(i,j,k) = b_z_half(kglobal) * memory_dvx_dz(i,j,k) + a_z_half(kglobal) * value_dvx_dz\n\n duzdx = value_dvz_dx / K_x(i) + memory_dvz_dx(i,j,k)\n duxdz = value_dvx_dz / K_z_half(kglobal) + memory_dvx_dz(i,j,k)\n\n! evolution e13(1)\n tauinv = - inv_tau_sigma_nu2(1)\n Un = e13(1,i,j,k)\n Sn = (duxdz+duzdx) * phi_nu2(1)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e13(1,i,j,k) = Unp1\n\n! evolution e13(2)\n tauinv = - inv_tau_sigma_nu2(2)\n Un = e13(2,i,j,k)\n Sn = (duxdz+duzdx) * phi_nu2(2)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e13(2,i,j,k) = Unp1\n\n sigmaxz(i,j,k) = sigmaxz(i,j,k)+deltat*mul_relaxed * (e13(1,i,j,k) + e13(2,i,j,k))\n\n sigmaxz(i,j,k) = sigmaxz(i,j,k) + &\n mul_unrelaxed * (duxdz+duzdx) * DELTAT\n\n sigmaxz_R(i,j,k) = sigmaxz_R(i,j,k) + &\n mul_relaxed * (duxdz+duzdx) * DELTAT\n enddo\n enddo\n\n do j=1,NY-1\n do i=1,NX\n mul_relaxed = mu\n mul_unrelaxed = mul_relaxed * Mu_nu2\n\n 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\n 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\n\n memory_dvz_dy(i,j,k) = b_y_half(j) * memory_dvz_dy(i,j,k) + a_y_half(j) * value_dvz_dy\n memory_dvy_dz(i,j,k) = b_z_half(kglobal) * memory_dvy_dz(i,j,k) + a_z_half(kglobal) * value_dvy_dz\n\n duzdy = value_dvz_dy / K_y_half(j) + memory_dvz_dy(i,j,k)\n duydz = value_dvy_dz / K_z_half(kglobal) + memory_dvy_dz(i,j,k)\n\n! evolution e23(1)\n tauinv = - inv_tau_sigma_nu2(1)\n Un = e23(1,i,j,k)\n Sn = (duydz+duzdy) * phi_nu2(1)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e23(1,i,j,k) = Unp1\n\n! evolution e23(2)\n tauinv = - inv_tau_sigma_nu2(2)\n Un = e23(2,i,j,k)\n Sn = (duydz+duzdy) * phi_nu2(2)\n tauinvUn = tauinv * Un\n Unp1 = (Un + deltat*(Sn+0.5d0*tauinvUn))/(1.d0-deltat*0.5d0*tauinv)\n e23(2,i,j,k) = Unp1\n\n sigmayz(i,j,k) = sigmayz(i,j,k)+deltat*mul_relaxed * (e23(1,i,j,k) + e23(2,i,j,k))\n\n sigmayz(i,j,k) = sigmayz(i,j,k) + &\n mul_unrelaxed * (duydz+duzdy) * DELTAT\n\n sigmayz_R(i,j,k) = sigmayz_R(i,j,k) + &\n mul_relaxed * (duydz+duzdy) * DELTAT\n\n enddo\n enddo\n enddo\n\n!------------------\n! compute velocity\n!------------------\n\n! sigmazz(k+1), left shift\n call MPI_SENDRECV(sigmazz(:,:,1:2),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_left_shift,message_tag,sigmazz(:,:,NZ_LOCAL+1:NZ_LOCAL+2),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_left_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n! sigmayz(k-1), right shift\n call MPI_SENDRECV(sigmayz(:,:,NZ_LOCAL-1:NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_right_shift,message_tag,sigmayz(:,:,-1:0),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n! sigmaxz(k-1), right shift\n call MPI_SENDRECV(sigmaxz(:,:,NZ_LOCAL-1:NZ_LOCAL),number_of_values,MPI_DOUBLE_PRECISION, &\n receiver_right_shift,message_tag,sigmaxz(:,:,-1:0),number_of_values, &\n MPI_DOUBLE_PRECISION,sender_right_shift,message_tag,MPI_COMM_WORLD,message_status,code)\n\n do k=k2begin,NZ_LOCAL\n kglobal = k + offset_k\n do j=2,NY\n do i=2,NX\n\n 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\n 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\n 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\n\n memory_dsigmaxx_dx(i,j,k) = b_x(i) * memory_dsigmaxx_dx(i,j,k) + a_x(i) * value_dsigmaxx_dx\n memory_dsigmaxy_dy(i,j,k) = b_y(j) * memory_dsigmaxy_dy(i,j,k) + a_y(j) * value_dsigmaxy_dy\n memory_dsigmaxz_dz(i,j,k) = b_z(kglobal) * memory_dsigmaxz_dz(i,j,k) + a_z(kglobal) * value_dsigmaxz_dz\n\n value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j,k)\n value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j,k)\n value_dsigmaxz_dz = value_dsigmaxz_dz / K_z(kglobal) + memory_dsigmaxz_dz(i,j,k)\n\n vx(i,j,k) = DELTAT_over_rho*(value_dsigmaxx_dx + value_dsigmaxy_dy + value_dsigmaxz_dz) + vx(i,j,k)\n\n enddo\n enddo\n\n do j=1,NY-1\n do i=1,NX-1\n\n 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\n 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\n 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\n\n memory_dsigmaxy_dx(i,j,k) = b_x_half(i) * memory_dsigmaxy_dx(i,j,k) + a_x_half(i) * value_dsigmaxy_dx\n memory_dsigmayy_dy(i,j,k) = b_y_half(j) * memory_dsigmayy_dy(i,j,k) + a_y_half(j) * value_dsigmayy_dy\n memory_dsigmayz_dz(i,j,k) = b_z(kglobal) * memory_dsigmayz_dz(i,j,k) + a_z(kglobal) * value_dsigmayz_dz\n\n value_dsigmaxy_dx = value_dsigmaxy_dx / K_x_half(i) + memory_dsigmaxy_dx(i,j,k)\n value_dsigmayy_dy = value_dsigmayy_dy / K_y_half(j) + memory_dsigmayy_dy(i,j,k)\n value_dsigmayz_dz = value_dsigmayz_dz / K_z(kglobal) + memory_dsigmayz_dz(i,j,k)\n\n vy(i,j,k) = DELTAT_over_rho*(value_dsigmaxy_dx + value_dsigmayy_dy + value_dsigmayz_dz) + vy(i,j,k)\n\n enddo\n enddo\n enddo\n\n do k=1,kminus1end\n kglobal = k + offset_k\n do j=2,NY\n do i=1,NX-1\n\n 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\n 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\n 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\n\n memory_dsigmaxz_dx(i,j,k) = b_x_half(i) * memory_dsigmaxz_dx(i,j,k) + a_x_half(i) * value_dsigmaxz_dx\n memory_dsigmayz_dy(i,j,k) = b_y(j) * memory_dsigmayz_dy(i,j,k) + a_y(j) * value_dsigmayz_dy\n memory_dsigmazz_dz(i,j,k) = b_z_half(kglobal) * memory_dsigmazz_dz(i,j,k) + a_z_half(kglobal) * value_dsigmazz_dz\n\n value_dsigmaxz_dx = value_dsigmaxz_dx / K_x_half(i) + memory_dsigmaxz_dx(i,j,k)\n value_dsigmayz_dy = value_dsigmayz_dy / K_y(j) + memory_dsigmayz_dy(i,j,k)\n value_dsigmazz_dz = value_dsigmazz_dz / K_z_half(kglobal) + memory_dsigmazz_dz(i,j,k)\n\n vz(i,j,k) = DELTAT_over_rho*(value_dsigmaxz_dx + value_dsigmayz_dy + value_dsigmazz_dz) + vz(i,j,k)\n\n enddo\n enddo\n enddo\n\n if (rank == rank_cut_plane) then\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! source_term = factor * exp(-a*(t-t0)**2)\n\n! first derivative of a Gaussian\n source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n vx(i,j,NZ_LOCAL) = vx(i,j,NZ_LOCAL) + force_x * DELTAT / rho\n vy(i,j,NZ_LOCAL) = vy(i,j,NZ_LOCAL) + force_y * DELTAT / rho\n\n endif\n\n! implement Dirichlet boundary conditions on the six edges of the grid\n\n! xmin\n vx(0:1,:,:) = ZERO\n vy(0:1,:,:) = ZERO\n vz(0:1,:,:) = ZERO\n\n! xmax\n vx(NX:NX+1,:,:) = ZERO\n vy(NX:NX+1,:,:) = ZERO\n vz(NX:NX+1,:,:) = ZERO\n\n! ymin\n vx(:,0:1,:) = ZERO\n vy(:,0:1,:) = ZERO\n vz(:,0:1,:) = ZERO\n\n! ymax\n vx(:,NY:NY+1,:) = ZERO\n vy(:,NY:NY+1,:) = ZERO\n vz(:,NY:NY+1,:) = ZERO\n\n! zmin\n if (rank == 0) then\n vx(:,:,0:1) = ZERO\n vy(:,:,0:1) = ZERO\n vz(:,:,0:1) = ZERO\n endif\n\n! zmax\n if (rank == nb_procs-1) then\n vx(:,:,NZ_LOCAL:NZ_LOCAL+1) = ZERO\n vy(:,:,NZ_LOCAL:NZ_LOCAL+1) = ZERO\n vz(:,:,NZ_LOCAL:NZ_LOCAL+1) = ZERO\n endif\n\n! store seismograms\n if (rank == rank_cut_plane) then\n do irec = 1,NREC\n sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec),NZ_LOCAL)\n sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec),NZ_LOCAL)\n enddo\n endif\n\n! compute total energy in the medium (without the PML layers)\n local_energy_kinetic = ZERO\n local_energy_potential = ZERO\n\n kmin = 1\n kmax = NZ_LOCAL\n if (rank == 0) kmin = NPOINTS_PML\n if (rank == nb_procs-1) kmax = NZ_LOCAL-NPOINTS_PML+1\n\n do k = kmin,kmax\n do j = NPOINTS_PML, NY-NPOINTS_PML+1\n do i = NPOINTS_PML, NX-NPOINTS_PML+1\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n! in principle we should use rho_half_x_half_y instead of rho for vy\n! in order to interpolate density at the right location in the staggered grid cell\n! but in a homogeneous medium we can safely ignore it\n local_energy_kinetic = local_energy_kinetic + 0.5d0 * rho*( &\n vx(i,j,k)**2 + vy(i,j,k)**2 + vz(i,j,k)**2)\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n! in principle we should interpolate the medium parameters at the right location\n! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n\n! compute total field from split components\n epsilon_xx = (2.d0*(lambda + mu) * sigmaxx(i,j,k) - lambda * sigmayy(i,j,k) - &\n lambda*sigmazz(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu))\n epsilon_yy = (2.d0*(lambda + mu) * sigmayy(i,j,k) - lambda * sigmaxx(i,j,k) - &\n lambda*sigmazz(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu))\n epsilon_zz = (2.d0*(lambda + mu) * sigmazz(i,j,k) - lambda * sigmaxx(i,j,k) - &\n lambda*sigmayy(i,j,k)) / (2.d0 * mu * (3.d0*lambda + 2.d0*mu))\n epsilon_xy = sigmaxy_R(i,j,k) / (2.d0 * mu)\n epsilon_xz = sigmaxz_R(i,j,k) / (2.d0 * mu)\n epsilon_yz = sigmayz_R(i,j,k) / (2.d0 * mu)\n\n local_energy_potential = local_energy_potential + &\n 0.5d0 * (epsilon_xx * sigmaxx_R(i,j,k) + epsilon_yy * sigmayy_R(i,j,k) + &\n epsilon_yy * sigmayy_R(i,j,k)+ 2.d0 * epsilon_xy * sigmaxy_R(i,j,k) + &\n 2.d0*epsilon_xz * sigmaxz_R(i,j,k)+2.d0*epsilon_yz * sigmayz_R(i,j,k))\n\n enddo\n enddo\n enddo\n\n call MPI_REDUCE(local_energy_kinetic + local_energy_potential,total_energy(it),1, &\n MPI_DOUBLE_PRECISION,MPI_SUM,rank_cut_plane,MPI_COMM_WORLD,code)\n call MPI_REDUCE(local_energy_kinetic,total_energy_kinetic(it),1, &\n MPI_DOUBLE_PRECISION,MPI_SUM,rank_cut_plane,MPI_COMM_WORLD,code)\n call MPI_REDUCE(local_energy_potential,total_energy_potential(it),1, &\n MPI_DOUBLE_PRECISION,MPI_SUM,rank_cut_plane,MPI_COMM_WORLD,code)\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n call MPI_REDUCE(maxval(sqrt(vx(:,:,1:NZ_LOCAL)**2 + vy(:,:,1:NZ_LOCAL)**2 + &\n vz(:,:,1:NZ_LOCAL)**2)),Vsolidnorm,1,MPI_DOUBLE_PRECISION,MPI_MAX,rank_cut_plane,MPI_COMM_WORLD,code)\n\n if (rank == rank_cut_plane) then\n\n print *,'Time step # ',it,' out of ',NSTEP,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',Vsolidnorm\n print *,'Total energy = ',total_energy(it)\n! check stability of the code, exit if unstable\n if (Vsolidnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up in solid'\n\n! count elapsed wall-clock time\n call date_and_time(datein,timein,zone,time_values)\n! time_values(3): day of the month\n! time_values(5): hour of the day\n! time_values(6): minutes of the hour\n! time_values(7): seconds of the minute\n! time_values(8): milliseconds of the second\n! this fails if we cross the end of the month\n time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &\n 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0\n\n! elapsed time since beginning of the simulation\n tCPU = time_end - time_start\n int_tCPU = int(tCPU)\n ihours = int_tCPU / 3600\n iminutes = (int_tCPU - 3600*ihours) / 60\n iseconds = int_tCPU - 3600*ihours - 60*iminutes\n write(*,*) 'Elapsed time in seconds = ',tCPU\n write(*,\"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')\") ihours,iminutes,iseconds\n write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)\n write(*,*)\n\n! write time stamp file to give information about progression of simulation\n write(outputname,\"('timestamp',i6.6)\") it\n open(unit=IOUT,file=outputname,status='unknown')\n write(IOUT,*) 'Time step # ',it\n write(IOUT,*) 'Time: ',sngl((it-1)*DELTAT),' seconds'\n write(IOUT,*) 'Max norm velocity vector V (m/s) = ',Vsolidnorm\n write(IOUT,*) 'Total energy = ',total_energy(it)\n write(IOUT,*) 'Elapsed time in seconds = ',tCPU\n write(IOUT,\"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')\") ihours,iminutes,iseconds\n write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)\n close(IOUT)\n\n! save energy\n open(unit=21,file='energy.dat',status='unknown')\n do it2=1,NSTEP\n write(21,*) sngl(dble(it2-1)*DELTAT),sngl(total_energy_kinetic(it2)), &\n sngl(total_energy_potential(it2)),sngl(total_energy(it2))\n enddo\n close(21)\n\n! save seismograms\n print *,'saving seismograms'\n print *\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT,t0)\n\n call create_color_image(vx(1:NX,1:NY,NZ_LOCAL),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1,max_amplitudeVx)\n call create_color_image(vy(1:NX,1:NY,NZ_LOCAL),NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2,max_amplitudeVy)\n\n endif\n endif\n\n! --- end of time loop\n enddo\n\n if (rank == rank_cut_plane) then\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT,t0)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"CPML3D_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" t ''Total energy'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vz_receiver_001.eps\"'\n write(20,*) 'plot \"Vz_file_001.dat\" t ''Vz C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vz_receiver_002.eps\"'\n write(20,*) 'plot \"Vz_file_002.dat\" t ''Vz C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n endif\n\n! close MPI program\n call MPI_FINALIZE(code)\n\n end program seismic_visco_CPML_3D_MPI_OpenMP\n\n! include the SolvOpt routines\n include \"attenuation_model_with_SolvOpt.f90\"\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT,t0)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT,t0\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT-t0),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT-t0),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number,max_amplitude)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=150) :: file_name\n! character(len=150) :: system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n! write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n! write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n if (it <= 2301) max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_PML_Collino_2D_anisotropic_fourth.f90", "content": "!\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n!\n! Program seismic_PML_Collino_2D_ani_4th, fourth-order accurate in space and second-order accurate in time\n!\n! This anisotropic code with classical split PML is modified by Jingyi Chen from program 'seismic_PML_Collino_2D_iso'\n! written by Dimitri Komatitsch.\n!\n! Jingyi Chen, Department of Geosciences, University of Tulsa, USA. Email: jingyi-chen AT utulsa DOT edu\n!\n!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributors: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n! Jingyi Chen, jingyi-chen AT utulsa DOT edu\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional anisotropic elastic wave equation\n! using a finite-difference method with classical split Perfectly Matched\n! Layer (PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_PML_Collino_2D_ani_4th\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n!\n! PML implemented in the two directions (x and y directions).\n!\n! Version 1.0 July, 2010\n! Jingyi Chen,the Department of Geosciences, The University of Tulsa, USA. Email: jingyi-chen@utulsa.edu\n!\n! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n!\n!\n! To display the 2D results as color images, use:\n!\n! \" display image* \" or \" gimp image* \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 401\n integer, parameter :: NY = 401\n\n! size of a grid cell\n double precision, parameter :: h = 5.d0\n\n! flags to add PML layers to the edges of the grid\n logical, parameter :: USE_PML_XMIN = .true.\n logical, parameter :: USE_PML_XMAX = .true.\n logical, parameter :: USE_PML_YMIN = .true.\n logical, parameter :: USE_PML_YMAX = .true.\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! model I from Becache, Fauqueux and Joly, which is stable\n! Model was also used in Dimitri Komatitsch and Roland Martin (2007),geophysics\n double precision, parameter :: scale_aniso = 1.d10\n double precision, parameter :: c11 = 4.d0 * scale_aniso\n double precision, parameter :: c12 = 3.8d0 * scale_aniso\n double precision, parameter :: c22 = 20.d0 * scale_aniso\n double precision, parameter :: c33 = 2.d0 * scale_aniso\n double precision, parameter :: rho = 4000.d0 ! used to be 1.\n! double precision, parameter :: f0 = 25.d0\n\n! total number of time steps\n integer, parameter :: NSTEP = 3000\n\n! time step in seconds\n double precision, parameter :: DELTAT = 1.d-3/2\n double precision, parameter :: ONE_OVER_DELTAT = 1.d0 / DELTAT\n\n! parameters for the source\n double precision, parameter :: f0 = 25.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d7\n\n! source\n integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1\n\n integer, parameter :: JSOURCE = 2 * NY / 3 + 1\n\n double precision, parameter :: xsource = (ISOURCE - 1) * h\n double precision, parameter :: ysource = (JSOURCE - 1) * h\n! angle of source force clockwise with respect to vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 135.d0\n\n! receivers\n integer, parameter :: NREC = 2\n double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters\n double precision, parameter :: xfin = xsource ! last receiver x in meters\n double precision, parameter :: yfin = 300.d0 ! last receiver y in meters\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 200\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! definition of the split velocity vector and stress tensor:\n!\n! vx(:,:) = vx_1(:,:) + vx_2(:,:)\n! vy(:,:) = vy_1(:,:) + vy_2(:,:)\n!\n! sigmaxx(:,:) = sigmaxx_1(:,:) + sigmaxx_2(:,:)\n! sigmayy(:,:) = sigmayy_1(:,:) + sigmayy_2(:,:)\n! sigmaxy(:,:) = sigmaxy_1(:,:) + sigmaxy_2(:,:)\n\n! main arrays\n double precision, dimension(NX,NY) :: vx_1,vx_2,vy_1,vy_2, &\n sigmaxx_1,sigmaxx_2,sigmayy_1,sigmayy_2,sigmaxy_1,sigmaxy_2\n\n! additional array used for display only\n double precision, dimension(NX,NY) :: image_data_2D\n\n double precision, dimension(NX) :: dx_over_two,dx_half_over_two\n double precision, dimension(NY) :: dy_over_two,dy_half_over_two\n\n! for stability estimate\n\n double precision :: quasi_cp_max,aniso_stability_criterion,aniso2,aniso3\n\n! for the source\n double precision a,t,force_x,force_y,source_term\n\n! for receivers\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy\n\n! for evolution of total energy in the medium\n double precision :: epsilon_xx,epsilon_yy,epsilon_xy\n double precision :: sigmaxx_total,sigmayy_total,sigmaxy_total\n double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n\n integer :: i,j,it,irec\n\n double precision :: xval,delta,xoriginleft,xoriginright,rcoef,d0,velocnorm,Courant_number,value_dx,value_dy,d\n\n! *******************\n! program starts here\n! *******************\n\n print *\n print *,'2D elastic anisotropic finite-difference code in velocity and stress formulation with split PML'\n print *\n\n! display size of the model\n print *\n print *,'NX = ',NX\n print *,'NY = ',NY\n print *\n print *,'size of the model along X = ',(NX - 1) * h\n print *,'size of the model along Y = ',(NY - 1) * h\n print *\n print *,'Total number of grid points = ',NX * NY\n print *\n\n print *,'Velocity of qP along vertical axis. . . . =',sqrt(c22/rho)\n print *,'Velocity of qP along horizontal axis. . . =',sqrt(c11/rho)\n print *\n print *,'Velocity of qSV along vertical axis . . . =',sqrt(c33/rho)\n print *,'Velocity of qSV along horizontal axis . . =',sqrt(c33/rho)\n print *\n\n! from Becache et al., INRIA report, equation 7 page 5 http://hal.inria.fr/docs/00/07/22/83/PDF/RR-4304.pdf\n if (c11*c22 - c12*c12 <= 0.d0) stop 'problem in definition of orthotropic material'\n\n! check intrinsic mathematical stability of PML model for an anisotropic material\n! from E. B\\'ecache, S. Fauqueux and P. Joly, Stability of Perfectly Matched Layers, group\n! velocities and anisotropic waves, Journal of Computational Physics, 188(2), p. 399-433 (2003)\n aniso_stability_criterion = ((c12+c33)**2 - c11*(c22-c33)) * ((c12+c33)**2 + c33*(c22-c33))\n print *,'PML anisotropy stability criterion from Becache et al. 2003 = ',aniso_stability_criterion\n if (aniso_stability_criterion > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) &\n print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 1'\n print *\n\n aniso2 = (c12 + 2*c33)**2 - c11*c22\n print *,'PML aniso2 stability criterion from Becache et al. 2003 = ',aniso2\n if (aniso2 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) &\n print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 2'\n print *\n\n aniso3 = (c12 + c33)**2 - c11*c22 - c33**2\n print *,'PML aniso3 stability criterion from Becache et al. 2003 = ',aniso3\n if (aniso3 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) &\n print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 3'\n print *\n\n\n! to compute d0 below, and for stability estimate\n quasi_cp_max = max(sqrt(c22/rho),sqrt(c11/rho))\n\n\n!--- define profile of absorption in PML region\n\n! thickness of the layer in meters\n delta = NPOINTS_PML * h\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0 = 3.d0 * quasi_cp_max * log(1.d0/Rcoef) / (2.d0 * delta)\n\n print *,'d0 = ',d0\n print *\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = delta\n xoriginright = (NX-1)*h - delta\n\n do i=1,NX\n\n xval = h*dble(i-1)\n\n if (xval < xoriginleft) then\n dx_over_two(i) = d0 * ((xoriginleft-xval)/delta)**2\n dx_half_over_two(i) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2\n! fix problem with dx_half_over_two() exactly on the edge\n else if (xval >= 0.9999d0*xoriginright) then\n dx_over_two(i) = d0 * ((xval-xoriginright)/delta)**2\n dx_half_over_two(i) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2\n else\n dx_over_two(i) = 0.d0\n dx_half_over_two(i) = 0.d0\n endif\n\n enddo\n\n! divide the whole profile by two once and for all\n dx_over_two(:) = dx_over_two(:) / 2.d0\n dx_half_over_two(:) = dx_half_over_two(:) / 2.d0\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = delta\n xoriginright = (NY-1)*h - delta\n\n do j=1,NY\n\n xval = h*dble(j-1)\n\n if (xval < xoriginleft) then\n dy_over_two(j) = d0 * ((xoriginleft-xval)/delta)**2\n dy_half_over_two(j) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2\n! fix problem with dy_half_over_two() exactly on the edge\n else if (xval >= 0.9999d0*xoriginright) then\n dy_over_two(j) = d0 * ((xval-xoriginright)/delta)**2\n dy_half_over_two(j) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2\n else\n dy_over_two(j) = 0.d0\n dy_half_over_two(j) = 0.d0\n endif\n\n enddo\n\n! divide the whole profile by two once and for all\n dy_over_two(:) = dy_over_two(:) / 2.d0\n dy_half_over_two(:) = dy_half_over_two(:) / 2.d0\n\n! print position of the source\n print *\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *\n print *,'There are ',nrec,' receivers'\n print *\n xspacerec = (xfin-xdeb) / dble(NREC-1)\n yspacerec = (yfin-ydeb) / dble(NREC-1)\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((h*dble(i-1) - xrec(irec))**2 + (h*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n\n Courant_number = quasi_cp_max * DELTAT * sqrt(1.d0/h**2 + 1.d0/h**2)\n print *,'Courant number is ',Courant_number\n print *\n if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable'\n\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')\n\n! initialize arrays\n vx_1(:,:) = 0.d0\n vy_1(:,:) = 0.d0\n\n vx_2(:,:) = 0.d0\n vy_2(:,:) = 0.d0\n\n sigmaxx_1(:,:) = 0.d0\n sigmayy_1(:,:) = 0.d0\n sigmaxy_1(:,:) = 0.d0\n\n sigmaxx_2(:,:) = 0.d0\n sigmayy_2(:,:) = 0.d0\n sigmaxy_2(:,:) = 0.d0\n\n! initialize seismograms\n sisvx(:,:) = 0.d0\n sisvy(:,:) = 0.d0\n\n! initialize total energy\n total_energy_kinetic(:) = 0.d0\n total_energy_potential(:) = 0.d0\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!----------------------\n! compute stress sigma\n!----------------------\n\n do j = 3,NY-1\n do i = 2,NX-2\n\n 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) &\n + (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)\n\n 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) &\n + (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)\n\n d = dx_half_over_two(i)\n\n sigmaxx_1(i,j) = ( sigmaxx_1(i,j)*(ONE_OVER_DELTAT - d) + c11 * value_dx ) / (ONE_OVER_DELTAT + d)\n\n sigmayy_1(i,j) = ( sigmayy_1(i,j)*(ONE_OVER_DELTAT - d) + c12 * value_dx ) / (ONE_OVER_DELTAT + d)\n\n d = dy_over_two(j)\n\n sigmaxx_2(i,j) = ( sigmaxx_2(i,j)*(ONE_OVER_DELTAT - d) + c12 * value_dy ) / (ONE_OVER_DELTAT + d)\n\n sigmayy_2(i,j) = ( sigmayy_2(i,j)*(ONE_OVER_DELTAT - d) + c22 * value_dy ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n\n do j = 2,NY-2\n do i = 3,NX-1\n\n 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) &\n + (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)\n\n\n 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) &\n + (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)\n\n\n\n d = dx_over_two(i)\n\n sigmaxy_1(i,j) = ( sigmaxy_1(i,j)*(ONE_OVER_DELTAT - d) + c33 * value_dx ) / (ONE_OVER_DELTAT + d)\n\n d = dy_half_over_two(j)\n\n sigmaxy_2(i,j) = ( sigmaxy_2(i,j)*(ONE_OVER_DELTAT - d) + c33 * value_dy ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n\n!------------------\n! compute velocity\n!------------------\n\n do j = 3,NY-1\n do i = 3,NX-1\n\n\n 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) &\n + (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)\n\n\n 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) &\n + (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)\n\n\n d = dx_over_two(i)\n\n vx_1(i,j) = ( vx_1(i,j)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dy_over_two(j)\n\n vx_2(i,j) = ( vx_2(i,j)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n\n do j = 2,NY-2\n do i = 2,NX-2\n\n\n 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) &\n + (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)\n\n\n 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) &\n + (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)\n\n\n d = dx_half_over_two(i)\n\n vy_1(i,j) = ( vy_1(i,j)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dy_half_over_two(j)\n\n vy_2(i,j) = ( vy_2(i,j)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! source_term = factor * exp(-a*(t-t0)**2)\n\n! first derivative of a Gaussian\n! source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n! add the source to one of the two components of the split field\n vx_1(i,j) = vx_1(i,j) + force_x * DELTAT / rho\n vy_1(i,j) = vy_1(i,j) + force_y * DELTAT / rho\n\n! implement Dirichlet boundary conditions on the four edges of the grid\n\n! xmin\n vx_1(1,:) = 0.d0\n vy_1(1,:) = 0.d0\n\n vx_2(1,:) = 0.d0\n vy_2(1,:) = 0.d0\n\n! xmax\n vx_1(NX,:) = 0.d0\n vy_1(NX,:) = 0.d0\n\n vx_2(NX,:) = 0.d0\n vy_2(NX,:) = 0.d0\n\n! ymin\n vx_1(:,1) = 0.d0\n vy_1(:,1) = 0.d0\n\n vx_2(:,1) = 0.d0\n vy_2(:,1) = 0.d0\n\n! ymax\n vx_1(:,NY) = 0.d0\n vy_1(:,NY) = 0.d0\n\n vx_2(:,NY) = 0.d0\n vy_2(:,NY) = 0.d0\n\n! store seismograms\n do irec = 1,NREC\n sisvx(it,irec) = vx_1(ix_rec(irec),iy_rec(irec)) + vx_2(ix_rec(irec),iy_rec(irec))\n sisvy(it,irec) = vy_1(ix_rec(irec),iy_rec(irec)) + vy_2(ix_rec(irec),iy_rec(irec))\n enddo\n\n! compute total energy in the medium (without the PML layers)\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n! in principle we should use rho_half_x_half_y instead of rho for vy\n! in order to interpolate density at the right location in the staggered grid cell\n! but in a homogeneous medium we can safely ignore it\n total_energy_kinetic(it) = 0.5d0 * sum(rho*( &\n (vx_1(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML) + &\n vx_2(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML))**2 + &\n (vy_1(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML) + &\n vy_2(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML))**2))\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n! in principle we should interpolate the medium parameters at the right location\n! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n total_energy_potential(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n\n! compute total field from split components\n sigmaxx_total = sigmaxx_1(i,j) + sigmaxx_2(i,j)\n sigmayy_total = sigmayy_1(i,j) + sigmayy_2(i,j)\n sigmaxy_total = sigmaxy_1(i,j) + sigmaxy_2(i,j)\n\n epsilon_xx = (c22 * sigmaxx_total - c12 * sigmayy_total) / (c11*c22-c12**2)\n epsilon_yy = (c11 * sigmayy_total - c12 * sigmaxx_total) / (c11*c22-c12**2)\n epsilon_xy = sigmaxy_total / (2.d0 * c33)\n total_energy_potential(it) = total_energy_potential(it) + &\n 0.5d0 * (epsilon_xx * sigmaxx_total + epsilon_yy * sigmayy_total + 2.d0 * epsilon_xy * sigmaxy_total)\n enddo\n enddo\n\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n velocnorm = maxval(sqrt((vx_1 + vx_2)**2 + (vy_1 + vy_2)**2))\n\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',velocnorm\n print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n print *\n! check stability of the code, exit if unstable\n if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n image_data_2D = vx_1 + vx_2\n call create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,.true.,.true.,.true.,.true.,1)\n\n image_data_2D = vy_1 + vy_2\n call create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,.true.,.true.,.true.,.true.,2)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"collino_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_PML_Collino_2D_ani_4th\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_PML_Collino_2D_isotropic.f90", "content": "!\n! SEISMIC_CPML Version 1.1.1, November 2009.\n!\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the two-dimensional isotropic elastic wave equation\n! using a finite-difference method with classical split Perfectly Matched\n! Layer (PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_PML_Collino_2D_iso\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n!\n! 2D explicit PML velocity-stress FD code based upon INRIA report:\n!\n! Francis Collino and Chrysoula Tsogka\n! Application of the PML Absorbing Layer Model to the Linear\n! Elastodynamic Problem in Anisotropic Heteregeneous Media\n! INRIA Research Report RR-3471, August 1998\n! http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n!\n! and\n!\n! @ARTICLE{CoTs01,\n! author = {F. Collino and C. Tsogka},\n! title = {Application of the {PML} absorbing layer model to the linear elastodynamic\n! problem in anisotropic heterogeneous media},\n! journal = {Geophysics},\n! year = {2001},\n! volume = {66},\n! number = {1},\n! pages = {294-307}}\n!\n! PML implemented in the two directions (x and y directions).\n!\n! Dimitri Komatitsch, University of Pau, France, April 2007.\n!\n! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:\n!\n! ^ y\n! |\n! |\n!\n! +-------------------+\n! | |\n! | |\n! | |\n! | |\n! | v_y |\n! sigma_xy +---------+ |\n! | | |\n! | | |\n! | | |\n! | | |\n! | | |\n! +---------+---------+ ---> x\n! v_x sigma_xx\n! sigma_yy\n!\n!\n! To display the 2D results as color images, use:\n!\n! \" display image* \" or \" gimp image* \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 101\n integer, parameter :: NY = 641\n\n! size of a grid cell\n double precision, parameter :: h = 10.d0\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! P-velocity, S-velocity and density\n double precision, parameter :: cp = 3300.d0\n double precision, parameter :: cs = cp / 1.732d0\n double precision, parameter :: rho = 2800.d0\n double precision, parameter :: mu = rho*cs*cs\n double precision, parameter :: lambda = rho*(cp*cp - 2.d0*cs*cs)\n double precision, parameter :: lambda_plus_two_mu = rho*cp*cp\n\n! total number of time steps\n integer, parameter :: NSTEP = 2000\n\n! time step in seconds\n double precision, parameter :: DELTAT = 2.d-3\n double precision, parameter :: ONE_OVER_DELTAT = 1.d0 / DELTAT\n\n! parameters for the source\n double precision, parameter :: f0 = 7.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d7\n\n! source\n integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1\n integer, parameter :: JSOURCE = 2 * NY / 3 + 1\n double precision, parameter :: xsource = (ISOURCE - 1) * h\n double precision, parameter :: ysource = (JSOURCE - 1) * h\n! angle of source force clockwise with respect to vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 135.d0\n\n! receivers\n integer, parameter :: NREC = 2\n double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters\n double precision, parameter :: xfin = xsource ! last receiver x in meters\n double precision, parameter :: yfin = 300.d0 ! last receiver y in meters\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 100\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! definition of the split velocity vector and stress tensor:\n!\n! vx(:,:) = vx_1(:,:) + vx_2(:,:)\n! vy(:,:) = vy_1(:,:) + vy_2(:,:)\n!\n! sigmaxx(:,:) = sigmaxx_1(:,:) + sigmaxx_2(:,:)\n! sigmayy(:,:) = sigmayy_1(:,:) + sigmayy_2(:,:)\n! sigmaxy(:,:) = sigmaxy_1(:,:) + sigmaxy_2(:,:)\n\n! main arrays\n double precision, dimension(NX,NY) :: vx_1,vx_2,vy_1,vy_2, &\n sigmaxx_1,sigmaxx_2,sigmayy_1,sigmayy_2,sigmaxy_1,sigmaxy_2\n\n! additional array used for display only\n double precision, dimension(NX,NY) :: image_data_2D\n\n double precision, dimension(NX) :: dx_over_two,dx_half_over_two\n double precision, dimension(NY) :: dy_over_two,dy_half_over_two\n\n! for the source\n double precision a,t,force_x,force_y,source_term\n\n! for receivers\n double precision xspacerec,yspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec\n double precision, dimension(NREC) :: xrec,yrec\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy\n\n! for evolution of total energy in the medium\n double precision :: epsilon_xx,epsilon_yy,epsilon_xy\n double precision :: sigmaxx_total,sigmayy_total,sigmaxy_total\n double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential\n\n integer :: i,j,it,irec\n\n double precision :: xval,delta,xoriginleft,xoriginright,rcoef,d0,velocnorm,Courant_number,value_dx,value_dy,d\n\n! *******************\n! program starts here\n! *******************\n\n!--- define profile of absorption in PML region\n\n! thickness of the layer in meters\n delta = NPOINTS_PML * h\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0 = 3.d0 * cp * log(1.d0/Rcoef) / (2.d0 * delta)\n\n print *,'d0 = ',d0\n print *\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = delta\n xoriginright = (NX-1)*h - delta\n\n do i=1,NX\n\n xval = h*dble(i-1)\n\n if (xval < xoriginleft) then\n dx_over_two(i) = d0 * ((xoriginleft-xval)/delta)**2\n dx_half_over_two(i) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2\n! fix problem with dx_half_over_two() exactly on the edge\n else if (xval >= 0.9999d0*xoriginright) then\n dx_over_two(i) = d0 * ((xval-xoriginright)/delta)**2\n dx_half_over_two(i) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2\n else\n dx_over_two(i) = 0.d0\n dx_half_over_two(i) = 0.d0\n endif\n\n enddo\n\n! divide the whole profile by two once and for all\n dx_over_two(:) = dx_over_two(:) / 2.d0\n dx_half_over_two(:) = dx_half_over_two(:) / 2.d0\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = delta\n xoriginright = (NY-1)*h - delta\n\n do j=1,NY\n\n xval = h*dble(j-1)\n\n if (xval < xoriginleft) then\n dy_over_two(j) = d0 * ((xoriginleft-xval)/delta)**2\n dy_half_over_two(j) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2\n! fix problem with dy_half_over_two() exactly on the edge\n else if (xval >= 0.9999d0*xoriginright) then\n dy_over_two(j) = d0 * ((xval-xoriginright)/delta)**2\n dy_half_over_two(j) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2\n else\n dy_over_two(j) = 0.d0\n dy_half_over_two(j) = 0.d0\n endif\n\n enddo\n\n! divide the whole profile by two once and for all\n dy_over_two(:) = dy_over_two(:) / 2.d0\n dy_half_over_two(:) = dy_half_over_two(:) / 2.d0\n\n! print position of the source\n print *\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *\n\n! define location of receivers\n print *\n print *,'There are ',nrec,' receivers'\n print *\n xspacerec = (xfin-xdeb) / dble(NREC-1)\n yspacerec = (yfin-ydeb) / dble(NREC-1)\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((h*dble(i-1) - xrec(irec))**2 + (h*dble(j-1) - yrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n endif\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number = cp * DELTAT / h\n print *,'Courant number is ',Courant_number\n print *\n if (Courant_number > 1.d0/sqrt(2.d0)) stop 'time step is too large, simulation will be unstable'\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n! call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')\n\n! initialize arrays\n vx_1(:,:) = 0.d0\n vy_1(:,:) = 0.d0\n\n vx_2(:,:) = 0.d0\n vy_2(:,:) = 0.d0\n\n sigmaxx_1(:,:) = 0.d0\n sigmayy_1(:,:) = 0.d0\n sigmaxy_1(:,:) = 0.d0\n\n sigmaxx_2(:,:) = 0.d0\n sigmayy_2(:,:) = 0.d0\n sigmaxy_2(:,:) = 0.d0\n\n! initialize seismograms\n sisvx(:,:) = 0.d0\n sisvy(:,:) = 0.d0\n\n! initialize total energy\n total_energy_kinetic(:) = 0.d0\n total_energy_potential(:) = 0.d0\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n!----------------------\n! compute stress sigma\n!----------------------\n\n do j = 2,NY\n do i = 1,NX-1\n\n value_dx = (vx_1(i+1,j) - vx_1(i,j)) / h &\n + (vx_2(i+1,j) - vx_2(i,j)) / h\n\n value_dy = (vy_1(i,j) - vy_1(i,j-1)) / h &\n + (vy_2(i,j) - vy_2(i,j-1)) / h\n\n d = dx_half_over_two(i)\n\n sigmaxx_1(i,j) = ( sigmaxx_1(i,j)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dx ) / (ONE_OVER_DELTAT + d)\n\n sigmayy_1(i,j) = ( sigmayy_1(i,j)*(ONE_OVER_DELTAT - d) + lambda * value_dx ) / (ONE_OVER_DELTAT + d)\n\n d = dy_over_two(j)\n\n sigmaxx_2(i,j) = ( sigmaxx_2(i,j)*(ONE_OVER_DELTAT - d) + lambda * value_dy ) / (ONE_OVER_DELTAT + d)\n\n sigmayy_2(i,j) = ( sigmayy_2(i,j)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dy ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 2,NX\n\n value_dx = (vy_1(i,j) - vy_1(i-1,j)) / h &\n + (vy_2(i,j) - vy_2(i-1,j)) / h\n\n value_dy = (vx_1(i,j+1) - vx_1(i,j)) / h &\n + (vx_2(i,j+1) - vx_2(i,j)) / h\n\n d = dx_over_two(i)\n\n sigmaxy_1(i,j) = ( sigmaxy_1(i,j)*(ONE_OVER_DELTAT - d) + mu * value_dx ) / (ONE_OVER_DELTAT + d)\n\n d = dy_half_over_two(j)\n\n sigmaxy_2(i,j) = ( sigmaxy_2(i,j)*(ONE_OVER_DELTAT - d) + mu * value_dy ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n\n!------------------\n! compute velocity\n!------------------\n\n do j = 2,NY\n do i = 2,NX\n\n value_dx = (sigmaxx_1(i,j) - sigmaxx_1(i-1,j)) / h &\n + (sigmaxx_2(i,j) - sigmaxx_2(i-1,j)) / h\n\n value_dy = (sigmaxy_1(i,j) - sigmaxy_1(i,j-1)) / h &\n + (sigmaxy_2(i,j) - sigmaxy_2(i,j-1)) / h\n\n d = dx_over_two(i)\n\n vx_1(i,j) = ( vx_1(i,j)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dy_over_two(j)\n\n vx_2(i,j) = ( vx_2(i,j)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n\n do j = 1,NY-1\n do i = 1,NX-1\n\n value_dx = (sigmaxy_1(i+1,j) - sigmaxy_1(i,j)) / h &\n + (sigmaxy_2(i+1,j) - sigmaxy_2(i,j)) / h\n\n value_dy = (sigmayy_1(i,j+1) - sigmayy_1(i,j)) / h &\n + (sigmayy_2(i,j+1) - sigmayy_2(i,j)) / h\n\n d = dx_half_over_two(i)\n\n vy_1(i,j) = ( vy_1(i,j)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dy_half_over_two(j)\n\n vy_2(i,j) = ( vy_2(i,j)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! source_term = factor * exp(-a*(t-t0)**2)\n\n! first derivative of a Gaussian\n source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n\n! define location of the source\n i = ISOURCE\n j = JSOURCE\n\n! add the source to one of the two components of the split field\n vx_1(i,j) = vx_1(i,j) + force_x * DELTAT / rho\n vy_1(i,j) = vy_1(i,j) + force_y * DELTAT / rho\n\n! implement Dirichlet boundary conditions on the four edges of the grid\n\n! xmin\n vx_1(1,:) = 0.d0\n vy_1(1,:) = 0.d0\n\n vx_2(1,:) = 0.d0\n vy_2(1,:) = 0.d0\n\n! xmax\n vx_1(NX,:) = 0.d0\n vy_1(NX,:) = 0.d0\n\n vx_2(NX,:) = 0.d0\n vy_2(NX,:) = 0.d0\n\n! ymin\n vx_1(:,1) = 0.d0\n vy_1(:,1) = 0.d0\n\n vx_2(:,1) = 0.d0\n vy_2(:,1) = 0.d0\n\n! ymax\n vx_1(:,NY) = 0.d0\n vy_1(:,NY) = 0.d0\n\n vx_2(:,NY) = 0.d0\n vy_2(:,NY) = 0.d0\n\n! store seismograms\n do irec = 1,NREC\n sisvx(it,irec) = vx_1(ix_rec(irec),iy_rec(irec)) + vx_2(ix_rec(irec),iy_rec(irec))\n sisvy(it,irec) = vy_1(ix_rec(irec),iy_rec(irec)) + vy_2(ix_rec(irec),iy_rec(irec))\n enddo\n\n! compute total energy in the medium (without the PML layers)\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n! in principle we should use rho_half_x_half_y instead of rho for vy\n! in order to interpolate density at the right location in the staggered grid cell\n! but in a homogeneous medium we can safely ignore it\n total_energy_kinetic(it) = 0.5d0 * sum(rho*( &\n (vx_1(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML) + &\n vx_2(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML))**2 + &\n (vy_1(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML) + &\n vy_2(NPOINTS_PML+1:NX-NPOINTS_PML,NPOINTS_PML+1:NY-NPOINTS_PML))**2))\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n! in principle we should interpolate the medium parameters at the right location\n! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n total_energy_potential(it) = ZERO\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n\n! compute total field from split components\n sigmaxx_total = sigmaxx_1(i,j) + sigmaxx_2(i,j)\n sigmayy_total = sigmayy_1(i,j) + sigmayy_2(i,j)\n sigmaxy_total = sigmaxy_1(i,j) + sigmaxy_2(i,j)\n\n epsilon_xx = ((lambda + 2.d0*mu) * sigmaxx_total - lambda * sigmayy_total) / (4.d0 * mu * (lambda + mu))\n epsilon_yy = ((lambda + 2.d0*mu) * sigmayy_total - lambda * sigmaxx_total) / (4.d0 * mu * (lambda + mu))\n epsilon_xy = sigmaxy_total / (2.d0 * mu)\n total_energy_potential(it) = total_energy_potential(it) + &\n 0.5d0 * (epsilon_xx * sigmaxx_total + epsilon_yy * sigmayy_total + 2.d0 * epsilon_xy * sigmaxy_total)\n enddo\n enddo\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n velocnorm = maxval(sqrt((vx_1 + vx_2)**2 + (vy_1 + vy_2)**2))\n\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',velocnorm\n print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)\n print *\n! check stability of the code, exit if unstable\n if (velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n\n image_data_2D = vx_1 + vx_2\n call create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,.true.,.true.,.true.,.true.,1)\n\n image_data_2D = vy_1 + vy_2\n call create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,.true.,.true.,.true.,.true.,2)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &\n sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"collino_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" us 1:2 t ''Ec'' w l lc 1, \"energy.dat\" us 1:3 &\n & t ''Ep'' w l lc 3, \"energy.dat\" us 1:4 t ''Total energy'' w l lc 4'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_PML_Collino_2D_iso\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" }, { "path": "seismic_PML_Collino_3D_isotropic_OpenMP.f90", "content": "!\n! SEISMIC_CPML Version 1.1.1, November 2009.\n!\n! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.\n! Contributors: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr\n! and Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr\n!\n! This software is a computer program whose purpose is to solve\n! the three-dimensional isotropic elastic wave equation\n! using a finite-difference method with classical split Perfectly Matched\n! Layer (PML) conditions.\n!\n! This program is free software; you can redistribute it and/or modify\n! it under the terms of the GNU General Public License as published by\n! the Free Software Foundation; either version 3 of the License, or\n! (at your option) any later version.\n!\n! This program is distributed in the hope that it will be useful,\n! but WITHOUT ANY WARRANTY; without even the implied warranty of\n! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n! GNU General Public License for more details.\n!\n! You should have received a copy of the GNU General Public License along\n! with this program; if not, write to the Free Software Foundation, Inc.,\n! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n!\n! The full text of the license is available in file \"LICENSE\".\n\n program seismic_PML_Collino_3D_iso\n\n! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).\n! If you want you can thus force automatic conversion to single precision at compile time\n! or change all the declarations and constants in the code from double precision to single.\n\n implicit none\n\n!\n! 3D explicit PML velocity-stress FD code based upon INRIA report for the 2D case:\n!\n! Francis Collino and Chrysoula Tsogka\n! Application of the PML Absorbing Layer Model to the Linear\n! Elastodynamic Problem in Anisotropic Heteregeneous Media\n! INRIA Research Report RR-3471, August 1998\n! http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n!\n! and\n!\n! @ARTICLE{CoTs01,\n! author = {F. Collino and C. Tsogka},\n! title = {Application of the {PML} absorbing layer model to the linear elastodynamic\n! problem in anisotropic heterogeneous media},\n! journal = {Geophysics},\n! year = {2001},\n! volume = {66},\n! number = {1},\n! pages = {294-307}}\n!\n! PML implemented in the three directions (x, y and z).\n!\n! Dimitri Komatitsch and Roland Martin, University of Pau, France, April 2007.\n!\n! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used.\n!\n! Parallel implementation based on OpenMP.\n! Type for instance \"setenv OMP_NUM_THREADS 4\" before running in OpenMP if you want 4 tasks.\n!\n! To display the results as color images in the selected 2D cut plane, use:\n!\n! \" display image*.gif \" or \" gimp image*.gif \"\n!\n! or\n!\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif \"\n! \" montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif \"\n! then \" display allfiles_Vx.gif \" or \" gimp allfiles_Vx.gif \"\n! then \" display allfiles_Vy.gif \" or \" gimp allfiles_Vy.gif \"\n!\n\n! total number of grid points in each direction of the grid\n integer, parameter :: NX = 101\n integer, parameter :: NY = 641\n integer, parameter :: NZ = 640\n\n! size of a grid cell\n double precision, parameter :: h = 10.d0\n\n! thickness of the PML layer in grid points\n integer, parameter :: NPOINTS_PML = 10\n\n! P-velocity, S-velocity and density\n double precision, parameter :: cp = 3300.d0\n double precision, parameter :: cs = cp / 1.732d0\n double precision, parameter :: rho = 2800.d0\n double precision, parameter :: mu = rho*cs*cs\n double precision, parameter :: lambda = rho*(cp*cp - 2.d0*cs*cs)\n double precision, parameter :: lambda_plus_two_mu = rho*cp*cp\n\n! total number of time steps\n integer, parameter :: NSTEP = 2500\n\n! time step in seconds\n double precision, parameter :: DELTAT = 1.6d-3\n double precision, parameter :: ONE_OVER_DELTAT = 1.d0 / DELTAT\n\n! parameters for the source\n double precision, parameter :: f0 = 7.d0\n double precision, parameter :: t0 = 1.20d0 / f0\n double precision, parameter :: factor = 1.d7\n\n! source\n! if one wants to put the source at another location, one can invert the formulas below\n! and define the grid point (ISOURCE, JSOURCE, KSOURCE) to use as:\n! double precision, parameter :: xsource = ...put here the coordinate you want...\n! double precision, parameter :: ysource = ...put here the coordinate you want...\n! double precision, parameter :: zsource = ...put here the coordinate you want...\n! integer, parameter :: ISOURCE = xsource / h + 1\n! integer, parameter :: JSOURCE = ysource / h + 1\n! integer, parameter :: KSOURCE = zsource / h + 1\n! (h is the size of mesh cells)\n integer, parameter :: ISOURCE = NX - 2*NPOINTS_PML - 1\n integer, parameter :: JSOURCE = 2 * NY / 3 + 1\n integer, parameter :: KSOURCE = NZ / 2\n double precision, parameter :: xsource = (ISOURCE - 1) * h\n double precision, parameter :: ysource = (JSOURCE - 1) * h\n double precision, parameter :: zsource = (KSOURCE - 1) * h\n! angle of source force clockwise with respect to vertical (Y) axis\n double precision, parameter :: ANGLE_FORCE = 135.d0\n\n! receivers\n integer, parameter :: NREC = 2\n double precision, parameter :: xdeb = xsource - 100.d0 ! first receiver x in meters\n double precision, parameter :: ydeb = 2300.d0 ! first receiver y in meters\n double precision, parameter :: zdeb = zsource ! first receiver y in meters\n double precision, parameter :: xfin = xsource ! last receiver x in meters\n double precision, parameter :: yfin = 300.d0 ! last receiver y in meters\n double precision, parameter :: zfin = zsource ! last receiver y in meters\n\n! display information on the screen from time to time\n integer, parameter :: IT_DISPLAY = 100\n\n! value of PI\n double precision, parameter :: PI = 3.141592653589793238462643d0\n\n! conversion from degrees to radians\n double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0\n\n! zero\n double precision, parameter :: ZERO = 0.d0\n\n! large value for maximum\n double precision, parameter :: HUGEVAL = 1.d+30\n\n! velocity threshold above which we consider that the code became unstable\n double precision, parameter :: STABILITY_THRESHOLD = 1.d+25\n\n! main arrays\n double precision, dimension(NX,NY,NZ) :: vx_1,vx_2,vx_3, &\n vy_1,vy_2,vy_3, &\n vz_1,vz_2,vz_3, &\n sigmaxx_1,sigmaxx_2,sigmaxx_3, &\n sigmayy_1,sigmayy_2,sigmayy_3, &\n sigmazz_1,sigmazz_2,sigmazz_3, &\n sigmaxy_1,sigmaxy_2, &\n sigmaxz_1,sigmaxz_3, &\n sigmayz_2,sigmayz_3\n\n double precision, dimension(NX) :: dx_over_two,dx_half_over_two\n double precision, dimension(NY) :: dy_over_two,dy_half_over_two\n double precision, dimension(NZ) :: dz_over_two,dz_half_over_two\n\n! for the source\n double precision a,t,force_x,force_y,force_z,source_term\n\n! for receivers\n double precision xspacerec,yspacerec,zspacerec,distval,dist\n integer, dimension(NREC) :: ix_rec,iy_rec,iz_rec\n double precision, dimension(NREC) :: xrec,yrec,zrec\n double precision, dimension(NSTEP,NREC) :: sisvx,sisvy\n\n! for evolution of total energy in the medium\n double precision :: epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz\n double precision :: sigmaxx_total,sigmayy_total,sigmazz_total\n double precision :: sigmaxy_total,sigmaxz_total,sigmayz_total\n double precision :: total_energy_kinetic,total_energy_potential\n double precision, dimension(NSTEP) :: total_energy\n\n integer :: i,j,k,it,irec,iplane\n\n double precision :: xval,delta,xoriginleft,xoriginright,rcoef,d0,Vsolidnorm,Courant_number,value_dx,value_dy,value_dz,d\n\n! timer to count elapsed time\n character(len=8) datein\n character(len=10) timein\n character(len=5) :: zone\n integer, dimension(8) :: time_values\n integer ihours,iminutes,iseconds,int_tCPU\n double precision :: time_start,time_end,tCPU\n\n! names of the time stamp files\n character(len=150) outputname\n\n! main I/O file\n integer, parameter :: IOUT = 41\n\n!---\n!--- program starts here\n!---\n\n!--- define profile of absorption in PML region\n\n! thickness of the layer in meters\n delta = NPOINTS_PML * h\n\n! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n Rcoef = 0.001d0\n\n! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf\n d0 = 3.d0 * cp * log(1.d0/Rcoef) / (2.d0 * delta)\n\n print *,'d0 = ',d0\n print *\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = delta\n xoriginright = (NX-1)*h - delta\n\n do i=1,NX\n\n xval = h*dble(i-1)\n\n if (xval < xoriginleft) then\n dx_over_two(i) = d0 * ((xoriginleft-xval)/delta)**2\n dx_half_over_two(i) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2\n! fix problem with dx_half_over_two() exactly on the edge\n else if (xval >= 0.9999d0*xoriginright) then\n dx_over_two(i) = d0 * ((xval-xoriginright)/delta)**2\n dx_half_over_two(i) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2\n else\n dx_over_two(i) = 0.d0\n dx_half_over_two(i) = 0.d0\n endif\n\n enddo\n\n! divide the whole profile by two once and for all\n dx_over_two(:) = dx_over_two(:) / 2.d0\n dx_half_over_two(:) = dx_half_over_two(:) / 2.d0\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = delta\n xoriginright = (NY-1)*h - delta\n\n do j=1,NY\n\n xval = h*dble(j-1)\n\n if (xval < xoriginleft) then\n dy_over_two(j) = d0 * ((xoriginleft-xval)/delta)**2\n dy_half_over_two(j) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2\n! fix problem with dy_half_over_two() exactly on the edge\n else if (xval >= 0.9999d0*xoriginright) then\n dy_over_two(j) = d0 * ((xval-xoriginright)/delta)**2\n dy_half_over_two(j) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2\n else\n dy_over_two(j) = 0.d0\n dy_half_over_two(j) = 0.d0\n endif\n\n enddo\n\n! divide the whole profile by two once and for all\n dy_over_two(:) = dy_over_two(:) / 2.d0\n dy_half_over_two(:) = dy_half_over_two(:) / 2.d0\n\n! origin of the PML layer (position of right edge minus thickness, in meters)\n xoriginleft = delta\n xoriginright = (NZ-1)*h - delta\n\n do k=1,NZ\n\n xval = h*dble(k-1)\n\n if (xval < xoriginleft) then\n dz_over_two(k) = d0 * ((xoriginleft-xval)/delta)**2\n dz_half_over_two(k) = d0 * ((xoriginleft-xval-h/2.d0)/delta)**2\n! fix problem with dy_half_over_two() exactly on the edge\n else if (xval >= 0.9999d0*xoriginright) then\n dz_over_two(k) = d0 * ((xval-xoriginright)/delta)**2\n dz_half_over_two(k) = d0 * ((xval+h/2.d0-xoriginright)/delta)**2\n else\n dz_over_two(k) = 0.d0\n dz_half_over_two(k) = 0.d0\n endif\n\n enddo\n\n! divide the whole profile by two once and for all\n dz_over_two(:) = dz_over_two(:) / 2.d0\n dz_half_over_two(:) = dz_half_over_two(:) / 2.d0\n\n! print position of the source\n print *\n print *,'Position of the source:'\n print *\n print *,'x = ',xsource\n print *,'y = ',ysource\n print *,'z = ',zsource\n print *\n\n! define location of receivers\n print *\n print *,'There are ',nrec,' receivers'\n print *\n xspacerec = (xfin-xdeb) / dble(NREC-1)\n yspacerec = (yfin-ydeb) / dble(NREC-1)\n zspacerec = (zfin-zdeb) / dble(NREC-1)\n do irec=1,nrec\n xrec(irec) = xdeb + dble(irec-1)*xspacerec\n yrec(irec) = ydeb + dble(irec-1)*yspacerec\n zrec(irec) = zdeb + dble(irec-1)*zspacerec\n enddo\n\n! find closest grid point for each receiver\n do irec=1,nrec\n dist = HUGEVAL\n do k = 1,NZ\n do j = 1,NY\n do i = 1,NX\n distval = sqrt((h*dble(i-1) - xrec(irec))**2 + (h*dble(j-1) - yrec(irec))**2 + (h*dble(k-1) - zrec(irec))**2)\n if (distval < dist) then\n dist = distval\n ix_rec(irec) = i\n iy_rec(irec) = j\n iz_rec(irec) = k\n endif\n enddo\n enddo\n enddo\n print *,'receiver ',irec,' x_target,y_target,z_target = ',xrec(irec),yrec(irec),zrec(irec)\n print *,'closest grid point found at distance ',dist,' in i,j,k = ',ix_rec(irec),iy_rec(irec),iz_rec(irec)\n print *\n enddo\n\n! check the Courant stability condition for the explicit time scheme\n! R. Courant et K. O. Friedrichs et H. Lewy (1928)\n Courant_number = cp * DELTAT / h\n print *,'Courant number is ',Courant_number\n print *\n if (Courant_number > 1.d0/sqrt(3.d0)) stop 'time step is too large, simulation will be unstable'\n\n! suppress old files (can be commented out if \"call system\" is missing in your compiler)\n! call system('rm -f Vx_*.dat Vy_*.dat Vz_*.dat image*.pnm image*.gif timestamp*')\n\n! initialize arrays\n vx_1(:,:,:) = 0.d0\n vy_1(:,:,:) = 0.d0\n vz_1(:,:,:) = 0.d0\n\n vx_2(:,:,:) = 0.d0\n vy_2(:,:,:) = 0.d0\n vz_2(:,:,:) = 0.d0\n\n vx_3(:,:,:) = 0.d0\n vy_3(:,:,:) = 0.d0\n vz_3(:,:,:) = 0.d0\n\n sigmaxx_1(:,:,:) = 0.d0\n sigmayy_1(:,:,:) = 0.d0\n sigmazz_1(:,:,:) = 0.d0\n sigmaxy_1(:,:,:) = 0.d0\n sigmaxz_1(:,:,:) = 0.d0\n\n sigmaxx_2(:,:,:) = 0.d0\n sigmayy_2(:,:,:) = 0.d0\n sigmazz_2(:,:,:) = 0.d0\n sigmaxy_2(:,:,:) = 0.d0\n sigmayz_2(:,:,:) = 0.d0\n\n sigmaxx_3(:,:,:) = 0.d0\n sigmayy_3(:,:,:) = 0.d0\n sigmazz_3(:,:,:) = 0.d0\n sigmaxz_3(:,:,:) = 0.d0\n sigmayz_3(:,:,:) = 0.d0\n\n! initialize seismograms\n sisvx(:,:) = 0.d0\n sisvy(:,:) = 0.d0\n\n! initialize total energy\n total_energy(:) = 0.d0\n\n call date_and_time(datein,timein,zone,time_values)\n! time_values(3): day of the month\n! time_values(5): hour of the day\n! time_values(6): minutes of the hour\n! time_values(7): seconds of the minute\n! time_values(8): milliseconds of the second\n! this fails if we cross the end of the month\n time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &\n 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0\n\n!---\n!--- beginning of time loop\n!---\n\n do it = 1,NSTEP\n\n print *,'it = ',it\n\n!----------------------\n! compute stress sigma\n!----------------------\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy,value_dz) &\n!$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, &\n!$OMP sigmayy_1,sigmayy_2,sigmayy_3,sigmazz_1,sigmazz_2,sigmazz_3,dx_half_over_two,dy_over_two,dz_over_two)\ndo k=2,NZ\n do j = 2,NY\n do i = 1,NX-1\n\n value_dx = (vx_1(i+1,j,k) - vx_1(i,j,k)) / h &\n + (vx_2(i+1,j,k) - vx_2(i,j,k)) / h &\n + (vx_3(i+1,j,k) - vx_3(i,j,k)) / h\n\n value_dy = (vy_1(i,j,k) - vy_1(i,j-1,k)) / h &\n + (vy_2(i,j,k) - vy_2(i,j-1,k)) / h &\n + (vy_3(i,j,k) - vy_3(i,j-1,k)) / h\n\n value_dz = (vz_1(i,j,k) - vz_1(i,j,k-1)) / h &\n + (vz_2(i,j,k) - vz_2(i,j,k-1)) / h &\n + (vz_3(i,j,k) - vz_3(i,j,k-1)) / h\n\n d = dx_half_over_two(i)\n\n sigmaxx_1(i,j,k) = ( sigmaxx_1(i,j,k)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dx ) / (ONE_OVER_DELTAT + d)\n\n sigmayy_1(i,j,k) = ( sigmayy_1(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dx ) / (ONE_OVER_DELTAT + d)\n\n sigmazz_1(i,j,k) = ( sigmazz_1(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dx ) / (ONE_OVER_DELTAT + d)\n\n d = dy_over_two(j)\n\n sigmaxx_2(i,j,k) = ( sigmaxx_2(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dy ) / (ONE_OVER_DELTAT + d)\n\n sigmayy_2(i,j,k) = ( sigmayy_2(i,j,k)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dy ) / (ONE_OVER_DELTAT + d)\n\n sigmazz_2(i,j,k) = ( sigmazz_2(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dy ) / (ONE_OVER_DELTAT + d)\n\n d = dz_over_two(k)\n\n sigmaxx_3(i,j,k) = ( sigmaxx_3(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dz ) / (ONE_OVER_DELTAT + d)\n\n sigmayy_3(i,j,k) = ( sigmayy_3(i,j,k)*(ONE_OVER_DELTAT - d) + lambda * value_dz ) / (ONE_OVER_DELTAT + d)\n\n sigmazz_3(i,j,k) = ( sigmazz_3(i,j,k)*(ONE_OVER_DELTAT - d) + lambda_plus_two_mu * value_dz ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy) SHARED(vx_1,vx_2,vx_3,vy_1, &\n!$OMP vy_2,vy_3,sigmaxy_1,sigmaxy_2,dy_half_over_two,dx_over_two)\ndo k=1,NZ\n do j = 1,NY-1\n do i = 2,NX\n\n value_dx = (vy_1(i,j,k) - vy_1(i-1,j,k)) / h &\n + (vy_2(i,j,k) - vy_2(i-1,j,k)) / h &\n + (vy_3(i,j,k) - vy_3(i-1,j,k)) / h\n\n value_dy = (vx_1(i,j+1,k) - vx_1(i,j,k)) / h &\n + (vx_2(i,j+1,k) - vx_2(i,j,k)) / h &\n + (vx_3(i,j+1,k) - vx_3(i,j,k)) / h\n\n d = dx_over_two(i)\n\n sigmaxy_1(i,j,k) = ( sigmaxy_1(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dx ) / (ONE_OVER_DELTAT + d)\n\n d = dy_half_over_two(j)\n\n sigmaxy_2(i,j,k) = ( sigmaxy_2(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dy ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\nenddo\n!$OMP END PARALLEL DO\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dz) SHARED(vx_1,vx_2,vx_3, &\n!$OMP vz_1,vz_2,vz_3,sigmaxz_1,sigmaxz_3,dz_half_over_two,dx_over_two)\ndo k=1,NZ-1\n do j = 1,NY\n do i = 2,NX\n\n value_dx = (vz_1(i,j,k) - vz_1(i-1,j,k)) / h &\n + (vz_2(i,j,k) - vz_2(i-1,j,k)) / h &\n + (vz_3(i,j,k) - vz_3(i-1,j,k)) / h\n\n value_dz = (vx_1(i,j,k+1) - vx_1(i,j,k)) / h &\n + (vx_2(i,j,k+1) - vx_2(i,j,k)) / h &\n + (vx_3(i,j,k+1) - vx_3(i,j,k)) / h\n\n d = dx_over_two(i)\n\n sigmaxz_1(i,j,k) = ( sigmaxz_1(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dx ) / (ONE_OVER_DELTAT + d)\n\n d = dz_half_over_two(k)\n\n sigmaxz_3(i,j,k) = ( sigmaxz_3(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dz ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\nenddo\n!$OMP END PARALLEL DO\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dy,value_dz) SHARED(vy_1,vy_2,vy_3, &\n!$OMP vz_1,vz_2,vz_3,sigmayz_2,sigmayz_3,dy_half_over_two,dz_half_over_two)\ndo k=1,NZ-1\n do j = 1,NY-1\n do i = 1,NX\n\n value_dy = (vz_1(i,j+1,k) - vz_1(i,j,k)) / h &\n + (vz_2(i,j+1,k) - vz_2(i,j,k)) / h &\n + (vz_3(i,j+1,k) - vz_3(i,j,k)) / h\n\n value_dz = (vy_1(i,j,k+1) - vy_1(i,j,k)) / h &\n + (vy_2(i,j,k+1) - vy_2(i,j,k)) / h &\n + (vy_3(i,j,k+1) - vy_3(i,j,k)) / h\n\n d = dy_half_over_two(j)\n\n sigmayz_2(i,j,k) = ( sigmayz_2(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dy ) / (ONE_OVER_DELTAT + d)\n\n d = dz_half_over_two(k)\n\n sigmayz_3(i,j,k) = ( sigmayz_3(i,j,k)*(ONE_OVER_DELTAT - d) + mu * value_dz ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\nenddo\n!$OMP END PARALLEL DO\n\n!------------------\n! compute velocity\n!------------------\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy,value_dz) SHARED(vx_1,vx_2, &\n!$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)\ndo k = 2,NZ\n do j = 2,NY\n do i = 2,NX\n\n value_dx = (sigmaxx_1(i,j,k) - sigmaxx_1(i-1,j,k)) / h &\n + (sigmaxx_2(i,j,k) - sigmaxx_2(i-1,j,k)) / h &\n + (sigmaxx_3(i,j,k) - sigmaxx_3(i-1,j,k)) / h\n\n value_dy = (sigmaxy_1(i,j,k) - sigmaxy_1(i,j-1,k)) / h &\n + (sigmaxy_2(i,j,k) - sigmaxy_2(i,j-1,k)) / h\n\n value_dz = (sigmaxz_1(i,j,k) - sigmaxz_1(i,j,k-1)) / h &\n + (sigmaxz_3(i,j,k) - sigmaxz_3(i,j,k-1)) / h\n\n d = dx_over_two(i)\n\n vx_1(i,j,k) = ( vx_1(i,j,k)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dy_over_two(j)\n\n vx_2(i,j,k) = ( vx_2(i,j,k)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dz_over_two(k)\n\n vx_3(i,j,k) = ( vx_3(i,j,k)*(ONE_OVER_DELTAT - d) + value_dz / rho ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\nenddo\n!$OMP END PARALLEL DO\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy,value_dz) SHARED(vy_1,vy_2, &\n!$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)\ndo k = 2,NZ\n do j = 1,NY-1\n do i = 1,NX-1\n\n value_dx = (sigmaxy_1(i+1,j,k) - sigmaxy_1(i,j,k)) / h &\n + (sigmaxy_2(i+1,j,k) - sigmaxy_2(i,j,k)) / h\n\n value_dy = (sigmayy_1(i,j+1,k) - sigmayy_1(i,j,k)) / h &\n + (sigmayy_2(i,j+1,k) - sigmayy_2(i,j,k)) / h &\n + (sigmayy_3(i,j+1,k) - sigmayy_3(i,j,k)) / h\n\n value_dz = (sigmayz_2(i,j,k) - sigmayz_2(i,j,k-1)) / h &\n + (sigmayz_3(i,j,k) - sigmayz_3(i,j,k-1)) / h\n\n d = dx_half_over_two(i)\n\n vy_1(i,j,k) = ( vy_1(i,j,k)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dy_half_over_two(j)\n\n vy_2(i,j,k) = ( vy_2(i,j,k)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dz_over_two(k)\n\n vy_3(i,j,k) = ( vy_3(i,j,k)*(ONE_OVER_DELTAT - d) + value_dz / rho ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,d,value_dx,value_dy,value_dz) SHARED(vz_1,vz_2, &\n!$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)\ndo k = 1,NZ-1\n do j = 2,NY\n do i = 1,NX-1\n\n value_dx = (sigmaxz_1(i+1,j,k) - sigmaxz_1(i,j,k)) / h &\n + (sigmaxz_3(i+1,j,k) - sigmaxz_3(i,j,k)) / h\n\n value_dy = (sigmayz_2(i,j,k) - sigmayz_2(i,j-1,k)) / h &\n + (sigmayz_3(i,j,k) - sigmayz_3(i,j-1,k)) / h\n\n value_dz = (sigmazz_1(i,j,k+1) - sigmazz_1(i,j,k)) / h &\n + (sigmazz_2(i,j,k+1) - sigmazz_2(i,j,k)) / h &\n + (sigmazz_3(i,j,k+1) - sigmazz_3(i,j,k)) / h\n\n d = dx_half_over_two(i)\n\n vz_1(i,j,k) = ( vz_1(i,j,k)*(ONE_OVER_DELTAT - d) + value_dx / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dy_over_two(j)\n\n vz_2(i,j,k) = ( vz_2(i,j,k)*(ONE_OVER_DELTAT - d) + value_dy / rho ) / (ONE_OVER_DELTAT + d)\n\n d = dz_half_over_two(k)\n\n vz_3(i,j,k) = ( vz_3(i,j,k)*(ONE_OVER_DELTAT - d) + value_dz / rho ) / (ONE_OVER_DELTAT + d)\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n! add the source (force vector located at a given grid point)\n a = pi*pi*f0*f0\n t = dble(it-1)*DELTAT\n\n! Gaussian\n! source_term = factor * exp(-a*(t-t0)**2)\n\n! first derivative of a Gaussian\n source_term = - factor * 2.d0*a*(t-t0)*exp(-a*(t-t0)**2)\n\n! Ricker source time function (second derivative of a Gaussian)\n! source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)\n\n force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * source_term\n force_z = 0.d0\n\n! add the source to one of the two components of the split field\n vx_1(ISOURCE,JSOURCE,KSOURCE) = vx_1(ISOURCE,JSOURCE,KSOURCE) + force_x * DELTAT / rho\n vy_1(ISOURCE,JSOURCE,KSOURCE) = vy_1(ISOURCE,JSOURCE,KSOURCE) + force_y * DELTAT / rho\n\n! implement Dirichlet boundary conditions on the six edges of the grid\n\n!$OMP PARALLEL WORKSHARE\n! xmin\n vx_1(1,:,:) = 0.d0\n vy_1(1,:,:) = 0.d0\n vz_1(1,:,:) = 0.d0\n\n vx_2(1,:,:) = 0.d0\n vy_2(1,:,:) = 0.d0\n vz_2(1,:,:) = 0.d0\n\n vx_3(1,:,:) = 0.d0\n vy_3(1,:,:) = 0.d0\n vz_3(1,:,:) = 0.d0\n\n! xmax\n vx_1(NX,:,:) = 0.d0\n vy_1(NX,:,:) = 0.d0\n vz_1(NX,:,:) = 0.d0\n\n vx_2(NX,:,:) = 0.d0\n vy_2(NX,:,:) = 0.d0\n vz_2(NX,:,:) = 0.d0\n\n vx_3(NX,:,:) = 0.d0\n vy_3(NX,:,:) = 0.d0\n vz_3(NX,:,:) = 0.d0\n\n! ymin\n vx_1(:,1,:) = 0.d0\n vy_1(:,1,:) = 0.d0\n vz_1(:,1,:) = 0.d0\n\n vx_2(:,1,:) = 0.d0\n vy_2(:,1,:) = 0.d0\n vz_2(:,1,:) = 0.d0\n\n vx_3(:,1,:) = 0.d0\n vy_3(:,1,:) = 0.d0\n vz_3(:,1,:) = 0.d0\n\n! ymax\n vx_1(:,NY,:) = 0.d0\n vy_1(:,NY,:) = 0.d0\n vz_1(:,NY,:) = 0.d0\n\n vx_2(:,NY,:) = 0.d0\n vy_2(:,NY,:) = 0.d0\n vz_2(:,NY,:) = 0.d0\n\n vx_3(:,NY,:) = 0.d0\n vy_3(:,NY,:) = 0.d0\n vz_3(:,NY,:) = 0.d0\n\n! zmin\n vx_1(:,:,1) = 0.d0\n vy_1(:,:,1) = 0.d0\n vz_1(:,:,1) = 0.d0\n\n vx_2(:,:,1) = 0.d0\n vy_2(:,:,1) = 0.d0\n vz_2(:,:,1) = 0.d0\n\n vx_3(:,:,1) = 0.d0\n vy_3(:,:,1) = 0.d0\n vz_3(:,:,1) = 0.d0\n\n! zmax\n vx_1(:,:,NZ) = 0.d0\n vy_1(:,:,NZ) = 0.d0\n vz_1(:,:,NZ) = 0.d0\n\n vx_2(:,:,NZ) = 0.d0\n vy_2(:,:,NZ) = 0.d0\n vz_2(:,:,NZ) = 0.d0\n\n vx_3(:,:,NZ) = 0.d0\n vy_3(:,:,NZ) = 0.d0\n vz_3(:,:,NZ) = 0.d0\n!$OMP END PARALLEL WORKSHARE\n\n! store seismograms\n do irec = 1,NREC\n sisvx(it,irec) = vx_1(ix_rec(irec),iy_rec(irec),iz_rec(irec)) + &\n vx_2(ix_rec(irec),iy_rec(irec),iz_rec(irec)) + vx_3(ix_rec(irec),iy_rec(irec),iz_rec(irec))\n sisvy(it,irec) = vy_1(ix_rec(irec),iy_rec(irec),iz_rec(irec)) + &\n vy_2(ix_rec(irec),iy_rec(irec),iz_rec(irec)) + vy_3(ix_rec(irec),iy_rec(irec),iz_rec(irec))\n enddo\n\n! compute total energy in the medium (without the PML layers)\n\n total_energy_kinetic = ZERO\n total_energy_potential = ZERO\n\n!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,j,k,sigmaxx_total,sigmayy_total, &\n!$OMP sigmazz_total,sigmaxy_total,sigmaxz_total,sigmayz_total,epsilon_xx,epsilon_yy,epsilon_zz,epsilon_xy,epsilon_xz,epsilon_yz) &\n!$OMP SHARED(vx_1,vx_2,vx_3,vy_1,vy_2,vy_3,vz_1,vz_2,vz_3,sigmaxx_1,sigmaxx_2, &\n!$OMP sigmaxx_3,sigmayy_1,sigmayy_2,sigmayy_3,sigmazz_1,sigmazz_2,sigmazz_3, &\n!$OMP sigmaxy_1,sigmaxy_2,sigmaxz_1,sigmaxz_3,sigmayz_2,sigmayz_3) REDUCTION(+:total_energy_kinetic,total_energy_potential)\n do k = NPOINTS_PML+1, NZ-NPOINTS_PML\n do j = NPOINTS_PML+1, NY-NPOINTS_PML\n do i = NPOINTS_PML+1, NX-NPOINTS_PML\n\n! compute kinetic energy first, defined as 1/2 rho ||v||^2\n! in principle we should use rho_half_x_half_y instead of rho for vy\n! in order to interpolate density at the right location in the staggered grid cell\n! but in a homogeneous medium we can safely ignore it\n total_energy_kinetic = total_energy_kinetic + 0.5d0 * rho*( &\n (vx_1(i,j,k) + vx_2(i,j,k) + vx_3(i,j,k))**2 + &\n (vy_1(i,j,k) + vy_2(i,j,k) + vy_3(i,j,k))**2 + &\n (vz_1(i,j,k) + vz_2(i,j,k) + vz_3(i,j,k))**2)\n\n! add potential energy, defined as 1/2 epsilon_ij sigma_ij\n! in principle we should interpolate the medium parameters at the right location\n! in the staggered grid cell but in a homogeneous medium we can safely ignore it\n\n! compute total field from split components\n sigmaxx_total = sigmaxx_1(i,j,k) + sigmaxx_2(i,j,k) + sigmaxx_3(i,j,k)\n sigmayy_total = sigmayy_1(i,j,k) + sigmayy_2(i,j,k) + sigmayy_3(i,j,k)\n sigmazz_total = sigmazz_1(i,j,k) + sigmazz_2(i,j,k) + sigmazz_3(i,j,k)\n sigmaxy_total = sigmaxy_1(i,j,k) + sigmaxy_2(i,j,k)\n sigmaxz_total = sigmaxz_1(i,j,k) + sigmaxz_3(i,j,k)\n sigmayz_total = sigmayz_2(i,j,k) + sigmayz_3(i,j,k)\n\n epsilon_xx = (2.d0*(lambda + mu) * sigmaxx_total - lambda * sigmayy_total -lambda*sigmazz_total) / &\n (2.d0 * mu * (3.d0*lambda + 2.d0*mu))\n epsilon_yy = (2.d0*(lambda + mu) * sigmayy_total - lambda * sigmaxx_total -lambda*sigmazz_total) / &\n (2.d0 * mu * (3.d0*lambda + 2.d0*mu))\n epsilon_zz = (2.d0*(lambda + mu) * sigmazz_total - lambda * sigmaxx_total -lambda*sigmayy_total) / &\n (2.d0 * mu * (3.d0*lambda + 2.d0*mu))\n epsilon_xy = sigmaxy_total / (2.d0 * mu)\n epsilon_xz = sigmaxz_total / (2.d0 * mu)\n epsilon_yz = sigmayz_total / (2.d0 * mu)\n\n total_energy_potential = total_energy_potential + &\n 0.5d0 * (epsilon_xx * sigmaxx_total + epsilon_yy * sigmayy_total + &\n epsilon_yy * sigmayy_total+ 2.d0 * epsilon_xy * sigmaxy_total + &\n 2.d0*epsilon_xz * sigmaxz_total+2.d0*epsilon_yz * sigmayz_total)\n\n enddo\n enddo\n enddo\n!$OMP END PARALLEL DO\n\n total_energy(it) = total_energy_kinetic + total_energy_potential\n\n! output information\n if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then\n\n Vsolidnorm = maxval(sqrt((vx_1 + vx_2 + vx_3)**2 + (vy_1 + vy_2 + vy_3)**2+(vz_1 + vz_2 + vz_3)**2))\n\n print *,'Time step # ',it,' out of ',NSTEP\n print *,'Time: ',sngl((it-1)*DELTAT),' seconds'\n print *,'Max norm velocity vector V (m/s) = ',Vsolidnorm\n print *,'Total energy = ',total_energy(it)\n! check stability of the code, exit if unstable\n if (Vsolidnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'\n iplane=1\n\n! count elapsed wall-clock time\n call date_and_time(datein,timein,zone,time_values)\n! time_values(3): day of the month\n! time_values(5): hour of the day\n! time_values(6): minutes of the hour\n! time_values(7): seconds of the minute\n! time_values(8): milliseconds of the second\n! this fails if we cross the end of the month\n time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &\n 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0\n\n! elapsed time since beginning of the simulation\n tCPU = time_end - time_start\n int_tCPU = int(tCPU)\n ihours = int_tCPU / 3600\n iminutes = (int_tCPU - 3600*ihours) / 60\n iseconds = int_tCPU - 3600*ihours - 60*iminutes\n write(*,*) 'Elapsed time in seconds = ',tCPU\n write(*,\"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')\") ihours,iminutes,iseconds\n write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)\n write(*,*)\n\n! write time stamp file to give information about progression of simulation\n write(outputname,\"('timestamp',i6.6)\") it\n open(unit=IOUT,file=outputname,status='unknown')\n write(IOUT,*) 'Time step # ',it\n write(IOUT,*) 'Time: ',sngl((it-1)*DELTAT),' seconds'\n write(IOUT,*) 'Max norm velocity vector V (m/s) = ',Vsolidnorm\n write(IOUT,*) 'Total energy = ',total_energy(it)\n write(IOUT,*) 'Elapsed time in seconds = ',tCPU\n write(IOUT,\"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')\") ihours,iminutes,iseconds\n write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)\n close(IOUT)\n\n! save seismograms\n print *,'saving seismograms'\n print *\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n\n! here we represent the cut plane that is in the middle of the model along the Z direction, in NZ/2\n 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, &\n NPOINTS_PML,.true.,.true.,.true.,.true.,1)\n\n 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, &\n NPOINTS_PML,.true.,.true.,.true.,.true.,2)\n\n endif\n\n enddo ! end of time loop\n\n! save seismograms\n call write_seismograms(sisvx,sisvy,NSTEP,NREC,DELTAT)\n\n! save total energy\n open(unit=20,file='energy.dat',status='unknown')\n do it = 1,NSTEP\n write(20,*) sngl(dble(it-1)*DELTAT),total_energy(it)\n enddo\n close(20)\n\n! create script for Gnuplot for total energy\n open(unit=20,file='plot_energy',status='unknown')\n write(20,*) '# set term x11'\n write(20,*) 'set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Total energy\"'\n write(20,*)\n write(20,*) 'set output \"collino3D_total_energy_semilog.eps\"'\n write(20,*) 'set logscale y'\n write(20,*) 'plot \"energy.dat\" t ''Total energy'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n close(20)\n\n! create script for Gnuplot\n open(unit=20,file='plotgnu',status='unknown')\n write(20,*) 'set term x11'\n write(20,*) '# set term postscript landscape monochrome dashed \"Helvetica\" 22'\n write(20,*)\n write(20,*) 'set xlabel \"Time (s)\"'\n write(20,*) 'set ylabel \"Amplitude (m / s)\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_001.eps\"'\n write(20,*) 'plot \"Vx_file_001.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_001.eps\"'\n write(20,*) 'plot \"Vy_file_001.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vz_receiver_001.eps\"'\n write(20,*) 'plot \"Vz_file_001.dat\" t ''Vz C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vx_receiver_002.eps\"'\n write(20,*) 'plot \"Vx_file_002.dat\" t ''Vx C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vy_receiver_002.eps\"'\n write(20,*) 'plot \"Vy_file_002.dat\" t ''Vy C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n write(20,*) 'set output \"v_sigma_Vz_receiver_002.eps\"'\n write(20,*) 'plot \"Vz_file_002.dat\" t ''Vz C-PML'' w l lc 1'\n write(20,*) 'pause -1 \"Hit any key...\"'\n write(20,*)\n\n close(20)\n\n print *\n print *,'End of the simulation'\n print *\n\n end program seismic_PML_Collino_3D_iso\n\n!----\n!---- save the seismograms in ASCII text format\n!----\n\n subroutine write_seismograms(sisvx,sisvy,nt,nrec,DELTAT)\n\n implicit none\n\n integer nt,nrec\n double precision DELTAT\n\n double precision sisvx(nt,nrec)\n double precision sisvy(nt,nrec)\n\n integer irec,it\n\n character(len=100) file_name\n\n! X component\n do irec=1,nrec\n write(file_name,\"('Vx_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvx(it,irec))\n enddo\n close(11)\n enddo\n\n! Y component\n do irec=1,nrec\n write(file_name,\"('Vy_file_',i3.3,'.dat')\") irec\n open(unit=11,file=file_name,status='unknown')\n do it=1,nt\n write(11,*) sngl(dble(it-1)*DELTAT),' ',sngl(sisvy(it,irec))\n enddo\n close(11)\n enddo\n\n end subroutine write_seismograms\n\n!----\n!---- routine to create a color image of a given vector component\n!---- the image is created in PNM format and then converted to GIF\n!----\n\n subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &\n NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)\n\n implicit none\n\n! non linear display to enhance small amplitudes for graphics\n double precision, parameter :: POWER_DISPLAY = 0.30d0\n\n! amplitude threshold above which we draw the color point\n double precision, parameter :: cutvect = 0.01d0\n\n! use black or white background for points that are below the threshold\n logical, parameter :: WHITE_BACKGROUND = .true.\n\n! size of cross and square in pixels drawn to represent the source and the receivers\n integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3\n\n integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec\n logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX\n\n double precision, dimension(NX,NY) :: image_data_2D\n\n integer, dimension(nrec) :: ix_rec,iy_rec\n\n integer :: ix,iy,irec\n\n character(len=100) :: file_name,system_command\n\n integer :: R, G, B\n\n double precision :: normalized_value,max_amplitude\n\n! open image file and create system command to convert image to more convenient format\n! use the \"convert\" command from ImageMagick http://www.imagemagick.org\n if (field_number == 1) then\n write(file_name,\"('image',i6.6,'_Vx.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')\") it,it,it\n else if (field_number == 2) then\n write(file_name,\"('image',i6.6,'_Vy.pnm')\") it\n write(system_command,\"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')\") it,it,it\n endif\n\n open(unit=27, file=file_name, status='unknown')\n\n write(27,\"('P3')\") ! write image in PNM P3 format\n\n write(27,*) NX,NY ! write image size\n write(27,*) '255' ! maximum value of each pixel color\n\n! compute maximum amplitude\n max_amplitude = maxval(abs(image_data_2D))\n\n! image starts in upper-left corner in PNM format\n do iy=NY,1,-1\n do ix=1,NX\n\n! define data as vector component normalized to [-1:1] and rounded to nearest integer\n! keeping in mind that amplitude can be negative\n normalized_value = image_data_2D(ix,iy) / max_amplitude\n\n! suppress values that are outside [-1:+1] to avoid small edge effects\n if (normalized_value < -1.d0) normalized_value = -1.d0\n if (normalized_value > 1.d0) normalized_value = 1.d0\n\n! draw an orange cross to represent the source\n if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &\n iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &\n (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &\n iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then\n R = 255\n G = 157\n B = 0\n\n! display two-pixel-thick black frame around the image\n else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then\n R = 0\n G = 0\n B = 0\n\n! display edges of the PML layers\n else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &\n (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &\n (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &\n (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then\n R = 255\n G = 150\n B = 0\n\n! suppress all the values that are below the threshold\n else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then\n\n! use a black or white background for points that are below the threshold\n if (WHITE_BACKGROUND) then\n R = 255\n G = 255\n B = 255\n else\n R = 0\n G = 0\n B = 0\n endif\n\n! represent regular image points using red if value is positive, blue if negative\n else if (normalized_value >= 0.d0) then\n R = nint(255.d0*normalized_value**POWER_DISPLAY)\n G = 0\n B = 0\n else\n R = 0\n G = 0\n B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)\n endif\n\n! draw a green square to represent the receivers\n do irec = 1,nrec\n if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &\n (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &\n iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then\n! use dark green color\n R = 30\n G = 180\n B = 60\n endif\n enddo\n\n! write color pixel\n write(27,\"(i3,' ',i3,' ',i3)\") R,G,B\n\n enddo\n enddo\n\n! close file\n close(27)\n\n! call the system to convert image to Gif (can be commented out if \"call system\" is missing in your compiler)\n! call system(system_command)\n\n end subroutine create_color_image\n\n" } ]