├── .gitignore ├── LICENSE ├── README.rst ├── example └── Dispersion.ipynb ├── pydisp ├── pydisp.h ├── pydisp.pyx └── surfmodes │ ├── .gitignore │ ├── .gitkeep │ ├── C_interval.f90 │ ├── C_interval_L.f90 │ ├── GRT.f90 │ ├── Love.f90 │ ├── Makefile │ ├── Makefile2 │ ├── Rayleigh.f90 │ ├── SearchLove.f90 │ ├── SearchRayleigh.f90 │ ├── disp96.f90 │ ├── disper.f90 │ ├── eigenfunctions.f90 │ ├── eigenfunctions_L.f90 │ ├── hash.f90 │ ├── model.dat │ ├── surfdisp96.f │ ├── surfmodes.f90 │ └── util.f90 └── setup.py /.gitignore: -------------------------------------------------------------------------------- 1 | build/ 2 | *.so 3 | dist/ 4 | MCDisp* 5 | pydisp/pydisp.c 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /README.rst: -------------------------------------------------------------------------------- 1 | ============ 2 | MCDisp 3 | ============ 4 | 5 | Surface wave dispersion curve inversion using Monte Carlo sampling 6 | 7 | Installation 8 | -------------- 9 | 10 | Dependencies 11 | ^^^^^^^^^^^^^^ 12 | 13 | +---------------------------+-------------------------------+ 14 | | **Package** | **Version** | 15 | +---------------------------+-------------------------------+ 16 | | Pymc3 | 3.X | 17 | +---------------------------+-------------------------------+ 18 | | Numpy | >= 1.15.0 | 19 | +---------------------------+-------------------------------+ 20 | | Cython | >= 0.29.0 | 21 | +---------------------------+-------------------------------+ 22 | 23 | Installing 24 | ^^^^^^^^^^^^^ 25 | 26 | .. code-block:: sh 27 | 28 | # first clone the repository 29 | git clone 'https://github.com/xin2zhang/MCDisp.git' 30 | # then install it 31 | cd MCDisp 32 | python setup.py install 33 | If you want to install it in development mode, so that changes do not require a reinstall 34 | 35 | .. code-block:: sh 36 | 37 | python setup.py develop 38 | 39 | 40 | Modal approximation 41 | -------------- 42 | 43 | The 1d modal approximation code used to compute dispersion curves is from Computer Program in Seismology (CPS, http://www.eas.slu.edu/eqc/eqccps.html). 44 | This package provides a Python interface for the original Fortran code. 45 | To use this code, 46 | 47 | .. code-block:: 48 | 49 | from pydisp import disp 50 | phase = disp(thk,vp,vs,rho,freqs,modetype=1,phasetype=0,dc=1e-3) 51 | # thk, vp, vs, rho are 1D arrays with same size 52 | # freqs is a 1D array of frequencies 53 | # modetype: 1 for Rayleigh wave, 0 for Love wave 54 | # phasetype: 1 for group velocity, 0 for phase velocity 55 | # dc is the searching spacing for phase velocity 56 | 57 | Examples 58 | ---------- 59 | 60 | Please look through the jupyter-notebook: `Dispersion.ipynb `__ in the example folder. 61 | -------------------------------------------------------------------------------- /pydisp/pydisp.h: -------------------------------------------------------------------------------- 1 | extern void c_disp96(int *, double *, double *, double *, double *, int *, double *, 2 | int *, int *, double *, double *); 3 | -------------------------------------------------------------------------------- /pydisp/pydisp.pyx: -------------------------------------------------------------------------------- 1 | # cython: language_level=3 2 | import numpy as np 3 | cimport numpy as np 4 | 5 | cdef extern from "pydisp.h": 6 | void c_disp96(int *n, double *thick, double *vp, double *vs, double *rho, int *, double *freqs, int *modetype, int *phasetype, double *dc, double *phase) 7 | void disp96(double *thick, double *vp, double *vs, double *rho, double *freqs, int *modetype, int *phasetype, double *dc, double *phase) 8 | 9 | 10 | def disp(np.ndarray[double, ndim=1, mode="c"] thick not None, 11 | np.ndarray[double, ndim=1, mode="c"] vp not None, 12 | np.ndarray[double, ndim=1, mode="c"] vs not None, 13 | np.ndarray[double, ndim=1, mode="c"] rho not None, 14 | np.ndarray[double, ndim=1, mode="c"] freqs not None, 15 | int modetype=1, int phasetype=0, double dc=1e-3): 16 | ''' Compute dispersion curves using modal approximation method. 17 | thick : 1d array of thickness 18 | vp : 1d array of P-wave velocity 19 | vs : 1d array of S-wave velocity 20 | rho : 1d array of density 21 | freqs : 1d array of frequencies for which phase/group velocity will be computed 22 | modetype : 1 for Rayleigh wave, 0 for Love wave 23 | phasetype: 1 for group velocity, 0 for phase velocity 24 | dc : the spacing of phase velocity which is used to search phase velocities 25 | ''' 26 | 27 | cdef int n = thick.shape[0] 28 | cdef int nfreqs = freqs.shape[0] 29 | cdef np.ndarray[double, ndim=1, mode="c"] phase = np.empty(nfreqs,dtype=np.float64) 30 | 31 | c_disp96(&n, &thick[0], &vp[0], &vs[0], &rho[0], &nfreqs, &freqs[0], &modetype, &phasetype, &dc, &phase[0]) 32 | 33 | return phase 34 | -------------------------------------------------------------------------------- /pydisp/surfmodes/.gitignore: -------------------------------------------------------------------------------- 1 | *.*~ 2 | test/ 3 | test*.* 4 | *.o 5 | *.mod 6 | *.a 7 | *__genmod.f90 8 | 9 | -------------------------------------------------------------------------------- /pydisp/surfmodes/.gitkeep: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /pydisp/surfmodes/C_interval.f90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xin2zhang/MCDisp/6b84d750a8839ed045b6d7bf2ebc3ad36d7e6313/pydisp/surfmodes/C_interval.f90 -------------------------------------------------------------------------------- /pydisp/surfmodes/C_interval_L.f90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xin2zhang/MCDisp/6b84d750a8839ed045b6d7bf2ebc3ad36d7e6313/pydisp/surfmodes/C_interval_L.f90 -------------------------------------------------------------------------------- /pydisp/surfmodes/GRT.f90: -------------------------------------------------------------------------------- 1 | module m_GRT 2 | 3 | use iso_c_binding 4 | 5 | implicit none 6 | 7 | private 8 | 9 | public :: T_GRT, init_grt 10 | public :: csq 11 | public :: dp, nmode 12 | public :: pi, eps, expo 13 | public :: ai, IC 14 | 15 | ! static values 16 | integer, parameter :: dp=c_double 17 | integer, parameter :: nmode = 100 18 | complex*16,parameter::ai=(0d0,1d0) 19 | complex*16,parameter::IC=(1d0,0d0) 20 | real(kind=dp),parameter::expo=46d0,eps=1d-10 21 | real(kind=dp),parameter :: edNN=.5d0,pi=3.1415926535897932d0 22 | 23 | ! parameters used in generalized R/T method 24 | type T_GRT 25 | integer nlayers 26 | integer index0, index_a 27 | real(kind=dp) w 28 | real(kind=dp) smin, tol 29 | real(kind=dp) dc, dc2, dcm 30 | 31 | ! the first layer for calculation 32 | integer ll 33 | ! the first low velocity layer except water layers 34 | integer L1 35 | ! the last low velocity layer 36 | integer lvlast 37 | ! the number of low velocity layers in fluid 38 | integer no_lvl_fl 39 | ! the number of low velocity layers 40 | integer no_lvl 41 | ! the number of layers whose velocity < first vs 42 | integer nlvl1, nlvls1 43 | ! the number of fluid layers 44 | integer ifs 45 | ! the index of velocity layers in ascending order 46 | integer, dimension(:), allocatable :: lvls 47 | 48 | ! velocity and mu 49 | integer :: ilastvs 50 | real(kind=dp), dimension(:), allocatable :: d 51 | real(kind=dp), dimension(:), allocatable :: vs 52 | real(kind=dp), dimension(:), allocatable :: vp 53 | real(kind=dp), dimension(:), allocatable :: rho 54 | real(kind=dp), dimension(:), allocatable :: v 55 | real(kind=dp), dimension(:), allocatable :: mu 56 | real(kind=dp) :: mu0 57 | real(kind=dp) :: vsy, vs1, vsm, vss1 58 | 59 | ! storeage for the root 60 | real(kind=dp) :: root1(nmode) 61 | integer ncr1 62 | endtype T_GRT 63 | 64 | contains 65 | 66 | subroutine init_grt(GRT, nlayers) 67 | type(T_GRT), intent(out) :: GRT 68 | integer, intent(in) :: nlayers 69 | 70 | GRT%nlayers = nlayers 71 | GRT%w = 0 72 | GRT%index0 = 0 73 | GRT%index_a = 0 74 | GRT%smin = 1E-4 75 | GRT%tol = 1E-5 76 | GRT%dc = 1E-4 77 | GRT%dc2 = 1E-4 78 | GRT%dcm = 1E-4 79 | 80 | GRT%ll = 0 81 | GRT%L1 = 0 82 | GRT%lvlast = 0 83 | GRT%no_lvl_fl = 0 84 | GRT%no_lvl = 0 85 | GRT%nlvl1 = 0 86 | GRT%nlvls1 = 0 87 | GRT%ifs = 0 88 | GRT%ilastvs = 0 89 | 90 | allocate( GRT%d(nlayers) ) 91 | allocate( GRT%vp(nlayers) ) 92 | allocate( GRT%vs(nlayers) ) 93 | allocate( GRT%rho(nlayers) ) 94 | allocate( GRT%v(2*nlayers) ) 95 | allocate( GRT%mu(nlayers) ) 96 | allocate( GRT%lvls(nlayers/2+1) ) 97 | GRT%d = 0 98 | GRT%vp = 0 99 | GRT%vs = 0 100 | GRT%rho = 0 101 | GRT%v = 0 102 | GRT%mu = 0 103 | GRT%mu0 = 0 104 | GRT%lvls = 0 105 | GRT%vsy = huge(grt%vsy) 106 | GRT%vs1 = 0 107 | GRT%vss1 = 0 108 | GRT%vsm = 0 109 | end subroutine init_grt 110 | 111 | complex*16 function csq(c,vel) 112 | implicit none 113 | real(kind=dp) c,vel 114 | csq=sqrt(dcmplx(1-(c/vel)**2)) 115 | !csq=sqrt(dcmplx(1./(c*c)-1./(vel*vel))) 116 | end function csq 117 | 118 | end module m_GRT 119 | -------------------------------------------------------------------------------- /pydisp/surfmodes/Love.f90: -------------------------------------------------------------------------------- 1 | module Love 2 | use m_GRT, only: dp, T_GRT, csq, IC 3 | 4 | implicit none 5 | 6 | private 7 | 8 | public :: SecFuns_L 9 | public :: init_love, delete_love 10 | 11 | 12 | complex*16,allocatable::RduL(:),RudL(:),TdL(:),TuL(:) 13 | complex*16,private::r 14 | complex*16::a22(2,2),b22(2,2) 15 | complex*16::cs(0:1),la(2) 16 | !$omp threadprivate(RduL, RudL, TdL, TuL, a22, b22, cs, la) 17 | 18 | CONTAINS 19 | 20 | subroutine init_love(nly) 21 | implicit none 22 | integer, intent(in) :: nly 23 | 24 | allocate(RduL(1:nly-1),TdL(1:nly-1),& 25 | RudL(0:nly-2),TuL(1:nly-2)) 26 | RduL = 0 27 | TdL = 0 28 | RudL = 0 29 | TuL = 0 30 | end subroutine 31 | 32 | subroutine delete_love 33 | implicit none 34 | 35 | deallocate(RduL,TdL,RudL,TuL) 36 | 37 | end subroutine 38 | 39 | function EinvE_L(j,c,iq,GRT) 40 | implicit none 41 | complex*16 EinvE_L(2,2) 42 | real*8,intent(in):: c 43 | integer,intent(in):: iq,j ! interface number 44 | type(T_GRT), intent(in) :: GRT 45 | 46 | integer k 47 | real(kind=dp) am, as 48 | 49 | do k=1,iq,-1 50 | as=GRT%vs(j+k) 51 | cs(k)=csq(c,as) 52 | am=GRT%mu(j+k) 53 | select case(k) 54 | case(1) ! below the interface 55 | a22(:,2)=[IC,am*cs(k)] 56 | a22(:,1)=[IC,-a22(2,2)] 57 | case(0) ! above the interface 58 | b22(:,1)=am*cs(k) 59 | b22(:,2)=[-IC,IC] 60 | b22=b22/(2.*b22(1,1)) 61 | end select 62 | enddo 63 | if(iq==0) then 64 | EinvE_L=matmul(b22,a22) 65 | else 66 | EinvE_L=a22 67 | endif 68 | end function EinvE_L 69 | 70 | subroutine propdn_L(c,j1,j2,GRT) 71 | implicit none 72 | real*8,intent(in)::c 73 | integer,intent(in)::j1,j2 74 | type(T_GRT), intent(in) :: GRT 75 | 76 | integer j 77 | real(kind=dp) vk 78 | 79 | vk = GRT%w/c 80 | a22=EinvE_L(GRT%ifs,c,1,GRT) 81 | la(2)=exp(-GRT%d(1+GRT%ifs)*vk*cs(1)) 82 | RudL(GRT%ifs)=-a22(2,2)*la(2)/a22(2,1) 83 | 84 | ! now loop downward over other interfaces 85 | do j=j1,j2-1 86 | a22=EinvE_L(j,c,0,GRT) 87 | la=[exp(-GRT%d(j)*vk*cs(0)),exp(-GRT%d(j+1)*vk*cs(1))] 88 | la(1)=la(1)*RudL(j-1) 89 | RudL(j)=(a22(1,2)-la(1)*a22(2,2))*la(2) & 90 | /(la(1)*a22(2,1)-a22(1,1)) 91 | TuL(j)=a22(2,1)*RudL(j)+a22(2,2)*la(2) 92 | enddo 93 | end subroutine propdn_L 94 | 95 | subroutine propup_L(c,j2,j1,GRT) 96 | implicit none 97 | real*8,intent(in)::c 98 | integer,intent(in)::j1,j2 99 | type(T_GRT), intent(in) :: GRT 100 | 101 | integer j 102 | real(kind=dp) vk 103 | 104 | vk = GRT%w/c 105 | a22=EinvE_L(j2,c,0,GRT) 106 | TdL(j2)=exp(-GRT%d(j2)*vk*cs(0))/a22(1,1) 107 | RduL(j2)=a22(2,1)*TdL(j2) 108 | ! now loop upward over other interfaces 109 | do j=j2-1,j1,-1 110 | a22=EinvE_L(j,c,0,GRT) 111 | r=exp(-GRT%d(j+1)*vk*cs(1))*RduL(j+1) 112 | TdL(j)=exp(-GRT%d(j)*vk*cs(0))/(a22(1,1)+a22(1,2)*r) 113 | RduL(j)=(a22(2,1)+a22(2,2)*r)*TdL(j) 114 | enddo 115 | end subroutine propup_L 116 | 117 | real*8 function SecFuns_L(lay,c,GRT,imf) 118 | implicit none 119 | integer,intent(in)::lay 120 | real*8,intent(in)::c 121 | type(T_GRT), intent(in) :: GRT 122 | real*8,intent(out)::Imf 123 | 124 | complex*16 dsp 125 | real(kind=dp) vk 126 | vk=GRT%w/c 127 | call propdn_L(c,1+GRT%ifs,lay,GRT) 128 | call propup_L(c,GRT%ll-1,lay,GRT) 129 | dsp=IC-RudL(lay-1)*RduL(lay) 130 | SecFuns_L=aimag(dsp) 131 | Imf=dble(dsp) 132 | end function SecFuns_L 133 | 134 | end module Love 135 | -------------------------------------------------------------------------------- /pydisp/surfmodes/Makefile: -------------------------------------------------------------------------------- 1 | # List of source code file 2 | obj = GRT.o Rayleigh.o util.o Love.o C_interval.o C_interval_L.o SearchRayleigh.o SearchLove.o surfdisp96.o surfmodes.o disp96.o 3 | 4 | # Archive toll 5 | AR = ar r 6 | SURF_LIB = libsurfmodes.a 7 | 8 | # Compiler 9 | F90 = gfortran 10 | F77FLAGS = -fPIC -O3 -ffree-line-length-0 -ffixed-line-length-0 -cpp 11 | FFLAGS += -fPIC -O3 12 | 13 | # rule for building surface modes code 14 | $(SURF_LIB): $(obj) 15 | $(AR) $@ $^ 16 | #$(F90) -shared -fPIC -o $@ $(obj) 17 | 18 | # rule for building object file 19 | %.o : %.f90 20 | $(F90) $(FFLAGS) -c -o $@ $< 21 | 22 | %.o : %.f 23 | $(F90) $(F77FLAGS) -c -o $@ $< 24 | 25 | .PHONY: clean cleanall 26 | 27 | clean: 28 | rm -f *.o *.mod 29 | 30 | cleanall: clean 31 | rm -f *.a 32 | -------------------------------------------------------------------------------- /pydisp/surfmodes/Makefile2: -------------------------------------------------------------------------------- 1 | # List of source code file 2 | obj = GRT.o Rayleigh.o util.o Love.o C_interval.o C_interval_L.o SearchRayleigh.o SearchLove.o surfdisp96.o surfmodes.o test.o 3 | 4 | # Whether to run in debugging mode 5 | DEBUG = 6 | 7 | # bin dir 8 | BIN_DIR = . 9 | 10 | # Set the compiler 11 | F90 = gfortran 12 | CC = g++ 13 | 14 | #F90 = ifort 15 | 16 | # gfortran settings 17 | # ================= 18 | #FFLAGS += -ffree-line-length-0 -cpp 19 | FFLAGS += -ffree-line-length-0 -ffixed-line-length-0 -cpp 20 | FFLAGS += -fopenmp 21 | 22 | ifdef DEBUG 23 | #FFLAGS += -O0 -g -Wall -Wtabs -Wextra -Wconversion -fimplicit-none -fbacktrace -fcheck=all -ffpe-trap=zero,overflow,underflow -finit-real=nan 24 | FFLAGS += -O0 -g -Wall -Wtabs -Wextra -Wconversion -fimplicit-none -fbacktrace -fcheck=all -finit-real=nan 25 | F77FLAGS = -O0 -g -ffree-line-length-0 -ffixed-line-length-0 -cpp 26 | CFLAGS += -O0 -g -std=c++11 -frounding-math -Wall -Wextra -ansi -pedantic 27 | else 28 | FFLAGS += -Ofast -g 29 | CFLAGS += -Ofast -std=c++11 -frounding-math 30 | endif 31 | 32 | all :: test 33 | 34 | test :: $(obj) 35 | $(F90) $(FFLAGS) $(LDFLAGS) $^ $(LDLIBS) -o $(BIN_DIR)/$@ 36 | 37 | #disper.o : disper.f90 $(obj) 38 | # $(F90) $(INCLIKE) $(INCFLAGS) $(FFLAGS) -c -o $@ $< 39 | 40 | %.o : %.f90 41 | $(F90) $(INCLIKE) $(INCFLAGS) $(FFLAGS) -c -o $@ $< 42 | 43 | %.o : %.f 44 | $(F90) $(INCLIKE) $(INCFLAGS) $(F77FLAGS) -c -o $@ $< 45 | 46 | clean: 47 | rm -f *.o *.mod 48 | -------------------------------------------------------------------------------- /pydisp/surfmodes/Rayleigh.f90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xin2zhang/MCDisp/6b84d750a8839ed045b6d7bf2ebc3ad36d7e6313/pydisp/surfmodes/Rayleigh.f90 -------------------------------------------------------------------------------- /pydisp/surfmodes/SearchLove.f90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xin2zhang/MCDisp/6b84d750a8839ed045b6d7bf2ebc3ad36d7e6313/pydisp/surfmodes/SearchLove.f90 -------------------------------------------------------------------------------- /pydisp/surfmodes/SearchRayleigh.f90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xin2zhang/MCDisp/6b84d750a8839ed045b6d7bf2ebc3ad36d7e6313/pydisp/surfmodes/SearchRayleigh.f90 -------------------------------------------------------------------------------- /pydisp/surfmodes/disp96.f90: -------------------------------------------------------------------------------- 1 | module m_disp 2 | use iso_c_binding, only : c_double, c_int 3 | 4 | implicit none 5 | 6 | contains 7 | subroutine disp96(thick, vp, vs, rho, freqs, modetype, phasetype, dc, phase) 8 | use m_surfmodes, only: surfmodes, T_MODES_PARA 9 | implicit none 10 | real(kind=c_double), dimension(:), intent(in) :: thick 11 | real(kind=c_double), dimension(:), intent(in) :: vp 12 | real(kind=c_double), dimension(:), intent(in) :: vs 13 | real(kind=c_double), dimension(:), intent(in) :: rho 14 | real(kind=c_double), dimension(:), intent(in) :: freqs 15 | integer(c_int), intent(in) :: modetype, phasetype 16 | real(kind=c_double), intent(in) :: dc 17 | real(kind=c_double), dimension(:), intent(out) :: phase 18 | 19 | type(T_MODES_PARA) :: paras 20 | real(kind=c_double), dimension(:), allocatable :: pvel, gvel 21 | integer :: nfreqs, ierr 22 | 23 | nfreqs = size(freqs) 24 | allocate( pvel(nfreqs), gvel(nfreqs) ) 25 | pvel = 0 26 | gvel = 0 27 | 28 | paras%modetype = modetype 29 | paras%phaseGroup = phasetype 30 | paras%tolmin = 1E-6 31 | paras%tolmax = 1E-5 32 | paras%smin_min = 1E-3 33 | paras%smin_max = 5E-3 34 | paras%dc = dc 35 | paras%dcm = dc 36 | paras%dc1 = dc 37 | paras%dc2 = dc 38 | 39 | call surfmodes(thick, vp, vs, rho, freqs, paras, pvel, gvel, ierr) 40 | 41 | phase = 0 42 | if(phasetype==0)then 43 | phase = pvel 44 | else 45 | phase = gvel 46 | endif 47 | if(ierr==1)then 48 | phase = 0 49 | endif 50 | 51 | end subroutine 52 | 53 | subroutine c_disp96(n, thick, vp, vs, rho, nf, freqs, modetype, phasetype, dc, phase) bind(c) 54 | integer(c_int), intent(in) :: n, nf 55 | real(kind=c_double), dimension(n), intent(in) :: thick 56 | real(kind=c_double), dimension(n), intent(in) :: vp 57 | real(kind=c_double), dimension(n), intent(in) :: vs 58 | real(kind=c_double), dimension(n), intent(in) :: rho 59 | real(kind=c_double), dimension(nf), intent(in) :: freqs 60 | integer(c_int), intent(in) :: modetype, phasetype 61 | real(kind=c_double), intent(in) :: dc 62 | real(kind=c_double), dimension(nf), intent(out) :: phase 63 | 64 | call disp96(thick,vp,vs,rho,freqs,modetype,phasetype,dc,phase) 65 | 66 | end subroutine 67 | 68 | end module 69 | -------------------------------------------------------------------------------- /pydisp/surfmodes/disper.f90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xin2zhang/MCDisp/6b84d750a8839ed045b6d7bf2ebc3ad36d7e6313/pydisp/surfmodes/disper.f90 -------------------------------------------------------------------------------- /pydisp/surfmodes/eigenfunctions.f90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xin2zhang/MCDisp/6b84d750a8839ed045b6d7bf2ebc3ad36d7e6313/pydisp/surfmodes/eigenfunctions.f90 -------------------------------------------------------------------------------- /pydisp/surfmodes/eigenfunctions_L.f90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xin2zhang/MCDisp/6b84d750a8839ed045b6d7bf2ebc3ad36d7e6313/pydisp/surfmodes/eigenfunctions_L.f90 -------------------------------------------------------------------------------- /pydisp/surfmodes/hash.f90: -------------------------------------------------------------------------------- 1 | module hash 2 | implicit none 3 | !real*8,allocatable::FMRay(:,:,:) 4 | !real*8,target::a44(4,4),b44(4,4) 5 | !complex*16,target,allocatable::Rdu(:,:,:),Rud(:,:,:),Td(:,:,:),Tu(:,:,:) 6 | complex*16,parameter::ai=(0d0,1d0) 7 | complex*16,parameter::IC=(1d0,0d0) 8 | real*8,allocatable::d(:),z(:),vs(:),vp(:),v(:),mu(:),rho(:) 9 | real*8,parameter::expo=46d0,eps=1d-10,edNN=.5d0,pi=3.1415926535897932d0 10 | integer,parameter::nmode=1000,nmax=3000 11 | integer nf1,nf4,nf1t,nf4t,NN,ncr,index_a,index0 12 | integer::i1,i2,NN0 13 | integer modetype 14 | integer,allocatable::lvls(:) 15 | 16 | ! ll: the first calculation layer 17 | ! lvlast: the last low velocity layer 18 | ! no_lvl: the number of low velocity layers 19 | ! nlvl1: the number of layers whose velocity < first S wave velocity 20 | ! lvls: # of velocity layers in ascending order 21 | integer ifun,ilay,ll,jj,nly,lvl,lvlast,& 22 | nlvl1,no_lvl,no_lvl_fl,ileaky,im1,ifs,L1 23 | logical Lend 24 | character*20 suf 25 | real*8 ap,as,am,vs1,vsm,vsmin,vsy,imf, mu0 26 | real*8 vk,w,freq,df,ff1,ff4 27 | real*8 tol0,tol,smin, dc,dcm, dc1,dc2 28 | real*8 tolmin,tolmax,smin_min,smin_max 29 | !real*8 dc1min,dc1max,dc2min,dc2max 30 | real*8,target::cr(3,nmode) 31 | real*8,pointer::root2(:),cr1 32 | real*8 allroots(3000,nmode),root1(nmode),ccc(20000),NNN_max 33 | !equivalence(cr1,cr(1,1)) 34 | !target cr 35 | end module hash 36 | -------------------------------------------------------------------------------- /pydisp/surfmodes/model.dat: -------------------------------------------------------------------------------- 1 | 5 2 | 0.10000000000000001 2.8343793669911984 2.5825142775621530 2.1667060638969216 3 | 1.7000000000000002 2.8547849595267989 1.5121378245836730 2.2617395930051476 4 | 1.0000000000000000 4.6579939060979507 2.2201301658572934 2.5562244215165064 5 | 2.1000000000000001 4.1008595181156924 2.3704390016781254 2.4760988227494232 6 | 0.0000000000000000 4.5746158111015758 2.9196517156147563 2.5447077199113832 7 | -------------------------------------------------------------------------------- /pydisp/surfmodes/surfdisp96.f: -------------------------------------------------------------------------------- 1 | c----------------------------------------------------------------------c 2 | c c 3 | c COMPUTER PROGRAMS IN SEISMOLOGY c 4 | c VOLUME IV c 5 | c c 6 | c PROGRAM: SRFDIS c 7 | c c 8 | c COPYRIGHT 1986, 1991 c 9 | c D. R. Russell, R. B. Herrmann c 10 | c Department of Earth and Atmospheric Sciences c 11 | c Saint Louis University c 12 | c 221 North Grand Boulevard c 13 | c St. Louis, Missouri 63103 c 14 | c U. S. A. c 15 | c c 16 | c----------------------------------------------------------------------c 17 | c This is a combination of program 'surface80' which search the poles 18 | c on C-T domain, and the program 'surface81' which search in the F-K 19 | c domain. The input data is slightly different with its precessors. 20 | c -Wang 06/06/83. 21 | c 22 | c The program calculates the dispersion values for any 23 | c layered model, any frequency, and any mode. 24 | c 25 | c This program will accept one liquid layer at the surface. 26 | c In such case ellipticity of rayleigh wave is that at the 27 | c top of solid array. Love wave communications ignore 28 | c liquid layer. 29 | c 30 | c Program developed by Robert B Herrmann Saint Louis 31 | c univ. Nov 1971, and revised by C. Y. Wang on Oct 1981. 32 | c Modified for use in surface wave inversion, and 33 | c addition of spherical earth flattening transformation, by 34 | c David R. Russell, St. Louis University, Jan. 1984. 35 | c 36 | c Changes 37 | c 28 JAN 2003 - fixed minor but for sphericity correction by 38 | c saving one parameter in subroutine sphere 39 | c 20 JUL 2004 - removed extraneous line at line 550 40 | c since dc not defined 41 | c if(dabs(c1-c2) .le. dmin1(1.d-6*c1,0.005d+0*dc) )go to 1000 42 | c 28 DEC 2007 - changed the Earth flattening to now use layer 43 | c midpoint and the Biswas (1972: PAGEOPH 96, 61-74, 1972) 44 | c density mapping for P-SV - note a true comparison 45 | c requires the ability to handle a fluid core for SH and SV 46 | c Also permit one layer with fluid is base of the velocity is 0.001 km/sec 47 | c----- 48 | c 13 JAN 2010 - modified by Huajian Yao at MIT for calculation of 49 | c group or phase velocities 50 | c----- 51 | 52 | subroutine surfdisp96(thkm,vpm,vsm,rhom,nlayer,iflsph,iwave, 53 | & mode,igr,kmax,t,dphase,cp,cg,ierr) 54 | 55 | parameter(LER=0,LIN=5,LOT=66) 56 | integer NL, NL2, NLAY 57 | parameter(NL=200,NLAY=200,NL2=NL+NL) 58 | integer NP 59 | parameter (NP=60) 60 | ! increment of phase velocity 61 | real(kind=8) :: dphase 62 | double precision :: cp(kmax) 63 | ! err flag 64 | integer ierr 65 | 66 | c----- 67 | c LIN - unit for FORTRAN read from terminal 68 | c LOT - unit for FORTRAN write to terminal 69 | c LER - unit for FORTRAN error output to terminal 70 | c NL - layers in model 71 | c NP - number of unique periods 72 | c----- 73 | c----- parameters 74 | c thkm, vpm, vsm, rhom: model for dispersion calculation 75 | c nlayer - I4: number of layers in the model 76 | c iflsph - I4: 0 flat earth model, 1 spherical earth model 77 | c iwave - I4: 1 Love wave, 2 Rayleigh wave 78 | c mode - I4: ith mode of surface wave, 1 fundamental, 2 first higher, .... 79 | c igr - I4: 0 phase velocity, > 0 group velocity 80 | c kmax - I4: number of periods (t) for dispersion calculation 81 | c t - period vector (t(NP)) 82 | c cg - output phase or group velocities (vector,cg(NP)) 83 | c----- 84 | real*4 thkm(NLAY),vpm(NLAY),vsm(NLAY),rhom(NLAY) 85 | integer nlayer,iflsph,iwave,mode,igr,kmax 86 | double precision twopi,one,onea 87 | double precision cc,c1,clow,cm,dc,t1 88 | double precision t(NP),c(NP),cb(NP),cg(kmax) 89 | real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) 90 | c common/modl/ d,a,b,rho,rtp,dtp,btp 91 | c common/para/ mmax,llw,twopi 92 | integer*4 iverb(2) 93 | integer*4 llw 94 | integer*4 nsph, ifunc, idispl, idispr, is, ie 95 | real*4 sone0, ddc0, h0, sone, ddc, h 96 | integer previd 97 | 98 | c maximum number of layers in the model 99 | mmax = nlayer 100 | c is the model flat (nsph = 0) or sphere (nsph = 1) 101 | nsph = iflsph 102 | ierr = 0 103 | cp = 100.0 !safe 104 | cg = 100.0 !safe 105 | 106 | c----- 107 | c save current values 108 | do 39 i=1,mmax 109 | b(i) = vsm(i) 110 | a(i) = vpm(i) 111 | d(i) = thkm(i) 112 | rho(i) = rhom(i) 113 | c print *,d(i), b(i) 114 | 39 continue 115 | 116 | if(iwave.eq.1)then 117 | idispl = kmax 118 | idispr = 0 119 | elseif(iwave.eq.2)then 120 | idispl = 0 121 | idispr = kmax 122 | endif 123 | 124 | iverb(1) = 0 125 | iverb(2) = 0 126 | c ---- constant value 127 | sone0 = 1.500 128 | c ---- phase velocity increment for searching root 129 | !ddc0 = 0.001 130 | ddc0 = dphase 131 | c ---- frequency increment (%) for calculating group vel. using g = dw/dk = dw/d(w/c) 132 | h0 = 0.005 133 | c ---- period range is:ie for calculation of dispersion 134 | 135 | c----- 136 | c check for water layer 137 | c----- 138 | llw=1 139 | if(b(1).le.0.0) llw=2 140 | twopi=2.d0*3.141592653589793d0 141 | one=1.0d-2 142 | if(nsph.eq.1) call sphere(0,0,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 143 | JMN = 1 144 | betmx=-1.e20 145 | betmn=1.e20 146 | c----- 147 | c find the extremal velocities to assist in starting search 148 | c----- 149 | do 20 i=1,mmax 150 | if(b(i).gt.0.01 .and. b(i).lt.betmn)then 151 | betmn = b(i) 152 | jmn = i 153 | jsol = 1 154 | elseif(b(i).le.0.01 .and. a(i).lt.betmn)then 155 | betmn = a(i) 156 | jmn = i 157 | jsol = 0 158 | endif 159 | if(b(i).gt.betmx) betmx=b(i) 160 | 20 continue 161 | cc WRITE(6,*)'betmn, betmx:',betmn, betmx 162 | c if(idispl.gt.0)then 163 | cc open(1,file='tmpsrfi.06',form='unformatted', 164 | cc 1 access='sequential') 165 | cc rewind 1 166 | c read(*,*) lovdispfile 167 | c open(1, file = lovdispfile); 168 | c endif 169 | c if(idispr.gt.0)then 170 | cc open(2,file='tmpsrfi.07',form='unformatted', 171 | cc 1 access='sequential') 172 | cc rewind 2 173 | c read(*,*) raydispfile 174 | c open(2, file = raydispfile); 175 | c endif 176 | do 2000 ifunc=1,2 177 | if(ifunc.eq.1.and.idispl.le.0) go to 2000 178 | if(ifunc.eq.2.and.idispr.le.0) go to 2000 179 | if(nsph.eq.1) call sphere(ifunc,1,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 180 | ddc = ddc0 181 | sone = sone0 182 | h = h0 183 | c read(*,*) kmax,mode,ddc,sone,igr,h 184 | c write(*,*) kmax,mode,ddc,sone,igr,h 185 | c read(*,*) (t(i),i=1,kmax) 186 | c write(*,*) (t(i),i=1,kmax) 187 | cc write(ifunc,*) mmax,nsph 188 | cc write(ifunc,*) (btp(i),i=1,mmax) 189 | cc write(ifunc,*) (dtp(i),i=1,mmax) 190 | cc do 420 i=1,mmax 191 | cc write(ifunc,*) d(i),a(i),b(i),rho(i) 192 | cc 420 continue 193 | c write(ifunc,*) kmax,igr,h 194 | if(sone.lt. 0.01) sone=2.0 195 | onea=dble(sone) 196 | c----- 197 | c get starting value for phase velocity, 198 | c which will correspond to the 199 | c VP/VS ratio 200 | c----- 201 | if(jsol.eq.0)then 202 | c----- 203 | c water layer 204 | c----- 205 | cc1 = betmn 206 | else 207 | c----- 208 | c solid layer solve halfspace period equation 209 | c----- 210 | call gtsolh(a(jmn),b(jmn),cc1) 211 | endif 212 | c----- 213 | c back off a bit to get a starting value at a lower phase velocity 214 | c----- 215 | cc1=.95*cc1 216 | CC1=.90*CC1 217 | cc=dble(cc1) 218 | dc=dble(ddc) 219 | dc = dabs(dc) 220 | c1=cc 221 | cm=cc 222 | do 450 i=1,kmax 223 | cb(i)=0.0d0 224 | c(i)=0.0d0 225 | 450 continue 226 | ift=999 227 | do 1800 iq=1,mode 228 | is = 1 229 | ie = kmax 230 | c read(*,*) is,ie 231 | c write(*,*) 'is =', is, ', ie = ', ie 232 | itst=ifunc 233 | do 1600 k=is,ie 234 | if(k.ge.ift) go to 1700 235 | t1=dble(t(k)) 236 | if(igr.gt.0)then 237 | t1a=t1/(1.+h) 238 | t1b=t1/(1.-h) 239 | t1=dble(t1a) 240 | else 241 | t1a=sngl(t1) 242 | tlb=0.0 243 | endif 244 | c----- 245 | c get initial phase velocity estimate to begin search 246 | c 247 | c in the notation here, c() is an array of phase velocities 248 | c c(k-1) is the velocity estimate of the present mode 249 | c at the k-1 period, while c(k) is the phase velocity of the 250 | c previous mode at the k period. Since there must be no mode 251 | c crossing, we make use of these values. The only complexity 252 | c is that the dispersion may be reversed. 253 | c 254 | c The subroutine getsol determines the zero crossing and refines 255 | c the root. 256 | c----- 257 | if(k.eq.is .and. iq.eq.1)then 258 | c1 = cc 259 | clow = cc 260 | ifirst = 1 261 | elseif(k.eq.is .and. iq.gt.1)then 262 | c1 = c(is) + one*dc 263 | clow = c1 264 | ifirst = 1 265 | elseif(k.gt.is .and. iq.gt.1)then 266 | ifirst = 0 267 | c clow = c(k) + one*dc 268 | c c1 = c(k-1) -onea*dc 269 | clow = c(k) + one*dc 270 | c1 = c(k-1) 271 | if(c1 .lt. clow)c1 = clow 272 | elseif(k.gt.is .and. iq.eq.1)then 273 | ifirst = 0 274 | c1 = cc 275 | do previd = k-1, 1, -1 276 | if(c(previd)>0)then 277 | c1 = c(previd) - onea*dc 278 | exit 279 | endif 280 | enddo 281 | clow = cm 282 | endif 283 | c----- 284 | c bracket root and refine it 285 | c----- 286 | call getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) 287 | if(iret.eq.-1)goto 1700 288 | if(iret.eq.-1)then 289 | c1=0.0 290 | ierr = 1 291 | endif 292 | c(k) = c1 293 | c----- 294 | c for group velocities compute near above solution 295 | c----- 296 | if(igr.gt.0) then 297 | t1=dble(t1b) 298 | ifirst = 0 299 | clow = cb(k) + one*dc 300 | c1 = c1 -onea*dc 301 | call getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) 302 | c----- 303 | c test if root not found at slightly larger period 304 | c----- 305 | if(iret.eq.-1)then 306 | c1 = c(k) 307 | ierr = 1 308 | endif 309 | cb(k)=c1 310 | else 311 | c1 = 0.0d+00 312 | endif 313 | cc0 = sngl(c(k)) 314 | cc1 = sngl(c1) 315 | if(igr.eq.0) then 316 | c ----- output only phase velocity 317 | c write(ifunc,*) itst,iq,t(k),cc0,0.0 318 | cp(k) = cc0 319 | else 320 | c ----- calculate group velocity and output phase and group velocities 321 | gvel = (1/t1a-1/t1b)/(1/(t1a*cc0)-1/(t1b*cc1)) 322 | cg(k) = gvel 323 | cp(k) = cc0 324 | if(gvel<0 .or. c(k)==0)then 325 | ierr = 1 326 | !write(*,*) 'gvel is smaller than zero: ', gvel 327 | endif 328 | c write(ifunc,*) itst,iq,t(k),(cc0+cc1)/2,gvel 329 | c ----- print *, itst,iq,t(k),t1a,t1b,cc0,cc1,gvel 330 | endif 331 | 1600 continue 332 | go to 1800 333 | 1700 if(iq.gt.1) go to 1750 334 | if(iverb(ifunc).eq.0)then 335 | iverb(ifunc) = 1 336 | ierr = 1 337 | !write(LOT,*)'improper initial value in disper - no zero found' 338 | !write(*,*) 'WARNING:improper initial value in disper - no zero found' 339 | !write(LOT,*)'in fundamental mode ' 340 | !write(LOT,*)'This may be due to low velocity zone ' 341 | !write(LOT,*)'causing reverse phase velocity dispersion, ' 342 | !write(LOT,*)'and mode jumping.' 343 | !write(LOT,*)'due to looking for Love waves in a halfspace' 344 | !write(LOT,*)'which is OK if there are Rayleigh data.' 345 | !write(LOT,*)'If reverse dispersion is the problem,' 346 | !write(LOT,*)'Get present model using OPTION 28, edit sobs.d,' 347 | !write(LOT,*)'Rerun with onel large than 2' 348 | !write(LOT,*)'which is the default ' 349 | c----- 350 | c if we have higher mode data and the model does not find that 351 | c mod e, just indicate (itst=0) that it has not been found, but 352 | c fil l out file with dummy results to maintain format - note 353 | c eig enfunctions will not be found for these values. The subroutine 354 | c 'am at' in 'surf' will worry about this in building up the 355 | c inp ut file for 'surfinv' 356 | c----- 357 | !write(LOT,*)'ifunc = ',ifunc ,' (1=L, 2=R)' 358 | !write(LOT,*)'mode = ',iq-1 359 | !write(LOT,*)'period= ',t(k), ' for k,is,ie=',k,is,ie 360 | !write(LOT,*)'cc,cm = ',cc,cm 361 | !write(LOT,*)'c1 = ',c1 362 | !write(LOT,*)'d,a,b,rho (d(mmax)=control ignore)' 363 | !write(LOT,'(4f15.5)')(d(i),a(i),b(i),rho(i),i=1,mmax) 364 | !write(LOT,*)' c(i),i=1,k (NOTE may be part)' 365 | !write(LOT,*)(c(i),i=1,k) 366 | endif 367 | c if(k.gt.0)goto 1750 368 | c go to 2000 369 | 1750 ift=k 370 | itst=0 371 | do 1770 i=k,ie 372 | t1a=t(i) 373 | c write(ifunc,*) itst,iq,t1a,0.0,0.0 374 | cg(i) = 0.0 375 | 1770 continue 376 | ierr = 1 377 | 1800 continue 378 | c close(ifunc,status='keep') 379 | 2000 continue 380 | c close(3,status='keep') 381 | 382 | end 383 | 384 | ! multimodes calculation 385 | subroutine surfdisp_mmodes(thkm,vpm,vsm,rhom,nlayer,iflsph,iwave, 386 | & mode,igr,kmax,t,dphase,cp,cg,ierr) 387 | 388 | parameter(LER=0,LIN=5,LOT=66) 389 | integer NL, NL2, NLAY 390 | parameter(NL=200,NLAY=200,NL2=NL+NL) 391 | integer NP 392 | parameter (NP=60) 393 | ! increment of phase velocity 394 | real(kind=8) :: dphase 395 | ! err flag 396 | integer ierr 397 | 398 | c----- 399 | c LIN - unit for FORTRAN read from terminal 400 | c LOT - unit for FORTRAN write to terminal 401 | c LER - unit for FORTRAN error output to terminal 402 | c NL - layers in model 403 | c NP - number of unique periods 404 | c----- 405 | c----- parameters 406 | c thkm, vpm, vsm, rhom: model for dispersion calculation 407 | c nlayer - I4: number of layers in the model 408 | c iflsph - I4: 0 flat earth model, 1 spherical earth model 409 | c iwave - I4: 1 Love wave, 2 Rayleigh wave 410 | c mode - I4: ith mode of surface wave, 1 fundamental, 2 first higher, .... 411 | c igr - I4: 0 phase velocity, > 0 group velocity 412 | c kmax - I4: number of periods (t) for dispersion calculation 413 | c t - period vector (t(NP)) 414 | c cg - output phase or group velocities (vector,cg(NP)) 415 | c----- 416 | real*4 thkm(NLAY),vpm(NLAY),vsm(NLAY),rhom(NLAY) 417 | integer nlayer,iflsph,iwave,mode,igr,kmax 418 | double precision twopi,one,onea 419 | double precision cc,c1,clow,cm,dc,t1 420 | double precision :: cp(kmax,mode) 421 | double precision t(NP),c(NP),cb(NP),cg(kmax,mode) 422 | real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) 423 | c common/modl/ d,a,b,rho,rtp,dtp,btp 424 | c common/para/ mmax,llw,twopi 425 | integer*4 iverb(2) 426 | integer*4 llw 427 | integer*4 nsph, ifunc, idispl, idispr, is, ie 428 | real*4 sone0, ddc0, h0, sone, ddc, h 429 | 430 | c maximum number of layers in the model 431 | mmax = nlayer 432 | c is the model flat (nsph = 0) or sphere (nsph = 1) 433 | nsph = iflsph 434 | ierr = 0 435 | cp = 0 436 | cg = 0 437 | 438 | c----- 439 | c save current values 440 | do 39 i=1,mmax 441 | b(i) = vsm(i) 442 | a(i) = vpm(i) 443 | d(i) = thkm(i) 444 | rho(i) = rhom(i) 445 | c print *,d(i), b(i) 446 | 39 continue 447 | 448 | if(iwave.eq.1)then 449 | idispl = kmax 450 | idispr = 0 451 | elseif(iwave.eq.2)then 452 | idispl = 0 453 | idispr = kmax 454 | endif 455 | 456 | iverb(1) = 0 457 | iverb(2) = 0 458 | c ---- constant value 459 | sone0 = 1.500 460 | c ---- phase velocity increment for searching root 461 | !ddc0 = 0.001 462 | ddc0 = dphase 463 | c ---- frequency increment (%) for calculating group vel. using g = dw/dk = dw/d(w/c) 464 | h0 = 0.005 465 | c ---- period range is:ie for calculation of dispersion 466 | 467 | c----- 468 | c check for water layer 469 | c----- 470 | llw=1 471 | if(b(1).le.0.0) llw=2 472 | twopi=2.d0*3.141592653589793d0 473 | one=1.0d-2 474 | if(nsph.eq.1) call sphere(0,0,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 475 | JMN = 1 476 | betmx=-1.e20 477 | betmn=1.e20 478 | c----- 479 | c find the extremal velocities to assist in starting search 480 | c----- 481 | do 20 i=1,mmax 482 | if(b(i).gt.0.01 .and. b(i).lt.betmn)then 483 | betmn = b(i) 484 | jmn = i 485 | jsol = 1 486 | elseif(b(i).le.0.01 .and. a(i).lt.betmn)then 487 | betmn = a(i) 488 | jmn = i 489 | jsol = 0 490 | endif 491 | if(b(i).gt.betmx) betmx=b(i) 492 | 20 continue 493 | cc WRITE(6,*)'betmn, betmx:',betmn, betmx 494 | c if(idispl.gt.0)then 495 | cc open(1,file='tmpsrfi.06',form='unformatted', 496 | cc 1 access='sequential') 497 | cc rewind 1 498 | c read(*,*) lovdispfile 499 | c open(1, file = lovdispfile); 500 | c endif 501 | c if(idispr.gt.0)then 502 | cc open(2,file='tmpsrfi.07',form='unformatted', 503 | cc 1 access='sequential') 504 | cc rewind 2 505 | c read(*,*) raydispfile 506 | c open(2, file = raydispfile); 507 | c endif 508 | do 2000 ifunc=1,2 509 | if(ifunc.eq.1.and.idispl.le.0) go to 2000 510 | if(ifunc.eq.2.and.idispr.le.0) go to 2000 511 | if(nsph.eq.1) call sphere(ifunc,1,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 512 | ddc = ddc0 513 | sone = sone0 514 | h = h0 515 | c read(*,*) kmax,mode,ddc,sone,igr,h 516 | c write(*,*) kmax,mode,ddc,sone,igr,h 517 | c read(*,*) (t(i),i=1,kmax) 518 | c write(*,*) (t(i),i=1,kmax) 519 | cc write(ifunc,*) mmax,nsph 520 | cc write(ifunc,*) (btp(i),i=1,mmax) 521 | cc write(ifunc,*) (dtp(i),i=1,mmax) 522 | cc do 420 i=1,mmax 523 | cc write(ifunc,*) d(i),a(i),b(i),rho(i) 524 | cc 420 continue 525 | c write(ifunc,*) kmax,igr,h 526 | if(sone.lt. 0.01) sone=2.0 527 | onea=dble(sone) 528 | c----- 529 | c get starting value for phase velocity, 530 | c which will correspond to the 531 | c VP/VS ratio 532 | c----- 533 | if(jsol.eq.0)then 534 | c----- 535 | c water layer 536 | c----- 537 | cc1 = betmn 538 | else 539 | c----- 540 | c solid layer solve halfspace period equation 541 | c----- 542 | call gtsolh(a(jmn),b(jmn),cc1) 543 | endif 544 | c----- 545 | c back off a bit to get a starting value at a lower phase velocity 546 | c----- 547 | cc1=.95*cc1 548 | CC1=.90*CC1 549 | cc=dble(cc1) 550 | dc=dble(ddc) 551 | dc = dabs(dc) 552 | c1=cc 553 | cm=cc 554 | do 450 i=1,kmax 555 | cb(i)=0.0d0 556 | c(i)=0.0d0 557 | 450 continue 558 | ift=999 559 | do 1800 iq=1,mode 560 | is = 1 561 | ie = kmax 562 | c read(*,*) is,ie 563 | c write(*,*) 'is =', is, ', ie = ', ie 564 | itst=ifunc 565 | do 1600 k=is,ie 566 | if(k.ge.ift) go to 1700 567 | t1=dble(t(k)) 568 | if(igr.gt.0)then 569 | t1a=t1/(1.+h) 570 | t1b=t1/(1.-h) 571 | t1=dble(t1a) 572 | else 573 | t1a=sngl(t1) 574 | tlb=0.0 575 | endif 576 | c----- 577 | c get initial phase velocity estimate to begin search 578 | c 579 | c in the notation here, c() is an array of phase velocities 580 | c c(k-1) is the velocity estimate of the present mode 581 | c at the k-1 period, while c(k) is the phase velocity of the 582 | c previous mode at the k period. Since there must be no mode 583 | c crossing, we make use of these values. The only complexity 584 | c is that the dispersion may be reversed. 585 | c 586 | c The subroutine getsol determines the zero crossing and refines 587 | c the root. 588 | c----- 589 | if(k.eq.is .and. iq.eq.1)then 590 | c1 = cc 591 | clow = cc 592 | ifirst = 1 593 | elseif(k.eq.is .and. iq.gt.1)then 594 | c1 = c(is) + one*dc 595 | clow = c1 596 | ifirst = 1 597 | elseif(k.gt.is .and. iq.gt.1)then 598 | ifirst = 0 599 | c clow = c(k) + one*dc 600 | c c1 = c(k-1) -onea*dc 601 | clow = c(k) + one*dc 602 | c1 = c(k-1) 603 | if(c1 .lt. clow)c1 = clow 604 | elseif(k.gt.is .and. iq.eq.1)then 605 | ifirst = 0 606 | c1 = c(k-1) - onea*dc 607 | clow = cm 608 | endif 609 | c----- 610 | c bracket root and refine it 611 | c----- 612 | call getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) 613 | if(iret.eq.-1)goto 1700 614 | c(k) = c1 615 | c----- 616 | c for group velocities compute near above solution 617 | c----- 618 | if(igr.gt.0) then 619 | t1=dble(t1b) 620 | ifirst = 0 621 | clow = cb(k) + one*dc 622 | c1 = c1 -onea*dc 623 | call getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) 624 | c----- 625 | c test if root not found at slightly larger period 626 | c----- 627 | if(iret.eq.-1)then 628 | c1 = c(k) 629 | ierr = 1 630 | endif 631 | cb(k)=c1 632 | else 633 | c1 = 0.0d+00 634 | endif 635 | cc0 = sngl(c(k)) 636 | cc1 = sngl(c1) 637 | if(igr.eq.0) then 638 | c ----- output only phase velocity 639 | c write(ifunc,*) itst,iq,t(k),cc0,0.0 640 | cp(k,iq) = cc0 641 | !if(iq>1) write(*,*) cc0, cp(k,iq) 642 | else 643 | c ----- calculate group velocity and output phase and group velocities 644 | gvel = (1/t1a-1/t1b)/(1/(t1a*cc0)-1/(t1b*cc1)) 645 | cg(k,iq) = gvel 646 | cp(k,iq) = cc0 647 | c write(ifunc,*) itst,iq,t(k),(cc0+cc1)/2,gvel 648 | c ----- print *, itst,iq,t(k),t1a,t1b,cc0,cc1,gvel 649 | endif 650 | 1600 continue 651 | go to 1800 652 | 1700 if(iq.gt.1) go to 1750 653 | if(iverb(ifunc).eq.0)then 654 | iverb(ifunc) = 1 655 | ierr = 1 656 | !write(LOT,*)'improper initial value in disper - no zero found' 657 | !write(*,*) 'WARNING:improper initial value in disper - no zero found' 658 | !write(LOT,*)'in fundamental mode ' 659 | !write(LOT,*)'This may be due to low velocity zone ' 660 | !write(LOT,*)'causing reverse phase velocity dispersion, ' 661 | !write(LOT,*)'and mode jumping.' 662 | !write(LOT,*)'due to looking for Love waves in a halfspace' 663 | !write(LOT,*)'which is OK if there are Rayleigh data.' 664 | !write(LOT,*)'If reverse dispersion is the problem,' 665 | !write(LOT,*)'Get present model using OPTION 28, edit sobs.d,' 666 | !write(LOT,*)'Rerun with onel large than 2' 667 | !write(LOT,*)'which is the default ' 668 | c----- 669 | c if we have higher mode data and the model does not find that 670 | c mod e, just indicate (itst=0) that it has not been found, but 671 | c fil l out file with dummy results to maintain format - note 672 | c eig enfunctions will not be found for these values. The subroutine 673 | c 'am at' in 'surf' will worry about this in building up the 674 | c inp ut file for 'surfinv' 675 | c----- 676 | !write(LOT,*)'ifunc = ',ifunc ,' (1=L, 2=R)' 677 | !write(LOT,*)'mode = ',iq-1 678 | !write(LOT,*)'period= ',t(k), ' for k,is,ie=',k,is,ie 679 | !write(LOT,*)'cc,cm = ',cc,cm 680 | !write(LOT,*)'c1 = ',c1 681 | !write(LOT,*)'d,a,b,rho (d(mmax)=control ignore)' 682 | !write(LOT,'(4f15.5)')(d(i),a(i),b(i),rho(i),i=1,mmax) 683 | !write(LOT,*)' c(i),i=1,k (NOTE may be part)' 684 | !write(LOT,*)(c(i),i=1,k) 685 | endif 686 | c if(k.gt.0)goto 1750 687 | c go to 2000 688 | 1750 ift=k 689 | itst=0 690 | do 1770 i=k,ie 691 | t1a=t(i) 692 | c write(ifunc,*) itst,iq,t1a,0.0,0.0 693 | cg(i,iq) = 0.0 694 | 1770 continue 695 | ierr = 1 696 | 1800 continue 697 | c close(ifunc,status='keep') 698 | 2000 continue 699 | c close(3,status='keep') 700 | 701 | end 702 | 703 | 704 | 705 | 706 | 707 | 708 | 709 | 710 | 711 | subroutine gtsolh(a,b,c) 712 | c----- 713 | c starting solution 714 | c----- 715 | real*4 kappa, k2, gk2 716 | c = 0.95*b 717 | do 100 i=1,5 718 | gamma = b/a 719 | kappa = c/b 720 | k2 = kappa**2 721 | gk2 = (gamma*kappa)**2 722 | fac1 = sqrt(1.0 - gk2) 723 | fac2 = sqrt(1.0 - k2) 724 | fr = (2.0 - k2)**2 - 4.0*fac1*fac2 725 | frp = -4.0*(2.0-k2) *kappa 726 | 1 +4.0*fac2*gamma*gamma*kappa/fac1 727 | 2 +4.0*fac1*kappa/fac2 728 | frp = frp/b 729 | c = c - fr/frp 730 | 100 continue 731 | return 732 | end 733 | 734 | subroutine getsol(t1,c1,clow,dc,cm,betmx,iret,ifunc,ifirst,d,a,b,rho,rtp,dtp,btp,mmax,llw) 735 | c----- 736 | c subroutine to bracket dispersion curve 737 | c and then refine it 738 | c----- 739 | c t1 - period 740 | c c1 - initial guess on low side of mode 741 | c clow - lowest possible value for present mode in a 742 | c reversed direction search 743 | c dc - phase velocity search increment 744 | c cm - minimum possible solution 745 | c betmx - maximum shear velocity 746 | c iret - 1 = successful 747 | c - -1= unsuccessful 748 | c ifunc - 1 - Love 749 | c - 2 - Rayleigh 750 | c ifirst - 1 this is first period for a particular mode 751 | c - 0 this is not the first period 752 | c (this is to define period equation sign 753 | c for mode jumping test) 754 | c----- 755 | parameter (NL=200) 756 | real*8 wvno, omega, twopi 757 | real*8 c1, c2, cn, cm, dc, t1, clow 758 | real*8 dltar, del1, del2, del1st, plmn 759 | save del1st 760 | !$omp threadprivate(del1st) 761 | real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) 762 | integer llw,mmax 763 | c----- 764 | c to avoid problems in mode jumping with reversed dispersion 765 | c we note what the polarity of period equation is for phase 766 | c velocities just beneath the zero crossing at the 767 | c first period computed. 768 | c----- 769 | c bracket solution 770 | c----- 771 | twopi=2.d0*3.141592653589793d0 772 | omega=twopi/t1 773 | wvno=omega/c1 774 | del1 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 775 | if(ifirst.eq.1)del1st = del1 776 | plmn = dsign(1.0d+00,del1st)*dsign(1.0d+00,del1) 777 | if(ifirst.eq.1)then 778 | idir = +1 779 | elseif(ifirst.ne.1 .and. plmn.ge.0.0d+00)then 780 | idir = +1 781 | elseif(ifirst.ne.1 .and. plmn.lt.0.0d+00)then 782 | idir = -1 783 | endif 784 | c----- 785 | c idir indicates the direction of the search for the 786 | c true phase velocity from the initial estimate. 787 | c Usually phase velocity increases with period and 788 | c we always underestimate, so phase velocity should increase 789 | c (idir = +1). For reversed dispersion, we should look 790 | c downward from the present estimate. However, we never 791 | c go below the floor of clow, when the direction is reversed 792 | c----- 793 | 1000 continue 794 | if(idir.gt.0)then 795 | c2 = c1 + dc 796 | else 797 | c2 = c1 - dc 798 | endif 799 | if(c2.le.clow)then 800 | idir = +1 801 | c1 = clow 802 | endif 803 | if(c2.le.clow)goto 1000 804 | omega=twopi/t1 805 | wvno=omega/c2 806 | del2 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 807 | if (dsign(1.0d+00,del1).ne.dsign(1.0d+00,del2)) then 808 | go to 1300 809 | endif 810 | c1=c2 811 | del1=del2 812 | c check that c1 is in region of solutions 813 | if(c1.lt.cm) go to 1700 814 | if(c1.ge.(betmx+dc)) go to 1700 815 | go to 1000 816 | c----- 817 | c root bracketed, refine it 818 | c----- 819 | 1300 call nevill(t1,c1,c2,del1,del2,ifunc,cn,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 820 | c1 = cn 821 | if(c1.gt.(betmx)) go to 1700 822 | iret = 1 823 | return 824 | 1700 continue 825 | iret = -1 826 | return 827 | end 828 | c 829 | c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 830 | c 831 | subroutine sphere(ifunc,iflag,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 832 | c----- 833 | c Transform spherical earth to flat earth 834 | c 835 | c Schwab, F. A., and L. Knopoff (1972). Fast surface wave and free 836 | c mode computations, in Methods in Computational Physics, 837 | c Volume 11, 838 | c Seismology: Surface Waves and Earth Oscillations, 839 | c B. A. Bolt (ed), 840 | c Academic Press, New York 841 | c 842 | c Love Wave Equations 44, 45 , 41 pp 112-113 843 | c Rayleigh Wave Equations 102, 108, 109 pp 142, 144 844 | c 845 | c Revised 28 DEC 2007 to use mid-point, assume linear variation in 846 | c slowness instead of using average velocity for the layer 847 | c Use the Biswas (1972:PAGEOPH 96, 61-74, 1972) density mapping 848 | c 849 | c ifunc I*4 1 - Love Wave 850 | c 2 - Rayleigh Wave 851 | c iflag I*4 0 - Initialize 852 | c 1 - Make model for Love or Rayleigh Wave 853 | c----- 854 | parameter(NL=200,NP=60) 855 | real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) 856 | integer mmax,llw 857 | c common/modl/ d,a,b,rho,rtp,dtp,btp 858 | c common/para/ mmax,llw,twopi 859 | double precision z0,z1,r0,r1,dr,ar,tmp,twopi 860 | save dhalf 861 | !$omp threadprivate (dhalf) 862 | ar=6370.0d0 863 | dr=0.0d0 864 | r0=ar 865 | d(mmax)=1.0 866 | if(iflag.eq.0) then 867 | do 5 i=1,mmax 868 | dtp(i)=d(i) 869 | rtp(i)=rho(i) 870 | 5 continue 871 | do 10 i=1,mmax 872 | dr=dr+dble(d(i)) 873 | r1=ar-dr 874 | z0=ar*dlog(ar/r0) 875 | z1=ar*dlog(ar/r1) 876 | d(i)=z1-z0 877 | c----- 878 | c use layer midpoint 879 | c----- 880 | TMP=(ar+ar)/(r0+r1) 881 | a(i)=a(i)*tmp 882 | b(i)=b(i)*tmp 883 | btp(i)=tmp 884 | r0=r1 885 | 10 continue 886 | dhalf = d(mmax) 887 | else 888 | d(mmax) = dhalf 889 | do 30 i=1,mmax 890 | if(ifunc.eq.1)then 891 | rho(i)=rtp(i)*btp(i)**(-5) 892 | else if(ifunc.eq.2)then 893 | rho(i)=rtp(i)*btp(i)**(-2.275) 894 | endif 895 | 30 continue 896 | endif 897 | d(mmax)=0.0 898 | return 899 | end 900 | c 901 | c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 902 | c 903 | subroutine nevill(t,c1,c2,del1,del2,ifunc,cc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 904 | c----- 905 | c hybrid method for refining root once it has been bracketted 906 | c between c1 and c2. interval halving is used where other schemes 907 | c would be inefficient. once suitable region is found neville s 908 | c iteration method is used to find root. 909 | c the procedure alternates between the interval halving and neville 910 | c techniques using whichever is most efficient 911 | c----- 912 | c the control integer nev means the following: 913 | c 914 | c nev = 0 force interval halving 915 | c nev = 1 permit neville iteration if conditions are proper 916 | c nev = 2 neville iteration is being used 917 | c----- 918 | parameter (NL=200,NP=60) 919 | implicit double precision (a-h,o-z) 920 | real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) 921 | dimension x(20),y(20) 922 | integer llw,mmax 923 | c common/modl/ d,a,b,rho,rtp,dtp,btp 924 | c common/para/ mmax,llw,twopi 925 | c----- 926 | c initial guess 927 | c----- 928 | omega = twopi/t 929 | call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, 930 | & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 931 | nev = 1 932 | nctrl=1 933 | 100 continue 934 | nctrl=nctrl+1 935 | if(nctrl.ge.100) go to 1000 936 | c----- 937 | c make sure new estimate is inside the previous values. If not 938 | c perform interval halving 939 | c----- 940 | if(c3 .lt. dmin1(c1,c2) .or. c3. gt.dmax1(c1,c2))then 941 | nev = 0 942 | call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, 943 | & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 944 | endif 945 | s13 = del1 - del3 946 | s32 = del3 - del2 947 | c----- 948 | c define new bounds according to the sign of the period equation 949 | c----- 950 | if(dsign(1.d+00,del3)*dsign(1.d+00,del1) .lt.0.0d+00)then 951 | c2 = c3 952 | del2 = del3 953 | else 954 | c1 = c3 955 | del1 = del3 956 | endif 957 | c----- 958 | c check for convergence. A relative error criteria is used 959 | c----- 960 | if(dabs(c1-c2).le.1.d-6*c1) go to 1000 961 | c----- 962 | c if the slopes are not the same between c1, c3 and c3 963 | c do not use neville iteration 964 | c----- 965 | if(dsign (1.0d+00,s13).ne.dsign (1.0d+00,s32)) nev = 0 966 | c----- 967 | c if the period equation differs by more than a factor of 10 968 | c use interval halving to avoid poor behavior of polynomial fit 969 | c----- 970 | ss1=dabs(del1) 971 | s1=0.01*ss1 972 | ss2=dabs(del2) 973 | s2=0.01*ss2 974 | if(s1.gt.ss2.or.s2.gt.ss1 .or. nev.eq.0) then 975 | call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, 976 | & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 977 | nev = 1 978 | m = 1 979 | else 980 | if(nev.eq.2)then 981 | x(m+1) = c3 982 | y(m+1) = del3 983 | else 984 | x(1) = c1 985 | y(1) = del1 986 | x(2) = c2 987 | y(2) = del2 988 | m = 1 989 | endif 990 | c----- 991 | c perform Neville iteration. Note instead of generating y(x) 992 | c we interchange the x and y of formula to solve for x(y) when 993 | c y = 0 994 | c----- 995 | do 900 kk = 1,m 996 | j = m-kk+1 997 | denom = y(m+1) - y(j) 998 | if(dabs(denom).lt.1.0d-10*abs(y(m+1)))goto 950 999 | x(j)=(-y(j)*x(j+1)+y(m+1)*x(j))/denom 1000 | 900 continue 1001 | c3 = x(1) 1002 | wvno = omega/c3 1003 | del3 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 1004 | c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1005 | nev = 2 1006 | m = m + 1 1007 | if(m.gt.10)m = 10 1008 | goto 951 1009 | 950 continue 1010 | call half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, 1011 | & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1012 | nev = 1 1013 | m = 1 1014 | 951 continue 1015 | endif 1016 | goto 100 1017 | 1000 continue 1018 | cc = c3 1019 | return 1020 | end 1021 | 1022 | subroutine half(c1,c2,c3,del3,omega,ifunc,d,a,b,rho,rtp,dtp,btp, 1023 | & mmax,llw,twopi,a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1024 | implicit double precision (a-h,o-z) 1025 | parameter(NL=200) 1026 | real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) 1027 | c3 = 0.5*(c1 + c2) 1028 | wvno=omega/c3 1029 | del3 = dltar(wvno,omega,ifunc,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 1030 | c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1031 | return 1032 | end 1033 | c 1034 | c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1035 | c 1036 | function dltar(wvno,omega,kk,d,a,b,rho,rtp,dtp,btp,mmax,llw,twop) 1037 | c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1038 | c control the way to P-SV or SH. 1039 | c 1040 | implicit double precision (a-h,o-z) 1041 | parameter(NL=200) 1042 | real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) 1043 | c 1044 | if(kk.eq.1)then 1045 | c love wave period equation 1046 | dltar = dltar1(wvno,omega,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 1047 | elseif(kk.eq.2)then 1048 | c rayleigh wave period equation 1049 | dltar = dltar4(wvno,omega,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 1050 | c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1051 | endif 1052 | end 1053 | c 1054 | c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1055 | c 1056 | function dltar1(wvno,omega,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 1057 | c find SH dispersion values. 1058 | c 1059 | parameter (NL=200,NP=60) 1060 | implicit double precision (a-h,o-z) 1061 | real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) 1062 | integer llw,mmax 1063 | c common/modl/ d,a,b,rho,rtp,dtp,btp 1064 | c common/para/ mmax,llw,twopi 1065 | c 1066 | c Haskell-Thompson love wave formulation from halfspace 1067 | c to surface. 1068 | c 1069 | beta1=dble(b(mmax)) 1070 | rho1=dble(rho(mmax)) 1071 | xkb=omega/beta1 1072 | wvnop=wvno+xkb 1073 | wvnom=dabs(wvno-xkb) 1074 | rb=dsqrt(wvnop*wvnom) 1075 | e1=rho1*rb 1076 | e2=1.d+00/(beta1*beta1) 1077 | mmm1 = mmax - 1 1078 | do 600 m=mmm1,llw,-1 1079 | beta1=dble(b(m)) 1080 | rho1=dble(rho(m)) 1081 | xmu=rho1*beta1*beta1 1082 | xkb=omega/beta1 1083 | wvnop=wvno+xkb 1084 | wvnom=dabs(wvno-xkb) 1085 | rb=dsqrt(wvnop*wvnom) 1086 | q = dble(d(m))*rb 1087 | if(wvno.lt.xkb)then 1088 | sinq = dsin(q) 1089 | y = sinq/rb 1090 | z = -rb*sinq 1091 | cosq = dcos(q) 1092 | elseif(wvno.eq.xkb)then 1093 | cosq=1.0d+00 1094 | y=dble(d(m)) 1095 | z=0.0d+00 1096 | else 1097 | fac = 0.0d+00 1098 | if(q.lt.16)fac = dexp(-2.0d+0*q) 1099 | cosq = ( 1.0d+00 + fac ) * 0.5d+00 1100 | sinq = ( 1.0d+00 - fac ) * 0.5d+00 1101 | y = sinq/rb 1102 | z = rb*sinq 1103 | endif 1104 | e10=e1*cosq+e2*xmu*z 1105 | e20=e1*y/xmu+e2*cosq 1106 | xnor=dabs(e10) 1107 | ynor=dabs(e20) 1108 | if(ynor.gt.xnor) xnor=ynor 1109 | if(xnor.lt.1.d-40) xnor=1.0d+00 1110 | e1=e10/xnor 1111 | e2=e20/xnor 1112 | 600 continue 1113 | dltar1=e1 1114 | return 1115 | end 1116 | c 1117 | c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1118 | c 1119 | function dltar4(wvno,omga,d,a,b,rho,rtp,dtp,btp,mmax,llw,twopi) 1120 | c & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1121 | c find P-SV dispersion values. 1122 | c 1123 | parameter (NL=200,NP=60) 1124 | implicit double precision (a-h,o-z) 1125 | dimension e(5),ee(5),ca(5,5) 1126 | real*4 d(NL),a(NL),b(NL),rho(NL),rtp(NL),dtp(NL),btp(NL) 1127 | c common/modl/ d,a,b,rho,rtp,dtp,btp 1128 | c common/para/ mmax,llw,twopi 1129 | c common/ovrflw/ a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz 1130 | c 1131 | omega=omga 1132 | if(omega.lt.1.0d-4) omega=1.0d-4 1133 | wvno2=wvno*wvno 1134 | xka=omega/dble(a(mmax)) 1135 | xkb=omega/dble(b(mmax)) 1136 | wvnop=wvno+xka 1137 | wvnom=dabs(wvno-xka) 1138 | ra=dsqrt(wvnop*wvnom) 1139 | wvnop=wvno+xkb 1140 | wvnom=dabs(wvno-xkb) 1141 | rb=dsqrt(wvnop*wvnom) 1142 | t = dble(b(mmax))/omega 1143 | c----- 1144 | c E matrix for the bottom half-space. 1145 | c----- 1146 | gammk = 2.d+00*t*t 1147 | gam = gammk*wvno2 1148 | gamm1 = gam - 1.d+00 1149 | rho1=dble(rho(mmax)) 1150 | e(1)=rho1*rho1*(gamm1*gamm1-gam*gammk*ra*rb) 1151 | e(2)=-rho1*ra 1152 | e(3)=rho1*(gamm1-gammk*ra*rb) 1153 | e(4)=rho1*rb 1154 | e(5)=wvno2-ra*rb 1155 | c----- 1156 | c matrix multiplication from bottom layer upward 1157 | c----- 1158 | mmm1 = mmax-1 1159 | do 500 m = mmm1,llw,-1 1160 | xka = omega/dble(a(m)) 1161 | xkb = omega/dble(b(m)) 1162 | t = dble(b(m))/omega 1163 | gammk = 2.d+00*t*t 1164 | gam = gammk*wvno2 1165 | wvnop=wvno+xka 1166 | wvnom=dabs(wvno-xka) 1167 | ra=dsqrt(wvnop*wvnom) 1168 | wvnop=wvno+xkb 1169 | wvnom=dabs(wvno-xkb) 1170 | rb=dsqrt(wvnop*wvnom) 1171 | dpth=dble(d(m)) 1172 | rho1=dble(rho(m)) 1173 | p=ra*dpth 1174 | q=rb*dpth 1175 | beta=dble(b(m)) 1176 | c----- 1177 | c evaluate cosP, cosQ,.... in var. 1178 | c evaluate Dunkin's matrix in dnka. 1179 | c----- 1180 | call var(p,q,ra,rb,wvno,xka,xkb,dpth,w,cosp,exa, 1181 | & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1182 | call dnka(ca,wvno2,gam,gammk,rho1, 1183 | & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1184 | do 200 i=1,5 1185 | cr=0.0d+00 1186 | do 100 j=1,5 1187 | cr=cr+e(j)*ca(j,i) 1188 | 100 continue 1189 | ee(i)=cr 1190 | 200 continue 1191 | call normc(ee,exa) 1192 | do 300 i = 1,5 1193 | e(i)=ee(i) 1194 | 300 continue 1195 | 500 continue 1196 | if(llw.ne.1) then 1197 | c----- 1198 | c include water layer. 1199 | c----- 1200 | xka = omega/dble(a(1)) 1201 | wvnop=wvno+xka 1202 | wvnom=dabs(wvno-xka) 1203 | ra=dsqrt(wvnop*wvnom) 1204 | dpth=dble(d(1)) 1205 | rho1=dble(rho(1)) 1206 | p = ra*dpth 1207 | beta = dble(b(1)) 1208 | znul = 1.0d-05 1209 | call var(p,znul,ra,znul,wvno,xka,znul,dpth,w,cosp,exa, 1210 | & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1211 | w0=-rho1*w 1212 | dltar4 = cosp*e(1) + w0*e(2) 1213 | else 1214 | dltar4 = e(1) 1215 | endif 1216 | return 1217 | end 1218 | c 1219 | c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1220 | subroutine var(p,q,ra,rb,wvno,xka,xkb,dpth,w,cosp,exa,a0,cpcq, 1221 | & cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1222 | c----- 1223 | c find variables cosP, cosQ, sinP, sinQ, etc. 1224 | c as well as cross products required for compound matrix 1225 | c----- 1226 | c To handle the hyperbolic functions correctly for large 1227 | c arguments, we use an extended precision procedure, 1228 | c keeping in mind that the maximum precision in double 1229 | c precision is on the order of 16 decimal places. 1230 | c 1231 | c So cosp = 0.5 ( exp(+p) + exp(-p)) 1232 | c = exp(p) * 0.5 * ( 1.0 + exp(-2p) ) 1233 | c becomes 1234 | c cosp = 0.5 * (1.0 + exp(-2p) ) with an exponent p 1235 | c In performing matrix multiplication, we multiply the modified 1236 | c cosp terms and add the exponents. At the last step 1237 | c when it is necessary to obtain a true amplitude, 1238 | c we then form exp(p). For normalized amplitudes at any depth, 1239 | c we carry an exponent for the numerator and the denominator, and 1240 | c scale the resulting ratio by exp(NUMexp - DENexp) 1241 | c 1242 | c The propagator matrices have three basic terms 1243 | c 1244 | c HSKA cosp cosq 1245 | c DUNKIN cosp*cosq 1.0 1246 | c 1247 | c When the extended floating point is used, we use the 1248 | c largest exponent for each, which is the following: 1249 | c 1250 | c Let pex = p exponent > 0 for evanescent waves = 0 otherwise 1251 | c Let sex = s exponent > 0 for evanescent waves = 0 otherwise 1252 | c Let exa = pex + sex 1253 | c 1254 | c Then the modified matrix elements are as follow: 1255 | c 1256 | c Haskell: cosp -> 0.5 ( 1 + exp(-2p) ) exponent = pex 1257 | c cosq -> 0.5 ( 1 + exp(-2q) ) * exp(q-p) 1258 | c exponent = pex 1259 | c (this is because we are normalizing all elements in the 1260 | c Haskell matrix ) 1261 | c Compound: 1262 | c cosp * cosq -> normalized cosp * cosq exponent = pex + qex 1263 | c 1.0 -> exp(-exa) 1264 | c----- 1265 | implicit double precision (a-h,o-z) 1266 | c common/ovrflw/ a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz 1267 | exa=0.0d+00 1268 | a0=1.0d+00 1269 | c----- 1270 | c examine P-wave eigenfunctions 1271 | c checking whether c> vp c=vp or c < vp 1272 | c----- 1273 | pex = 0.0d+00 1274 | sex = 0.0d+00 1275 | if(wvno.lt.xka)then 1276 | sinp = dsin(p) 1277 | w=sinp/ra 1278 | x=-ra*sinp 1279 | cosp=dcos(p) 1280 | elseif(wvno.eq.xka)then 1281 | cosp = 1.0d+00 1282 | w = dpth 1283 | x = 0.0d+00 1284 | elseif(wvno.gt.xka)then 1285 | pex = p 1286 | fac = 0.0d+00 1287 | if(p.lt.16)fac = dexp(-2.0d+00*p) 1288 | cosp = ( 1.0d+00 + fac) * 0.5d+00 1289 | sinp = ( 1.0d+00 - fac) * 0.5d+00 1290 | w=sinp/ra 1291 | x=ra*sinp 1292 | endif 1293 | c----- 1294 | c examine S-wave eigenfunctions 1295 | c checking whether c > vs, c = vs, c < vs 1296 | c----- 1297 | if(wvno.lt.xkb)then 1298 | sinq=dsin(q) 1299 | y=sinq/rb 1300 | z=-rb*sinq 1301 | cosq=dcos(q) 1302 | elseif(wvno.eq.xkb)then 1303 | cosq=1.0d+00 1304 | y=dpth 1305 | z=0.0d+00 1306 | elseif(wvno.gt.xkb)then 1307 | sex = q 1308 | fac = 0.0d+00 1309 | if(q.lt.16)fac = dexp(-2.0d+0*q) 1310 | cosq = ( 1.0d+00 + fac ) * 0.5d+00 1311 | sinq = ( 1.0d+00 - fac ) * 0.5d+00 1312 | y = sinq/rb 1313 | z = rb*sinq 1314 | endif 1315 | c----- 1316 | c form eigenfunction products for use with compound matrices 1317 | c----- 1318 | exa = pex + sex 1319 | a0=0.0d+00 1320 | if(exa.lt.60.0d+00) a0=dexp(-exa) 1321 | cpcq=cosp*cosq 1322 | cpy=cosp*y 1323 | cpz=cosp*z 1324 | cqw=cosq*w 1325 | cqx=cosq*x 1326 | xy=x*y 1327 | xz=x*z 1328 | wy=w*y 1329 | wz=w*z 1330 | qmp = sex - pex 1331 | fac = 0.0d+00 1332 | if(qmp.gt.-40.0d+00)fac = dexp(qmp) 1333 | cosq = cosq*fac 1334 | y=fac*y 1335 | z=fac*z 1336 | return 1337 | end 1338 | c 1339 | c 1340 | c 1341 | subroutine normc(ee,ex) 1342 | c This routine is an important step to control over- or 1343 | c underflow. 1344 | c The Haskell or Dunkin vectors are normalized before 1345 | c the layer matrix stacking. 1346 | c Note that some precision will be lost during normalization. 1347 | c 1348 | implicit double precision (a-h,o-z) 1349 | dimension ee(5) 1350 | ex = 0.0d+00 1351 | t1 = 0.0d+00 1352 | do 10 i = 1,5 1353 | if(dabs(ee(i)).gt.t1) t1 = dabs(ee(i)) 1354 | 10 continue 1355 | if(t1.lt.1.d-40) t1=1.d+00 1356 | do 20 i =1,5 1357 | t2=ee(i) 1358 | t2=t2/t1 1359 | ee(i)=t2 1360 | 20 continue 1361 | c----- 1362 | c store the normalization factor in exponential form. 1363 | c----- 1364 | ex=dlog(t1) 1365 | return 1366 | end 1367 | c 1368 | c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1369 | c 1370 | subroutine dnka(ca,wvno2,gam,gammk,rho, 1371 | & a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz) 1372 | c Dunkin's matrix. 1373 | c 1374 | implicit double precision (a-h,o-z) 1375 | dimension ca(5,5) 1376 | c common/ ovrflw / a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz 1377 | data one,two/1.d+00,2.d+00/ 1378 | gamm1 = gam-one 1379 | twgm1=gam+gamm1 1380 | gmgmk=gam*gammk 1381 | gmgm1=gam*gamm1 1382 | gm1sq=gamm1*gamm1 1383 | rho2=rho*rho 1384 | a0pq=a0-cpcq 1385 | ca(1,1)=cpcq-two*gmgm1*a0pq-gmgmk*xz-wvno2*gm1sq*wy 1386 | ca(1,2)=(wvno2*cpy-cqx)/rho 1387 | ca(1,3)=-(twgm1*a0pq+gammk*xz+wvno2*gamm1*wy)/rho 1388 | ca(1,4)=(cpz-wvno2*cqw)/rho 1389 | ca(1,5)=-(two*wvno2*a0pq+xz+wvno2*wvno2*wy)/rho2 1390 | ca(2,1)=(gmgmk*cpz-gm1sq*cqw)*rho 1391 | ca(2,2)=cpcq 1392 | ca(2,3)=gammk*cpz-gamm1*cqw 1393 | ca(2,4)=-wz 1394 | ca(2,5)=ca(1,4) 1395 | ca(4,1)=(gm1sq*cpy-gmgmk*cqx)*rho 1396 | ca(4,2)=-xy 1397 | ca(4,3)=gamm1*cpy-gammk*cqx 1398 | ca(4,4)=ca(2,2) 1399 | ca(4,5)=ca(1,2) 1400 | ca(5,1)=-(two*gmgmk*gm1sq*a0pq+gmgmk*gmgmk*xz+ 1401 | * gm1sq*gm1sq*wy)*rho2 1402 | ca(5,2)=ca(4,1) 1403 | ca(5,3)=-(gammk*gamm1*twgm1*a0pq+gam*gammk*gammk*xz+ 1404 | * gamm1*gm1sq*wy)*rho 1405 | ca(5,4)=ca(2,1) 1406 | ca(5,5)=ca(1,1) 1407 | t=-two*wvno2 1408 | ca(3,1)=t*ca(5,3) 1409 | ca(3,2)=t*ca(4,3) 1410 | ca(3,3)=a0+two*(cpcq-ca(1,1)) 1411 | ca(3,4)=t*ca(2,3) 1412 | ca(3,5)=t*ca(1,3) 1413 | return 1414 | end 1415 | -------------------------------------------------------------------------------- /pydisp/surfmodes/surfmodes.f90: -------------------------------------------------------------------------------- 1 | ! Subroutine to calculate surface modes for layered model which can 2 | ! contain fluid layers above the solid layers (e.g. sea floor). 3 | ! 4 | 5 | module m_surfmodes 6 | 7 | use m_GRT, only : T_GRT, init_grt, dp 8 | use omp_lib 9 | 10 | implicit none 11 | 12 | private 13 | 14 | public :: surfmodes, surfmmodes 15 | public :: T_MODES_PARA 16 | 17 | ! static values 18 | real(kind=dp), parameter :: eps = 1E-6 19 | real(kind=dp), parameter :: pi = 3.1415926 20 | integer, parameter :: nmodes = 100 21 | integer, parameter :: nfreqs = 100 22 | ! parameters for surface wave modes calculation 23 | type T_MODES_PARA 24 | integer :: modetype, nmodes ! 1 for rayleigh wave, 0 for love wave 25 | integer :: phaseGroup ! 0 for phase velocity, 1 for group velocity 26 | real(kind=dp) :: tolmin, tolmax 27 | real(kind=dp) :: Smin_min, Smin_max 28 | real(kind=dp) :: dc, dcm 29 | real(kind=dp) :: dc1, dc2 30 | endtype 31 | 32 | ! debug 33 | real(kind=dp) :: t1, t2 34 | !$omp threadprivate(t1,t2) 35 | 36 | 37 | contains 38 | 39 | subroutine surfmodes(thick,vp,vs,rho,freqs,paras,phase,group,ierr) 40 | implicit none 41 | real(kind=dp), dimension(:), intent(in) :: thick 42 | real(kind=dp), dimension(:), intent(in) :: vp 43 | real(kind=dp), dimension(:), intent(in) :: vs 44 | real(kind=dp), dimension(:), intent(in) :: rho 45 | real(kind=dp), dimension(:), intent(in) :: freqs 46 | type(T_MODES_PARA), intent(in) :: paras 47 | real(kind=dp), dimension(:), intent(out) :: phase 48 | real(kind=dp), dimension(:), intent(out) :: group 49 | integer, intent(out) :: ierr 50 | 51 | type(T_GRT) GRT 52 | integer nlayers 53 | 54 | nlayers = size(thick) 55 | 56 | ! prepare for the GRT method 57 | call init_grt(GRT, nlayers) 58 | GRT%d = thick 59 | GRT%vp = vp 60 | GRT%vs = vs 61 | GRT%rho = rho 62 | !t1=omp_get_wtime() 63 | call setup_grt(GRT,paras) 64 | !t2=omp_get_wtime() 65 | !write(*,*) 'Preparing time: ', t2-t1 66 | !open(22,file='1dmodel_tmp.dat',access='append') 67 | !write(22,*) nlayers 68 | !do i = 1, nlayers 69 | ! write(22,*) thick(i), vp(i), vs(i), rho(i) 70 | !enddo 71 | !close(22) 72 | 73 | !t1=omp_get_wtime() 74 | ierr = 0 75 | select case(paras%modetype) 76 | 77 | case(1) 78 | ! rayleigh waves 79 | if(grt%nlvls1==0)then 80 | !write(*,*) 'No low velocity layer, using surfdisp96:' 81 | call surfdisp96(real(thick,4),real(vp,4),real(vs,4),real(rho,4),& 82 | size(thick),0,2,1,paras%phaseGroup,size(freqs),dble(1/freqs),& 83 | paras%dc,phase,group,ierr) 84 | else 85 | !write(*,*) 'low velocity layer, using generalized R/T:' 86 | call RayleighModes(GRT, freqs, paras,& 87 | phase,group,ierr) 88 | endif 89 | case(0) 90 | ! love waves 91 | if(grt%nlvls1==0)then 92 | !write(*,*) 'No low velocity layer, using surfdisp96:' 93 | call surfdisp96(real(thick,4),real(vp,4),real(vs,4),real(rho,4),& 94 | size(thick),0,1,1,paras%phaseGroup,size(freqs),dble(1/freqs),& 95 | paras%dc,phase,group,ierr) 96 | else 97 | !write(*,*) 'low velocity layer, using generalized R/T:' 98 | call& 99 | LoveModes(GRT,freqs,paras,phase,group,ierr) 100 | endif 101 | case default 102 | ! 103 | end select 104 | !t2=omp_get_wtime() 105 | !write(*,*) 'dispersion curve calculation: ', t2-t1 106 | 107 | 108 | end subroutine 109 | 110 | subroutine surfmmodes(thick,vp,vs,rho,freqs,paras,phase,group,ierr) 111 | implicit none 112 | real(kind=dp), dimension(:), intent(in) :: thick 113 | real(kind=dp), dimension(:), intent(in) :: vp 114 | real(kind=dp), dimension(:), intent(in) :: vs 115 | real(kind=dp), dimension(:), intent(in) :: rho 116 | real(kind=dp), dimension(:), intent(in) :: freqs 117 | type(T_MODES_PARA), intent(in) :: paras 118 | real(kind=dp), dimension(:), intent(out) :: phase 119 | real(kind=dp), dimension(:), intent(out) :: group 120 | integer, intent(out) :: ierr 121 | 122 | type(T_GRT) GRT 123 | integer nlayers, nfreqs 124 | real(kind=dp), dimension(size(freqs),paras%nmodes) :: phase2d, group2d 125 | 126 | nlayers = size(thick) 127 | nfreqs = size(freqs) 128 | 129 | ! prepare for the GRT method 130 | call init_grt(GRT, nlayers) 131 | GRT%d = thick 132 | GRT%vp = vp 133 | GRT%vs = vs 134 | GRT%rho = rho 135 | !t1=omp_get_wtime() 136 | call setup_grt(GRT,paras) 137 | !t2=omp_get_wtime() 138 | !write(*,*) 'Preparing time: ', t2-t1 139 | !open(22,file='1dmodel_tmp.dat',access='append') 140 | !write(22,*) nlayers 141 | !do i = 1, nlayers 142 | ! write(22,*) thick(i), vp(i), vs(i), rho(i) 143 | !enddo 144 | !close(22) 145 | 146 | !t1=omp_get_wtime() 147 | ierr = 0 148 | select case(paras%modetype) 149 | 150 | case(1) 151 | ! rayleigh waves 152 | if(grt%nlvls1==0)then 153 | !write(*,*) 'No low velocity layer, using surfdisp96:' 154 | call surfdisp_mmodes(real(thick,4),real(vp,4),real(vs,4),real(rho,4),& 155 | size(thick),0,2,paras%nmodes,paras%phaseGroup,size(freqs),dble(1/freqs),& 156 | paras%dc,phase2d,group2d,ierr) 157 | else 158 | write(*,*) 'low velocity layer, not supported yet:' 159 | !call RayleighModes(GRT, freqs, paras,& 160 | !phase,group,ierr) 161 | endif 162 | case(0) 163 | ! love waves 164 | if(grt%nlvls1==0)then 165 | !write(*,*) 'No low velocity layer, using surfdisp96:' 166 | call surfdisp_mmodes(real(thick,4),real(vp,4),real(vs,4),real(rho,4),& 167 | size(thick),0,1,paras%nmodes,paras%phaseGroup,size(freqs),dble(1/freqs),& 168 | paras%dc,phase2d,group2d,ierr) 169 | else 170 | write(*,*) 'low velocity layer, not supported yet:' 171 | !call& 172 | ! LoveModes(GRT,freqs,paras,phase,group,ierr) 173 | endif 174 | case default 175 | ! 176 | end select 177 | !t2=omp_get_wtime() 178 | !write(*,*) 'dispersion curve calculation: ', t2-t1 179 | phase = reshape(phase2d,(/nfreqs*paras%nmodes/)) 180 | group = reshape(group2d,(/nfreqs*paras%nmodes/)) 181 | 182 | 183 | end subroutine 184 | 185 | subroutine RayleighModes(GRT,freqs,paras,& 186 | phase,group,ierr,allroots) 187 | implicit none 188 | type(T_GRT), intent(inout) :: GRT 189 | real(kind=dp), dimension(:), intent(in) :: freqs 190 | type(T_MODES_PARA), intent(in) :: paras 191 | real(kind=dp), dimension(:), intent(out) :: phase 192 | real(kind=dp), dimension(:), intent(out) :: group 193 | integer, intent(out) :: ierr 194 | real(kind=dp), dimension(:,:), intent(out), optional :: allroots 195 | 196 | real(kind=dp), parameter :: dh = 0.005 197 | real(kind=dp) freq0, cp0 198 | real(kind=dp), dimension(nmodes,nfreqs) :: roots, roots0 199 | real(kind=dp) c0 200 | integer allmodes, nfreqs 201 | integer nroots, ierr1 202 | integer i 203 | 204 | allmodes = 0 205 | if(present(allroots))then 206 | allmodes = 1 207 | endif 208 | 209 | ierr = 0 210 | roots = 0 211 | c0 = 0 212 | nfreqs = size(freqs) 213 | do i = 1, size(freqs) 214 | grt%w = freqs(i)*2*pi 215 | grt%tol = paras%tolmin + (nfreqs+1-i)*(paras%tolmax-paras%tolmin)/nfreqs 216 | grt%smin = paras%smin_min + (i-1)*(paras%smin_max-paras%smin_min)/nfreqs 217 | grt%index_a = i 218 | call SearchRayleigh(GRT, c0, & 219 | roots(:,i),nroots, allmodes,ierr1) 220 | if(ierr1 == 1)then 221 | ierr = 1 222 | exit 223 | endif 224 | phase(i) = roots(1,i) 225 | c0 = phase(i) 226 | grt%ncr1 = nroots 227 | grt%root1 = roots(:,i) 228 | if(paras%phaseGroup==1)then 229 | freq0 = freqs(i) + dh 230 | grt%w = freq0*2*pi 231 | call SearchRayleigh(GRT,c0,& 232 | roots0(:,i),nroots, allmodes,ierr) 233 | if(ierr==1) exit 234 | cp0 = roots0(1,i) 235 | call CalGroup(phase(i),cp0,freqs(i),dh,group(i)) 236 | endif 237 | enddo 238 | 239 | if(present(allroots))then 240 | allroots = roots(1:size(allroots,1),1:size(allroots,2)) 241 | endif 242 | 243 | end subroutine 244 | 245 | subroutine LoveModes(GRT,freqs,paras,& 246 | phase,group,ierr,allroots) 247 | implicit none 248 | type(T_GRT), intent(inout) :: GRT 249 | real(kind=dp), dimension(:), intent(in) :: freqs 250 | type(T_MODES_PARA), intent(in) :: paras 251 | real(kind=dp), dimension(:), intent(out) :: phase 252 | real(kind=dp), dimension(:), intent(out) :: group 253 | integer, intent(out) :: ierr 254 | real(kind=dp), dimension(:,:), intent(out), optional :: allroots 255 | 256 | real(kind=dp), parameter :: dh = 0.005 257 | real(kind=dp) freq0, cp0 258 | real(kind=dp), dimension(nmodes,nfreqs) :: roots, roots0 259 | real(kind=dp) c0 260 | integer allmodes, nfreqs 261 | integer nroots, ierr1 262 | integer i 263 | 264 | allmodes = 0 265 | if(present(allroots))then 266 | allmodes = 1 267 | endif 268 | 269 | nfreqs = size(freqs) 270 | ierr = 0 271 | roots = 0 272 | c0 = 0 273 | do i = 1, size(freqs) 274 | grt%w = freqs(i)*2*pi 275 | grt%tol = paras%tolmin + (nfreqs+1-i)*(paras%tolmax-paras%tolmin)/nfreqs 276 | grt%smin = paras%smin_min + (i-1)*(paras%smin_max-paras%smin_min)/nfreqs 277 | grt%index_a = i 278 | call SearchLove(GRT,c0,& 279 | roots(:,i),nroots,allmodes,ierr1) 280 | if(ierr1 == 1)then 281 | ierr = 1 282 | exit 283 | endif 284 | phase(i) = roots(1,i) 285 | c0 = phase(i) 286 | grt%ncr1 = nroots 287 | grt%root1 = roots(:,i) 288 | if(paras%phaseGroup==1)then 289 | freq0 = freqs(i) + dh 290 | grt%w = freq0*2*pi 291 | call SearchLove(GRT,c0,& 292 | roots0(:,i),nroots,allmodes,ierr) 293 | if(ierr==1) exit 294 | cp0 = roots0(1,i) 295 | call CalGroup(phase(i),cp0,freqs(i),dh,group(i)) 296 | endif 297 | enddo 298 | 299 | if(present(allroots))then 300 | allroots = roots(1:size(allroots,1),1:size(allroots,2)) 301 | endif 302 | 303 | end subroutine 304 | 305 | subroutine CalGroup(c1,c2,freq,dh,group) 306 | implicit none 307 | real(kind=dp), intent(in) :: c1, c2 308 | real(kind=dp), intent(in) :: freq 309 | real(kind=dp), intent(in) :: dh 310 | real(kind=dp), intent(out) :: group 311 | 312 | group = (freq+dh)/c2 - freq/c1 313 | if(group>0)then 314 | group = dh/group 315 | else 316 | group = 0 317 | endif 318 | endsubroutine 319 | 320 | subroutine setup_grt(GRT, para) 321 | implicit none 322 | type(T_GRT), intent(inout) :: GRT 323 | type(T_MODES_PARA), intent(in) :: para 324 | 325 | integer idx, i, j, k 326 | integer nlayers 327 | real(kind=dp) mu0, mu 328 | 329 | GRT%dc = para%dc 330 | GRT%dc2 = para%dc2 331 | GRT%dcm = para%dcm 332 | GRT%ifs = 0 333 | 334 | idx = 0 335 | nlayers = GRT%nlayers 336 | do i = 1, nlayers 337 | if(abs(GRT%vs(i))>eps) then 338 | idx = idx + 1 339 | GRT%v(idx) = GRT%vs(i) 340 | if(i==nlayers) GRT%ilastvs = idx 341 | else 342 | if(i>1)then 343 | write(*,*) 'Error: currently only allow first layer to be water' 344 | stop 345 | endif 346 | GRT%ifs = GRT%ifs + 1 347 | endif 348 | idx = idx + 1 349 | GRT%v(idx) = GRT%vp(i) 350 | enddo 351 | ! sort the wave velocity 352 | call sort(GRT%v,idx,1) 353 | 354 | ! prepare mu 355 | idx = 0 356 | mu0 = 0 357 | do i = 1, nlayers 358 | mu = GRT%rho(i)*GRT%vs(i)**2 359 | if(abs(mu)>eps) then 360 | idx = idx + 1 361 | mu0 = mu0 + mu 362 | endif 363 | GRT%mu(i) = mu 364 | end do 365 | mu0 = mu0/idx 366 | GRT%mu =GRT%mu/mu0 367 | GRT%mu0 = mu0 368 | 369 | GRT%vsy = maxval(GRT%vs) 370 | select case(para%modetype) 371 | case(1) 372 | if(GRT%ifs>0) then 373 | GRT%vs1=GRT%vp(1) 374 | GRT%vss1=GRT%vs(grt%ifs+1) 375 | else 376 | GRT%vs1=GRT%vs(1) 377 | endif 378 | GRT%vsm=GRT%v(1) 379 | case(0) 380 | GRT%vs1=GRT%vs(1+GRT%ifs) 381 | GRT%vsm=minval(GRT%vs(GRT%ifs+1:nlayers))! the lowest S wave velocity 382 | end select 383 | !vsm=vs1 384 | ! number of lvls in fluid 385 | GRT%no_lvl_fl=0 386 | do i=2,nlayers-1 387 | if(i>grt%ifs .and. grt%vs(i)ifs+1) no_lvl_L=no_lvl_L+1 393 | ! if(vs(i)0.) then 402 | if(grt%vs(i)grt%vp(grt%lvls(j+1))) then 428 | k=grt%lvls(j) 429 | grt%lvls(j)=grt%lvls(j+1) 430 | grt%lvls(j+1)=k 431 | endif 432 | enddo 433 | enddo 434 | !print '(2(a,i2))','nlvl1=',grt%nlvl1,', no_lvl=',grt%no_lvl 435 | !print '(a,(/),1(i4,f7.3,1x,f7.3))', 'LVLs:', & 436 | ! (grt%lvls(i),grt%vs(grt%lvls(i)),grt%vp(grt%lvls(i)),i=1,grt%no_lvl) 437 | !print '(a,f7.3)', 'vs1:',grt%vs1 438 | endif 439 | grt%lvlast=max(grt%ifs+2,grt%lvlast) 440 | 441 | ! lvls has been sorted 442 | do i=1,grt%no_lvl 443 | if(grt%lvls(i)>grt%ifs) then 444 | if(grt%vs(grt%lvls(i))