From ce26fe3dd2341f0c1b15d91f08908e6adb3e3fae Mon Sep 17 00:00:00 2001 From: Michele Esposito Marzino Date: Sun, 10 Sep 2023 11:58:43 +0200 Subject: [PATCH] [NEW] Initial release --- .gitattributes | 1 + .gitignore | 68 + BSA.sln | 55 + COPYING | 674 ++++ COPYING.LESSER | 165 + README.md | 18 + resources/images/BSA_logo.PNG | Bin 0 -> 5339 bytes resources/images/BSA_logo_extended.PNG | Bin 0 -> 7563 bytes src/BSA.vfproj | 52 + src/BsaLib/BSAlib.vfproj | 76 + src/BsaLib/BsaLib.f90 | 556 +++ src/BsaLib/CONSTANTS/CONSTANTS.f90 | 180 + src/BsaLib/IO/Logging.f90 | 152 + src/BsaLib/IO/LoggingImpl.f90 | 488 +++ src/BsaLib/IO/io.f90 | 276 ++ src/BsaLib/bsa/BsaLibImpl.f90 | 2008 ++++++++++ src/BsaLib/bsa/classic/BsaClassicImpl.f90 | 524 +++ src/BsaLib/bsa/data/BsaLibData.f90 | 238 ++ src/BsaLib/bsa/data/BsaLibDataImpl.f90 | 170 + src/BsaLib/bsa/functions/functions.f90 | 198 + src/BsaLib/bsa/functions/functionsImpl.f90 | 3384 +++++++++++++++++ src/BsaLib/bsa/meshing/BsaMesherImpl.f90 | 1771 +++++++++ src/BsaLib/bsa/meshing/point/MPoint.f90 | 354 ++ src/BsaLib/bsa/meshing/policy/MPolicy.f90 | 214 ++ src/BsaLib/bsa/meshing/zones/M2DPolygZone.f90 | 165 + src/BsaLib/bsa/meshing/zones/MRectZone.f90 | 368 ++ .../bsa/meshing/zones/MRectZoneImpl.f90 | 2879 ++++++++++++++ src/BsaLib/bsa/meshing/zones/MTriangZone.f90 | 261 ++ .../bsa/meshing/zones/MTriangZoneImpl.f90 | 2376 ++++++++++++ src/BsaLib/bsa/meshing/zones/MZone.f90 | 259 ++ src/BsaLib/precisions | 11 + src/BsaLib/settings/Settings.f90 | 204 + src/BsaLib/settings/SettingsImpl.f90 | 154 + src/BsaLib/structure/StructureData.f90 | 223 ++ src/BsaLib/structure/StructureImpl.f90 | 466 +++ src/BsaLib/timing/Timer.f90 | 121 + src/BsaLib/utils/utility.f90 | 79 + src/BsaLib/wind/WindPSDImpl.f90 | 327 ++ src/BsaLib/wind/WindSetImpl.f90 | 518 +++ src/BsaLib/wind/WindType.f90 | 417 ++ src/bsa.f90 | 1243 ++++++ 41 files changed, 21693 insertions(+) create mode 100644 .gitattributes create mode 100644 .gitignore create mode 100644 BSA.sln create mode 100644 COPYING create mode 100644 COPYING.LESSER create mode 100644 README.md create mode 100644 resources/images/BSA_logo.PNG create mode 100644 resources/images/BSA_logo_extended.PNG create mode 100644 src/BSA.vfproj create mode 100644 src/BsaLib/BSAlib.vfproj create mode 100644 src/BsaLib/BsaLib.f90 create mode 100644 src/BsaLib/CONSTANTS/CONSTANTS.f90 create mode 100644 src/BsaLib/IO/Logging.f90 create mode 100644 src/BsaLib/IO/LoggingImpl.f90 create mode 100644 src/BsaLib/IO/io.f90 create mode 100644 src/BsaLib/bsa/BsaLibImpl.f90 create mode 100644 src/BsaLib/bsa/classic/BsaClassicImpl.f90 create mode 100644 src/BsaLib/bsa/data/BsaLibData.f90 create mode 100644 src/BsaLib/bsa/data/BsaLibDataImpl.f90 create mode 100644 src/BsaLib/bsa/functions/functions.f90 create mode 100644 src/BsaLib/bsa/functions/functionsImpl.f90 create mode 100644 src/BsaLib/bsa/meshing/BsaMesherImpl.f90 create mode 100644 src/BsaLib/bsa/meshing/point/MPoint.f90 create mode 100644 src/BsaLib/bsa/meshing/policy/MPolicy.f90 create mode 100644 src/BsaLib/bsa/meshing/zones/M2DPolygZone.f90 create mode 100644 src/BsaLib/bsa/meshing/zones/MRectZone.f90 create mode 100644 src/BsaLib/bsa/meshing/zones/MRectZoneImpl.f90 create mode 100644 src/BsaLib/bsa/meshing/zones/MTriangZone.f90 create mode 100644 src/BsaLib/bsa/meshing/zones/MTriangZoneImpl.f90 create mode 100644 src/BsaLib/bsa/meshing/zones/MZone.f90 create mode 100644 src/BsaLib/precisions create mode 100644 src/BsaLib/settings/Settings.f90 create mode 100644 src/BsaLib/settings/SettingsImpl.f90 create mode 100644 src/BsaLib/structure/StructureData.f90 create mode 100644 src/BsaLib/structure/StructureImpl.f90 create mode 100644 src/BsaLib/timing/Timer.f90 create mode 100644 src/BsaLib/utils/utility.f90 create mode 100644 src/BsaLib/wind/WindPSDImpl.f90 create mode 100644 src/BsaLib/wind/WindSetImpl.f90 create mode 100644 src/BsaLib/wind/WindType.f90 create mode 100644 src/bsa.f90 diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..d7357fd --- /dev/null +++ b/.gitattributes @@ -0,0 +1 @@ +*.vfproj merge=ours \ No newline at end of file diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..f06fc4b --- /dev/null +++ b/.gitignore @@ -0,0 +1,68 @@ +# Prerequisites +*.d + +# Compiled Object files +*.slo +*.lo +*.o +*.obj + +# Precompiled Headers +*.gch +*.pch + +# Compiled Dynamic libraries +*.so +*.dylib +*.dll + +# Fortran module files +*.mod +*.smod + +# Compiled Static libraries +*.lai +*.la +*.a +*.lib + +# Executables +*.exe +*.out +*.app + +# after pre-processor +*.i90 + +# custom +**/*_help.txt + +# Visual Studio +**/*.suo +**/*.u2d +**/*.pdb +**/*BuildLog* +**/*.manifest + +# VS hidden (local) folder +.vs/ +.vscode/ + +# CUSTOM +#specific subfolder, keep it as backup +src/x64 +src/x86 +**/*.lnk +**/*.user +**/*.help +**/fort.* +deps/ +lapack/ +build/ +*.exp +**/*.ilk +**/*.idb +**/__pycache__ +compile.bat +plotter/ +build/ \ No newline at end of file diff --git a/BSA.sln b/BSA.sln new file mode 100644 index 0000000..379b067 --- /dev/null +++ b/BSA.sln @@ -0,0 +1,55 @@ + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio Version 16 +VisualStudioVersion = 16.0.32407.337 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "BSA", "src\BSA.vfproj", "{DA0DDA4B-436F-4F32-9664-D89DB5F50096}" + ProjectSection(ProjectDependencies) = postProject + {FA4C5412-70FD-4A98-9A97-758D8F0FE907} = {FA4C5412-70FD-4A98-9A97-758D8F0FE907} + EndProjectSection +EndProject +Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "BSAlib", "src\BsaLib\BSAlib.vfproj", "{FA4C5412-70FD-4A98-9A97-758D8F0FE907}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|x64 = Debug|x64 + Debug|x86 = Debug|x86 + MinSizeRel|x64 = MinSizeRel|x64 + MinSizeRel|x86 = MinSizeRel|x86 + Release|x64 = Release|x64 + Release|x86 = Release|x86 + RelWithDebInfo|x64 = RelWithDebInfo|x64 + RelWithDebInfo|x86 = RelWithDebInfo|x86 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.Debug|x64.ActiveCfg = Debug|x64 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.Debug|x64.Build.0 = Debug|x64 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.Debug|x86.ActiveCfg = Debug|Win32 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.Debug|x86.Build.0 = Debug|Win32 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.MinSizeRel|x64.ActiveCfg = Release|x64 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.MinSizeRel|x86.ActiveCfg = Release|Win32 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.Release|x64.ActiveCfg = Release|x64 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.Release|x64.Build.0 = Release|x64 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.Release|x86.ActiveCfg = Release|Win32 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.Release|x86.Build.0 = Release|Win32 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.RelWithDebInfo|x64.ActiveCfg = Release|x64 + {DA0DDA4B-436F-4F32-9664-D89DB5F50096}.RelWithDebInfo|x86.ActiveCfg = Release|Win32 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.Debug|x64.ActiveCfg = Debug|x64 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.Debug|x64.Build.0 = Debug|x64 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.Debug|x86.ActiveCfg = Debug|Win32 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.MinSizeRel|x64.ActiveCfg = Release|x64 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.MinSizeRel|x86.ActiveCfg = Release|Win32 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.Release|x64.ActiveCfg = Release|x64 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.Release|x64.Build.0 = Release|x64 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.Release|x86.ActiveCfg = Release|Win32 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.Release|x86.Build.0 = Release|Win32 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.RelWithDebInfo|x64.ActiveCfg = Release|x64 + {FA4C5412-70FD-4A98-9A97-758D8F0FE907}.RelWithDebInfo|x86.ActiveCfg = Release|Win32 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection + GlobalSection(ExtensibilityGlobals) = postSolution + SolutionGuid = {44B5D54D-AEDB-4A2B-A1FD-1A1D86279723} + EndGlobalSection +EndGlobal diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..f288702 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/COPYING.LESSER b/COPYING.LESSER new file mode 100644 index 0000000..0a04128 --- /dev/null +++ b/COPYING.LESSER @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/README.md b/README.md new file mode 100644 index 0000000..ea522b6 --- /dev/null +++ b/README.md @@ -0,0 +1,18 @@ + + +# BSA + +BSA library provides a framework for the Bispectral Stochastic Analysis of linear systems, +under non-Gaussian stationary random excitations. + +It is conceived to be a **plug-in** library for any personal/commercial Finite Element software capable +of providing some basic features. + +Its main API is defined in the main library interface module file `.\src\BsaLib.f90`. + +
Update History + +- v0.1.3 (05/09/2023) + - Initial relase + +
\ No newline at end of file diff --git a/resources/images/BSA_logo.PNG b/resources/images/BSA_logo.PNG new file mode 100644 index 0000000000000000000000000000000000000000..4645ce28ce09d28c90080676d2e1ef9d6b29665f GIT binary patch literal 5339 zcmdT|cT`i^x(^+Uz*sO2ppmhSB7wUU5d|Vj6I4(EDS-@49T*{iAV>+|MO21j89@ai zpnwoiLKo@Mh7zSq4Mj>q1cU?eMI6CXyJM*6F{&iW4?40cVwcq#qzP(7 zdX4-V1Og#_!btBd0wIb+AcT}9#lbJ57vfN05b{22cnp!#syGE6L@(-|(nTP0V~{Hj zV&GYdU}Wu$K#luN>q<|p=T->#%QF%{DZ*bA0}YM;;gBR>jKjpCXJ%&7 z{R09Re62`M%tJx^-+uHoHJNC{9lBTfL1r9#f$#M9AAMr5qjFLJH3Z`BHxJLmFu*%O zyMhQ1x6-vNS0V_3Z%g_#VKBs={BIt9c~uE9B!u)ASxgxBDp}z>9lz-JM{deqzrNDF zrI^I`KS>lpSZ*T>AJ9=#oDUUULhi$synY z^C7z~l)8Wp(TrNSIDw|!tPIbtHTlG16&z`0_3mF7UYC$>!4 zaC7sI_OVg6x0Y)!$4*EMwG$EJ2YN|~#3yMz-DSD!gi(bbd^Jh7TZ^OlB5LWj+`M_& zj&}Byb_E3`f`f_s_SWH&>c!~|A({idB$iLcZuS+AU;bGcu2N#BW2$9ar1cguIhDkp zUJ)tC=k+ht8A#%KqHS+_2L+awdG%BeDE4 zQkfspG!7o4Rr{t`4q!<2DzXbxScLcQlhjtMnPHdxrs9`!8nQ7Pw5#%Nkf7jQ*dX`} zCAJsrNVZ<$D?1$!z|u*9Q2eB*}7NI)ox^XGa2({64z-_xuLAzkk`gnXw|` z_B&k~!1Wz#%9k@2*yDVaD_fb+It|=>SxDw76Oy%5Ur$6%%shw~m;~0Y=@FwjiNv3@ zt$Dh%WBz9z+xt>CM9AasG`K@iXs3WIRlZ6wgc18u#r}%xd`a&MdfnkAS|bKtkqNJ$ zTmx{ojb!m(k0q(fXaJ|eA*T!>6s*qm6`g`%pp1y6V(5I7C!1d|-@)XA8rN(jT>9JIUkOEmM+Ekp z8{_{=AilS$sVQc0aSJ)^|11{5S{2TNCHDeT9U;ZsJl zZh7VA>2*S%rm~ZSw9fXqt4PGF4`~w`*FXZ8z|HF0?J%abEnN2h(+(< zrJ7~2t=ri)u>a5Xwya8(5|C1{^_*eZ8I<3z0;sR*TRjrVPrsXnt<=7}huSegB85t*Rs79)j=4?`JV?uxV1A1DnM z-3(?t22}|;W z<6lwfPvOQ?hNnmN&QUTNxs=kSw=`ufp&X!68~9?n@MN$@G8Ablr@E%#+&xw}6+b+6 zU8Hg`0i83-6P{?K>k6Zi_LkGBCMmlZNNjC{1jy2mcW`kMu$s!uT5XH%Z;;0ZI-G-s zWx;H>XYgi7wt;>e$ks9SFL$AIB4yXPD+%#iI1UMm$T7Eo%&DlT?}}$P&N*HR?8Iw# zp~|^_$e;0uzz-_~g&9->Dj*YXxaW$?K$ef;r=@{rye784by>`-fY$*Rso$YJfj~LG zg^!qQN6(CMbaQ%4;fApFv@l3nxD#8l^8B??p4Rb(cJ^7AQNzhkX8>K72J3^`6eN10 z=8ww&bN343L@`?T$I1>eklnYgrj-fPR$?20sWD zWg}X34b;M)H*%}vdsN+(LK8KyWAnkG%Py>)p-9>G@{t#vH~S(1tA4#@YlJ7RnQrDN zkrt8tFPO>ST-8=xAG|oc`d?dT+3YT!|AWqnMOGAHD~}n^7lF3$YD(ZX&2bS~vI+4> zngD@N{;n8m5<510!$61wf6&Pei-|M2n&6+W?&{XrMb?mcxtAwBJ`z|g!`slhlQ4{V z_Y{xEmyR~4X5XoiHM_$X_x9AmMewC2jFGrrgUi>PIyOqbx^tVV>i(FFGK=Di&l7ZT zk$kD3TvfP4`N-5)(D7Nz$xE--gvvd~8(H?K}{YxuD^vvrIVEC0%}7 z`yJG=hj+QFcFDO-Y!b;ZAYPyF(!s^?rAP(5w=f?z?-IlJ)w38;B4lGQ3;cNuW?h&P zp~#vYG)CTyqZV8Rt%$NB9XCm0e%WWCO>RuKqn-OdU~|zuS6d?(ZP?)$av9iwZ;q8l z_vCf0hpg3m>5z{L{z-CFT{X6zG0k=i`YcE8@c?q|*x__?5IA1BdImToGH$XKE(;%3 z2R3iaJ7{xvOXB>(telEaKKZEUWk~a<6;)1ebi5(0qJS%Db6s)_`f6m}n&_@)L`o@n za2H{CZ*IA}D&5mcIJ0ethRdx;kY&8XzPGdFA#qC&ZrI|^Rb4hLG1_>HX; zE@*QewY{!|KDEh>=Mlo4lO6<_i5l*LsqZH39JsEMFXeX?7RKO(CTXJPDHXap6E)hC zr0IQG^-{P)8}Y34#x7LE?xM|*_hVi<{So}e9Gd|RxVZRxfEt!4`IJRm9DH3QPD?g9$Ba2#o~?n^-vwlDiJhy5khVL;_wd{`m5_*ZNW^h$508e1ovu` zpvQwCn?A{#|1rDHCcEGfBkH)1aNI~rV_A8*Z~gF1t`Oi`&qMCS8JnmA8#ncCg$O#> z)eG-{U7fm4I_J*b{l;H(7-iRWC@9~4#e}-$#&LF7Kn5DnBP#JZajVKPor(|D#x^Yn zA^OCnJZSiZH6vTU+R_gyv;lbRcVU@^nh4EJt1G*I z3HqU3R*Pk7`45l2*O!G;un!~u+ePZv7?dvw&KG60TjrGs#FKVrMXbSXLV+qj;rSJt zy*5#WHY{6Ab6Tehyj5CT9r%%&_|-AXks@5Yg(X_9cwaM9>}xpWv`*J7YmnlTHm6o$ z*VlJ)4eUgxet}S#yJU-@Kd{z21tYxa14IxKqc(4ijIf#pk9m!2t4$|a=raq60i$DW zf(jHB-W@61_NW0v-OI}^V{uXjZ@|J z4)rTmCxDf_f$lJVA%;bzcg#8kPIJ&x0#dCvT#fq-xJ}v})Of!+K}+6s&ZLLaLXk}e zRxXe{I(SHPLBM$P$GT6@y5b7FvAu!XZruUy*dgc2O4La@2z`@zA%S6Hg!|MiAz9LxUnsjX#a z>kdN6^}l^{2ESM9@r7@ENA>@8xA?bP$bbB!xq!Dse500cY-4Dl0_FOI{%O6OV?Txc E4|z6(p#T5? literal 0 HcmV?d00001 diff --git a/resources/images/BSA_logo_extended.PNG b/resources/images/BSA_logo_extended.PNG new file mode 100644 index 0000000000000000000000000000000000000000..40713d89743dc058c7e8b5dcf447d658ea76db63 GIT binary patch literal 7563 zcmeHMdsI_b*1v#)iip->EFcLTJJPYO7LoTO;0vt^R6yk+;DAPX2ogaFBtaRCS`nvK z5qShE0eJ+9Rjf!1uK*DOMF=E>pa}^{NHXUJLilE_*7;-R>-^EX7K?Lp&)sJ~ ze*1U!KKHVRo2%Y3qh$~T>FwUNeLn3wK@U@OXO1ie_e-O8`CuUE(^2?O<9zVqwGd=tx_i5e*VzDW-(a$_?MK?Lb%WZy zwtl^R>E0zb+SiUQrU$1_&~_d6G7#e()&?0RCp~%M_4D%p1&>6Ki-An|ie5dgp&U4C zoOe_XpwFC3b!JD4mjET9Jt?JKFXsDF2NFX=gn?L=XuyVo@*auv{9L8d%h zt^r;8bGO!#4*YAY9Lwgs$fsM}d{AW4Nm1MnbOACkqn<%}g(`g@_fP49ZUadG!+R|I zZ`qPOIZ;TNj%lu|q)e>S)t)tWtX#Xn|GZnL>ud5DNM zR3)B)&2C3`-cqNq=~TJa_4YK_Rbivl_s8`Tt7mi3>ouo?vH4wwFEMZo1=(iyz>d(S znmZ$AjeNw(eb_nXAmi5ukegzj{d>lvmqVw3fh{{z;0Vl!$dgudwx?1X7T`>Gj6c7Ay|y zcg*Rob`9){E91bHyjOhP>%`f|Md3xY0g9PSU$nJE-`UMVf}zxlb=a3D^r1KIvmrZB zXBAOU>&A4bfsu0PCT#On5dL#duqhuGYkZYDE9t7_;+5WnVj-!DEplmS+z2alYzocS z@372qg`$wN;WMmQ-Dc$(J(_;pt+-4Vj-b+gmKChWhH6>ilATwcv^3_&#NGp7+foAp znEfCPr7r{ zh75dq+N2I$b+BkF{MZwItS9p^QF~-L)&%Rf9+lhWlMI990c^05LoO5tY86exgt!X4 zk)KHyjhE`l@q%6Q{X>*Uff_+Jf9}VGy3=Mubg(9Xj0%0t*c>D9 z8`nv8?i~95J@!rDfi@=M8!GfLHXWHjX$TXrPO4d{btIysqMB0lAkr$nP}8*a8b67* z<~G?8^GXeZj2B~X;W@hwYd!6)pi1!P#1ac@HFKfgThV*LGM!-zKLd!xh{I3HG%*#d zVzt{-%WQ7eT8UC`;!1clJ1C_Gr<@bluPOVRQ(Y$-vZz4+pZ5j6 zV3j*y6;|=GM1C4<$=)nW70xmmcf%@<-y@h6#3ZuPkofmN1pzu@fu*lG%?$srXhP40 z$_-F!Fn;=lNVjFsR%@;bd08eo5gt>%UXHi)F6Hu|x1T79YuKmm zV#c$88`762doPBOrNEXz3)Bpd^pt;9Lp90J>a#9jOJRVhzW|zc;x{qH_;ZJ_`YO<6 z(Kydfj9UVIe|oT`VW>r)z>+ThYh1m`8Sg(cULA%Z^c*G=BE6wE)R{?3=BAadAcJNL zrk6QbZuj?xfEE*y5dk;WxI}BxjNe30pg3prC+!S_THx&~WO8^FZrfIF(F@rH0)EEq ztppR4WHb;qLX=M9&)HyCs??_GT6d4=iqArXlO8BHawKqvrxJ zCAcyZkN55#qA~Ao6s?g9#Kp^~iyKHS`YG>Znk){rLyfxxVtY4m!;vDCF|5=L@!+ZY zzyW`5T<8K51KbSAuVfb}`~>LgSPJ!>xUpKo-=YSmDEi*nh>1;W`B$Nt-H{1d)RnF6 zS@#!gsuP1--oaY;vREPID@u*|O|}4AaSnS_6jV*T@f4^r=p?gmFVhUd+W<(|xDswH zPy$isrbLCV=p8WJeT2vd9>$!#HXqQNfW-&Sr&%uGYJf|zIJZkh+p=XB1L zYqCvp-FnfQ`do@PEi02|*RY~RpT(DHQp2bo7HXpaPyJGbtR%4yH-BHejjfT1Qtr5( zjgL2$i+u_L717npdAgGhGVX0TXbDSoK#Tar(`O=cV~$6vJa(@F^p)L7|C!b>>e0*L z_n^CxpQ`D*$azbf_@?F{H!HbIqo9pxx`uzmL}CVA&jf3^by;hb&^b|=4!w?#UT7EX zA|&~@5MxG3kaH}&V{&zlSoj9-!>!9c^^-LPkL{Of9>}4%AV!*e1@0ens6VRFBt2zR zgUEe!&U-BKdXl&lAzLl)$hxcs0<+Gh&+mp*yXb2|5}m)c>ur4_Nn&9>?{r>3#;d4--m4WR<-OGlmjQ{^uv1Xe0i4ì&s6`zt=i&pW;#^Pe_B;cw|4N zKUbukIgIZnlbM0DE?wD_P~{}MkqNqixy>I4FGfyr*y)%`M#QY1<}E}{JF3TrcS>Ev zl;kV2&qUI@@6`)Ac?Q>J$o1ctnj#X3 zQW#t-f8si}4k*T-wRWJ&%8kM*x^&7NZJ|Y- zzJ=AGglISj=UlJ;<74H|!UV{+WY0$lsS*tk)`u2T)V;;eI*bjbo~VmvYh>=jxQp`> z!X5VtyAU_a??kA9^XkX3Ls@t6iNN3Edu9A(>}yxBuddBE5$OPW4%=i9V43bT3CkPH ztx%X0Z?h^6NLO$8{HP7L(DVA%wy`9}U<%tn6@G-<)A!4#v;biSquHc`o=IM9p%rTQ zS*PGPWjq^MHSZMiNU`IFZwgh}jfwhbf%p&_+vCgqF62)2`j}Bs_W14 zYRsKR)!#xkt9@Zs7?4`L)0HzBiZz=nkeGBfi30q!Rpl?U&+l6FdXkpQ6 z<*Pxo4cRQbtc)FQ<8o5MkO?ZM@(2a&3Woeld26*mL7t+jQ=S=@5jqUdr$l0>-JZbH$BjK`wt3^B!9eOin;-d+W+$5zv^!*VU0guqmC-vjRjD1Vs7s+QDHP$ zBn}xqz98$19?&s`T$)`=HhF#yUGBmc8rm;}>4A1;Z&-z+FVWCfZ$Z2LD+i}anu30T zr)D3*$N3Frl?*P0@CSz<7!1ZFmHM;fIXE?*tZ!N&s04>|PcKiP*rZI*iUgs+sqnP2 z{$ncZKSGktd7Vo`V$DR^f9*4Zb2i{oBw#Uc8Nh|c?+3)H<_dV^mrDNs)f4qu)O`?= zpJHnIO)B + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/BsaLib/BSAlib.vfproj b/src/BsaLib/BSAlib.vfproj new file mode 100644 index 0000000..0a42373 --- /dev/null +++ b/src/BsaLib/BSAlib.vfproj @@ -0,0 +1,76 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/BsaLib/BsaLib.f90 b/src/BsaLib/BsaLib.f90 new file mode 100644 index 0000000..bd67a75 --- /dev/null +++ b/src/BsaLib/BsaLib.f90 @@ -0,0 +1,556 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib + +#include "./precisions" + + use BsaLib_CONSTANTS + use BsaLib_IO + implicit none + public + + private :: mainClassic_, mainMesher_ + + ! BUG: these might be moved, and called via an internal function pointer. + private :: bsa_exportSkewness_compute_, bsa_exportSkewness_nocompute_ + private :: bsa_exportBR_nocompute_ + + + + interface bsa_exportBRdecomp + module procedure bsa_exportBR_nocompute_ + end interface + + + interface bsa_exportSkewness + module procedure bsa_exportSkewness_compute_ + module procedure bsa_exportSkewness_nocompute_ + end interface + + + + !************************************************************************************** + ! INTERAFCE FOR PRIVATE PROCEDURES + !************************************************************************************** + interface + module subroutine mainClassic_(m2mf_cls, m2mr_cls, m2o2mr_cls, m3mf_cls, m3mr_cls) + real(RDP), allocatable :: m2mf_cls(:), m2mr_cls(:), m2o2mr_cls(:), m3mf_cls(:), m3mr_cls(:) + end subroutine + + + module subroutine mainMesher_(m3mf_msh, m3mr_msh) + real(RDP), target, allocatable :: m3mf_msh(:), m3mr_msh(:) + end subroutine + end interface + + + + + + !************************************************************************************** + ! INTERAFCE FOR PUBLIC PROCEDURES + !************************************************************************************** + interface + + + + ! -------------------------- GENERAL --------------------------------- + + + module subroutine bsa_setOutputDirectory(dirname) + character(len=*), intent(in) :: dirname + end subroutine + + + module subroutine bsa_setOutFileName(fname) + character(len=*), intent(in) :: fname + end subroutine + + + module subroutine bsa_setOutUnit(iunit) + integer(kind = 4), intent(in) :: iunit + end subroutine + + + module subroutine bsa_closeUnitsAtEnd() + end subroutine + + + module subroutine bsa_setExportFileFormat(iform) + integer(kind = 4), intent(in) :: iform + end subroutine + + + module subroutine bsa_setExportAppendMode(imode) + integer(kind = 4), intent(in) :: imode + end subroutine + + + module subroutine bsa_setSpatialSymmetry(isym) + integer(kind = 4), intent(in) :: isym + end subroutine + + + module subroutine bsa_setBfmMLR(bool) + logical, intent(in) :: bool + end subroutine + + + module subroutine bsa_setPremeshType(itype) + integer(kind = 4), intent(in) :: itype + end subroutine + + + module subroutine bsa_setPremeshMode(imode) + integer(kind = 4), intent(in) :: imode + end subroutine + + + module subroutine bsa_doValidateModalData(bool) + logical, intent(in) :: bool + end subroutine + + + ! module subroutine bsa_doValidateZoneDeltas(bool) + ! logical, intent(in) :: bool + ! end subroutine + + module subroutine bsa_setValidateDeltasPolicy(id) + integer, intent(in) :: id + end subroutine + + + module subroutine bsa_setValidateDeltasValues(ibkg, ires) + integer, intent(in) :: ibkg, ires + end subroutine + + + module subroutine bsa_Init() + end subroutine + + + module subroutine bsa_forceBsaClsExecution(bool) + logical, intent(in) :: bool + end subroutine + + + module subroutine bsa_setMaxBkgPeakRestriction(bool) + logical, intent(in) :: bool + end subroutine + + + module subroutine bsa_setPODTruncationThreshold(rval) + real(kind = 8), intent(in) :: rval + end subroutine + + + module subroutine bsa_Run(m2mf_cls, m2mr_cls, m2o2mr_cls, m3mf_msh, m3mr_msh, m3mf_cls, m3mr_cls) + real(RDP), target, allocatable, dimension(:) :: & + m2mf_cls, m2mr_cls, m2o2mr_cls, m3mf_msh, m3mr_msh, m3mf_cls, m3mr_cls + end subroutine + + + module subroutine bsa_Finalise() + end subroutine + + + logical pure module function bsa_isCleaned() + end function + + + + + ! -------------------------- SETTINGS --------------------------------- + + + module elemental function bsa_isFullComp() result(bool) + logical :: bool + end function + + + module subroutine bsa_setSubanType(isuban) + integer(kind = 4), intent(in) :: isuban + end subroutine + + + + module subroutine bsa_setVersion(ivers) + integer(kind = 4), intent(in) :: ivers + end subroutine + + + + module subroutine bsa_setScalingConv(iconv) + integer(kind = 4), intent(in) :: iconv + end subroutine + + + + module subroutine bsa_setSpectraComputation(ipsd, ibisp) + integer(kind = 4), intent(in), optional :: ipsd, ibisp + end subroutine + + + + module subroutine bsa_setSpectraExtension(ionlydiag) + integer(kind = 4), intent(in) :: ionlydiag + end subroutine + + + + module subroutine bsa_setTestMode(itest) + integer(kind = 4), intent(in) :: itest + end subroutine + + + module subroutine bsa_setSymmetries(ibispsym, i3dsym) + integer(kind = 4), intent(in) :: ibispsym, i3dsym + end subroutine + + + module subroutine bsa_setupClassic(nfreqs, df) + integer(kind = 4), intent(in) :: nfreqs + real(RDP), intent(in) :: df + end subroutine + + + + module subroutine bsa_setupMesher(isvd, bkgrfmt, bkgaext, genpaext, maxaext, ifcov, idumpmod) + integer(kind = 4), intent(in) :: isvd, bkgrfmt, maxaext + integer(kind = 4), intent(in) :: bkgaext, genpaext, ifcov, idumpmod + end subroutine + + + + + ! -------------------------- WIND --------------------------------- + + + module subroutine bsa_setWindDirections(dirs, ndirs) + integer(kind = 4), intent(in) :: dirs(:) + integer(kind = 4), intent(in), optional :: ndirs + end subroutine + + + module subroutine bsa_setWindTurbComps(tc, ntc) + integer(kind = 4), intent(in) :: tc(:) + integer(kind = 4), intent(in), optional :: ntc + end subroutine + + + module subroutine bsa_setWindVertProf(iwprof) + integer(kind = 4), intent(in) :: iwprof + end subroutine + + + + module subroutine bsa_setPSDType(ipsd) + integer(kind = 4), intent(in) :: ipsd + end subroutine + + + + module subroutine bsa_setWindAltDir(ivert) + integer(kind = 4), intent(in) :: ivert + end subroutine + + + + module subroutine bsa_setWindZoneLimits(lim, ilim) + real(RDP), intent(in) :: lim(..) + integer(kind = 4), intent(in), optional :: ilim(..) + end subroutine + + + + module subroutine bsa_setAirDensity(aird) + real(RDP), intent(in) :: aird + end subroutine + + + + module subroutine bsa_setGlobalRotMatW2G(rotW2G) + real(RDP), intent(in) :: rotW2G(3, 3) + end subroutine + + + + module subroutine bsa_setWZMeanWindVel(mat) + real(RDP), target, intent(in) :: mat(:) + end subroutine + + + + module subroutine bsa_setWZRefAlt(Zref) + real(RDP), target, intent(in) :: Zref(:) + end subroutine + + + + module subroutine bsa_setTurbWindScales(L) + real(RDP), target, intent(in) :: L(3, 3, *) + end subroutine + + + + module subroutine bsa_setTurbWindSDT(sigma) + real(RDP), target, intent(in) :: sigma(3, *) + end subroutine + + + + module subroutine bsa_setWindCorrCoeffs(ccoeffs) + real(RDP), target, intent(in) :: ccoeffs(3, 3, *) + end subroutine + + + + module subroutine bsa_setWindCorrExpnts(cexpn) + real(RDP), target, intent(in) :: cexpn(3, 3, *) + end subroutine + + + + module subroutine bsa_setIncidenceAngles(incang) + real(RDP), target, intent(in) :: incang(:) + end subroutine + + + + module subroutine bsa_setWZRotMatW2G(rotW2G_L) + real(RDP), target, intent(in) :: rotW2G_L(3, 3, *) + end subroutine + + + + module subroutine bsa_setNodalVel(Unod) + real(RDP), target, intent(in) :: Unod(:) + end subroutine + + + + module subroutine bsa_setNodalWindZones(NodWZ) + integer(kind = 4), target, intent(in) :: NodWZ(:) + end subroutine + + + module subroutine bsa_setNodalWindAltitudes(WnodAlt) + real(RDP), target, intent(in) :: WnodAlt(:) + end subroutine + + + module subroutine bsa_setSpatialNodalCorr(nodCorr) + real(RDP), target, intent(in) :: nodCorr(:, :) + end subroutine + + + + module subroutine bsa_setWindFCoeffs(wfc) + !> Dimensions should be [nlibs_l, ndegw+3, nnodes_l] + real(RDP), target, intent(in) :: wfc(:, :, :) + end subroutine + + + module subroutine bsa_setPhitimesC(phiTc) + real(RDP), target, intent(in) :: phiTc(:, :, :) + end subroutine + + + + + + ! -------------------------- STRUCTURAL --------------------------------- + + module subroutine bsa_setNodalCoords(nn, coords) + integer(kind = 4), intent(in) :: nn + real(RDP), target, allocatable :: coords(:, :) + end subroutine + + + + module subroutine bsa_setNodalNOfDOFs(nlibs) + integer(kind = 4), intent(in) :: nlibs + end subroutine + + + + module subroutine bsa_setTotalNOfNodes(nn) + integer(kind = 4), intent(in) :: nn + end subroutine + + + + module subroutine bsa_setLoadedNodalDOFs(libs_l, nlibs_l) + integer(kind = 4), intent(in), target, allocatable :: libs_l(:) + integer(kind = 4), intent(in), optional :: nlibs_l + end subroutine + + + + module subroutine bsa_setLoadedNodes(nodes_l, nn_l) + integer(kind = 4), intent(in), target, allocatable :: nodes_l(:) + integer(kind = 4), intent(in), optional :: nn_l + end subroutine + + + + module subroutine bsa_setModalInfo(ndofs, nm, Phi, natf) + integer(kind = 4), intent(in) :: ndofs, nm + real(RDP), intent(in), target :: Phi(ndofs, nm), natf(nm) + end subroutine + + + + module subroutine bsa_setKeptModalShapes(modes) + integer(kind = 4), intent(in) :: modes(:) + end subroutine + + + + module subroutine bsa_setModalMatrices(nm, Mgen, Kgen, Cgen) + integer(kind = 4), intent(in) :: nm + real(RDP), intent(in), target, dimension(nm) :: Mgen, Kgen + real(RDP), intent(in), target :: Cgen(nm, nm) + end subroutine + + + + module subroutine bsa_setTotDamping(xsi) + real(RDP), target, intent(in) :: xsi(:) + end subroutine + + + + module pure function bsa_getUsedModeShapes() result(modes) + integer(kind = 4), allocatable :: modes(:) + end function + + + + + + ! -------------------------- COMPUTING --------------------------------- + + module subroutine bsa_computeBRdecomp(m2mf, bkg, res) + real(RDP), intent(in) :: m2mf(:) + real(RDP), allocatable, intent(out) :: bkg(:), res(:) + end subroutine + + + module subroutine bsa_computePeakFactors(& + m2, m2o2, obs_time, peak_g, sk, peak_ng_pos, peak_ng_neg) + real(kind = 8), intent(in) :: m2(:), m2o2(:) + real(kind = 8), intent(in) :: obs_time + real(kind = 8), allocatable, intent(inout) :: peak_g(:) + real(kind = 8), intent(in), allocatable :: sk(:) + real(kind = 8), allocatable, intent(inout) :: peak_ng_pos(:) + real(kind = 8), allocatable, intent(inout), optional :: peak_ng_neg(:) + end subroutine + + + + + + + ! -------------------------- EXPORTING --------------------------------- + + module subroutine bsa_setExportDirectory(dirname) + character(len = *), intent(in) :: dirname + end subroutine + + + + module subroutine bsa_setExportInCurrDir() + end subroutine + + + + module subroutine bsa_exportBR_nocompute_(fname, bkg, res, xsi) + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: bkg(:), res(:), xsi(:) + end subroutine + + + + module subroutine bsa_exportMomentToFile(fname, vec) + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: vec(:) + end subroutine + + + + module subroutine bsa_exportSkewness_nocompute_(fname, sk) + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: sk(:) + end subroutine + + + module subroutine bsa_exportSkewness_compute_(fname, m2, m3) + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: m2(:), m3(:) + end subroutine + + + + module subroutine bsa_exportPSDToFile(fname, psd, varname, f) + character(len = *), intent(in) :: fname + character(len = *), intent(in), optional :: varname + real(RDP), intent(in), optional :: f(:) + real(RDP), intent(in) :: psd(:, :) + end subroutine + + + + module subroutine bsa_exportBispToFile(fname, bisp, varname) + character(len = *), intent(in) :: fname + character(len = *), intent(in), optional :: varname + real(RDP), intent(in) :: bisp(:, :, :) + end subroutine + + + + module subroutine bsa_saveCoordinatesToFile(fname, coords) + character(len = *), intent(in) :: fname + real(RDP), intent(in), target, optional :: coords(:, :) + end subroutine + + + + module subroutine bsa_exportPeakOrExtremesToFile(fname, rvar) + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: rvar(:) + end subroutine + + + + module subroutine bsa_setBRMExportDefaultMode(imode) + integer(kind = 4), intent(in) :: imode + end subroutine + + + module subroutine bsa_setBRMExportFunction(fptr) +#ifdef __BSA_OMP + procedure(exportBRMinterf_vect_all_), pointer, intent(in) :: fptr +#else + procedure(exportBRMinterf_scalar_), pointer, intent(in) :: fptr +#endif + end subroutine + + + end interface + + +end module BsaLib \ No newline at end of file diff --git a/src/BsaLib/CONSTANTS/CONSTANTS.f90 b/src/BsaLib/CONSTANTS/CONSTANTS.f90 new file mode 100644 index 0000000..9737b48 --- /dev/null +++ b/src/BsaLib/CONSTANTS/CONSTANTS.f90 @@ -0,0 +1,180 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_CONSTANTS + + implicit none + public + + + !************************************************************************************** + ! BSA GENERICS + !************************************************************************************** + integer(kind = 4), parameter :: BSA_SPATIAL_SYM_NONE = 1 + integer(kind = 4), parameter :: BSA_SPATIAL_SYM_HALF = 2 + integer(kind = 4), parameter :: BSA_SPATIAL_SYM_FOUR = 4 + + integer(kind = 4), parameter :: BSA_PREMESH_MODE_BASE = 0 + integer(kind = 4), parameter :: BSA_PREMESH_MODE_ZONE_REFINED = 1 + + integer(kind = 4), parameter :: BSA_PREMESH_TYPE_DIAG_CREST_NO = 0 + integer(kind = 4), parameter :: BSA_PREMESH_TYPE_DIAG_CREST_YES = 1 + + integer(kind = 4), parameter :: BSA_VALIDATE_DELTAS_POLICY_NONE = 0 + integer(kind = 4), parameter :: BSA_VALIDATE_DELTAS_POLICY_DEFAULT = 1 + integer(kind = 4), parameter :: BSA_VALIDATE_DELTAS_POLICY_LIGHT = 2 + integer(kind = 4), parameter :: BSA_VALIDATE_DELTAS_POLICY_MEDIUM = 3 + integer(kind = 4), parameter :: BSA_VALIDATE_DELTAS_POLICY_HIGH = 4 + integer(kind = 4), parameter :: BSA_VALIDATE_DELTAS_POLICY_STRICT = 5 + + !************************************************************************************** + ! BSA I/O DEFAULTS + !************************************************************************************** + character(len = *), parameter :: BSA_OUT_DIRNAME_DEFAULT = '.\bsaresults\' + character(len = *), parameter :: BSA_OUT_FILENAME_PREFIX_DEFAULT_ = 'bsaout_def' + character(len = *), parameter :: BSA_STRUCT_DATA_DUMPFILE = 'dumpstruct' + character(len = *), parameter :: BSA_SETTS_DATA_DUMPFILE = 'dumpsetts' + character(len = *), parameter :: BSA_WIND_DATA_DUMPFILE = 'dumpwind' + + + !************************************************************************************** + ! LOGGING TAGs + !************************************************************************************** + character(len = *), parameter :: MSGCONT = ' ' + character(len = *), parameter :: INFOMSG = ' --[info] ' + character(len = *), parameter :: NOTEMSG = ' --[note] ' + character(len = *), parameter :: WARNMSG = ' --[warn] ' + character(len = *), parameter :: ERRMSG = ' --[error] ' + character(len = *), parameter :: DBGMSG = ' --[debug] ' + + + !************************************************************************** + ! I/O CONSTANTs + !************************************************************************** + character(len = *), parameter :: IO_ACCESS_DIRECT = 'DIRECT' + character(len = *), parameter :: IO_ACCESS_SEQUEN = 'SEQUENTIAL' + character(len = *), parameter :: IO_ACCESS_STREAM = 'STREAM' + character(len = *), parameter :: IO_ACCESS_APPEND = 'APPEND' + + character(len = *), parameter :: IO_ACTION_WRITE = 'WRITE' + character(len = *), parameter :: IO_ACTION_READ = 'READ' + character(len = *), parameter :: IO_ACTION_READWRITE = 'READWRITE' + + character(len = *), parameter :: IO_ASYNC_YES = 'YES' + character(len = *), parameter :: IO_ASYNC_NO = 'NO' + + character(len = *), parameter :: IO_BUFFERED_YES = 'YES' + character(len = *), parameter :: IO_BUFFERED_NO = 'NO' + + character(len = *), parameter :: IO_FORM_FORMATTED = 'FORMATTED' + character(len = *), parameter :: IO_FORM_UNFORMATTED = 'UNFORMATTED' + character(len = *), parameter :: IO_FORM_BINARY = 'BINARY' + + character(len = *), parameter :: IO_POSITION_ASIS = 'ASIS' + character(len = *), parameter :: IO_POSITION_REWIND = 'REWIND' + character(len = *), parameter :: IO_POSITION_APPEND = 'APPEND' + + character(len = *), parameter :: IO_STATUS_OLD = 'OLD' + character(len = *), parameter :: IO_STATUS_NEW = 'NEW' + character(len = *), parameter :: IO_STATUS_SCRATCH = 'SCRATCH' + character(len = *), parameter :: IO_STATUS_REPLACE = 'REPLACE' + character(len = *), parameter :: IO_STATUS_UNKNOWN = 'UNKNOWN' + + + !************************************************************************** + ! EXPORT CONSTANTs + !************************************************************************** + integer(kind = 4), parameter :: BSA_EXPORT_FORMAT_FORMATTED = 0 + integer(kind = 4), parameter :: BSA_EXPORT_FORMAT_UNFORMATTED = 1 + integer(kind = 4), parameter :: BSA_EXPORT_MODE_APPEND = 0 + integer(kind = 4), parameter :: BSA_EXPORT_MODE_REPLACE = 1 + + integer(kind = 4), parameter :: BSA_EXPORT_BRM_MODE_NONE = 0 + integer(kind = 4), parameter :: BSA_EXPORT_BRM_MODE_BASE = 1 + integer(kind = 4), parameter :: BSA_EXPORT_BRM_MODE_USR = 9 + + + character(len = *), parameter :: BSA_EXPORT_M2MF_CLS_FNAME = "m2mf_cls" + character(len = *), parameter :: BSA_EXPORT_M2MR_CLS_FNAME = "m2mr_cls" + character(len = *), parameter :: BSA_EXPORT_M2O2MR_CLS_FNAME = "m2o2mr_cls" + character(len = *), parameter :: BSA_EXPORT_M3MF_CLS_FNAME = "m3mf_cls" + character(len = *), parameter :: BSA_EXPORT_M3MR_CLS_FNAME = "m3mr_cls" + character(len = *), parameter :: BSA_EXPORT_M2MF_MSH_FNAME = "m2mf_msh" + character(len = *), parameter :: BSA_EXPORT_M2MR_MSH_FNAME = "m2mr_msh" + character(len = *), parameter :: BSA_EXPORT_M2O2MR_MSH_FNAME = "m2o2mr_msh" + character(len = *), parameter :: BSA_EXPORT_M3MF_MSH_FNAME = "m3mf_msh" + character(len = *), parameter :: BSA_EXPORT_M3MR_MSH_FNAME = "m3mr_msh" + + + abstract interface + subroutine exportBRMinterf_scalar_(f1, f2, brm, pdata) + real(kind = 8), intent(in) :: f1, f2, brm(:) + class(*), pointer, intent(in) :: pdata + end subroutine + + subroutine exportBRMinterf_vect_all_(f1, f2, brm, pdata) + real(kind = 8), intent(in) :: f1(:), f2(:), brm(:, :) + class(*), pointer, intent(in) :: pdata + end subroutine + end interface + + + + + !************************************************************************************** + ! NUMERICs + !************************************************************************************** + + !> TO AVOID CRASHING BECAUSE OF MACHINE FLOATING PRECISION ERRORS + real(kind = 8), parameter :: MACHINE_PRECISION = 1e-12 + + real(kind = 8), parameter :: CST_PIGREC = 4.d0 * atan(1.d0) + + real(kind = 8), parameter :: CST_PIt2 = CST_PIGREC * 2.d0 + real(kind = 8), parameter :: CST_PIt4 = CST_PIGREC * 4.d0 + + real(kind = 8), parameter :: CST_PId2 = CST_PIGREC / 2.d0 + real(kind = 8), parameter :: CST_PId4 = CST_PIGREC / 4.d0 + + + real(kind = 8), parameter :: CST_2d3 = 2.d0 / 3.d0 + real(kind = 8), parameter :: CST_3d2 = 3.d0 / 2.d0 + real(kind = 8), parameter :: CST_PIt3d2 = CST_PIGREC * CST_3d2 + + + logical, protected :: header_called_ = .false. + + +contains + + + subroutine bsa_printBSAHeader() + print * + print * + print *, ' ____________________________________________ ' + print *, ' | _____ ____ |' + print *, ' | / \ / /\ |' + print *, ' | /____/ \___ / \ |' + print *, ' | / \ \ /____\ |' + print *, ' | /_____/ . _____/ . _/ \_ . |' + print *, ' |____________________________________________|' + print * + print * + + header_called_ = .true. + end subroutine bsa_printBSAHeader + + +end module \ No newline at end of file diff --git a/src/BsaLib/IO/Logging.f90 b/src/BsaLib/IO/Logging.f90 new file mode 100644 index 0000000..a8f644f --- /dev/null +++ b/src/BsaLib/IO/Logging.f90 @@ -0,0 +1,152 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module Logging + +#include "../precisions" + + use BsaLib_IO, only: unit_dump_bfm_, unit_debug_, undebug_fname_ + use BsaLib_CONSTANTS + implicit none + private + +#ifdef __BSA_ALLOC_DEBUG + interface allocOKMsg + module procedure allocOKMsg_scalar_ + module procedure allocOKMsg_array_ + end interface + + public :: allocOKMsg, deallocOKMsg +#endif + + public :: allocKOMsg, deallocKOMsg + + type, public :: logger_t + + private + integer(kind = 4) :: iun_ = 0 + character(len=:), allocatable :: fileName_ + + contains + + ! setting up + + procedure, public :: init + procedure, public :: name + procedure, public :: setName + procedure, public :: unit + procedure, public :: setUnit + + + ! logging procedures + + procedure, public :: logZonePremeshingTotTime + + ! procedure, public, pass :: LogWindSpectralAnalysisHeader, LogWindSPeedProfileType + ! procedure, public, pass :: LogWindZoneData, LogTransFuncType, LogMaxValueType + ! procedure, public, pass :: LogElementWindLoad, LOgDLMWindCoeffs, LogElementWindIncidenceAngles + ! procedure, public, pass :: LogElemWindNodalVel + end type logger_t + + + + + interface + + module subroutine init(this, iun, fname) + class(logger_t), intent(inout) :: this + integer(kind = 4), intent(in) :: iun + character(len=*), intent(in), optional :: fname + end subroutine + + + + module function name(this) result(nam) + class(logger_t), intent(in) :: this + character(len=:), allocatable :: nam + end function + + module subroutine setName(this, fname) + class(logger_t), intent(inout) :: this + character(len=*), intent(in) :: fname + end subroutine + + + + module function unit(this) result(iun) + class(logger_t), intent(in) :: this + integer :: iun + end function + + module subroutine setUnit(this, iun) + class(logger_t), intent(inout) :: this + integer, intent(in), target :: iun + end subroutine + + + + + + module subroutine logZonePremeshingTotTime(this, zname, rtime, npts, print2console) + class(logger_t), intent(in) :: this + character(len=*), intent(in) :: zname + real(RDP), intent(in) :: rtime + integer, intent(in), optional :: npts + logical, intent(in), optional :: print2console + end subroutine + + + + + +!========================================================================================= +! +! ALLOCATION +! +!========================================================================================= + + +#ifdef __BSA_ALLOC_DEBUG + module subroutine allocOKMsg_scalar_(name_, iloc, nbytes) + character(len = *), intent(in) :: name_ + integer(kind = 8), intent(in), optional :: iloc, nbytes + end subroutine + + module subroutine allocOKMsg_array_(name_, dims, iloc, nbytes) + character(len = *), intent(in) :: name_ + integer, intent(in) :: dims(..) + integer(kind = 8), intent(in), optional :: iloc, nbytes + end subroutine + + module subroutine deallocOKMsg(name_) + character(len = *), intent(in) :: name_ + end subroutine +#endif + + module subroutine allocKOMsg(name_, istat, emsg) + character(len = *), intent(in) :: name_, emsg + integer, intent(in) :: istat + end subroutine + + module subroutine deallocKOMsg(name_, istat, emsg) + character(len = *), intent(in) :: name_, emsg + integer, intent(in) :: istat + end subroutine + + + end interface + + +end module Logging \ No newline at end of file diff --git a/src/BsaLib/IO/LoggingImpl.f90 b/src/BsaLib/IO/LoggingImpl.f90 new file mode 100644 index 0000000..37b7b98 --- /dev/null +++ b/src/BsaLib/IO/LoggingImpl.f90 @@ -0,0 +1,488 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(Logging) LoggingImpl + +#include "../precisions" + + use BsaLib_IO, only: INFOMSG, WARNMSG, ERRMSG, MSGCONT, DBGMSG, NOTEMSG + use BsaLib_Data, only: bsa_Abort + implicit none + character(len = 256) :: fmt + character(len=0), parameter :: lev0 = '' + character(len=3), parameter :: lev1 = ' ' + + +contains + + + module subroutine init(this, iun, fname) + class(logger_t), intent(inout) :: this + integer(kind = 4), intent(in) :: iun + character(len=*), intent(in), optional :: fname + + this%iun_ = iun + if (present(fname)) this%fileName_ = fname + end subroutine + + + + module function name(this) result(nam) + class(logger_t), intent(in) :: this + character(len=:), allocatable :: nam + + nam = this%fileName_ + end function + + module subroutine setName(this, fname) + class(logger_t), intent(inout) :: this + character(len=*), intent(in) :: fname + + this%fileName_ = fname + end subroutine setName + + + + module function unit(this) result(iun) + class(logger_t), intent(in) :: this + integer :: iun + + iun = this%iun_ + end function + + + module subroutine setUnit(this, iun) + class(logger_t), intent(inout) :: this + integer, intent(in), target :: iun + + call this%init(iun) + end subroutine + + + + + module subroutine logZonePremeshingTotTime(this, zname, rtime, npts, print2console) + class(logger_t), intent(in) :: this + character(len=*), intent(in) :: zname + real(RDP), intent(in) :: rtime + integer, intent(in), optional :: npts + logical, intent(in), optional :: print2console + + logical :: do_print = .false. + + if (present(print2console) .and. print2console) do_print = .true. + + write(unit=fmt, fmt='(a, "Done zone ", a)') INFOMSG, zname + write(this%iun_, '(1x, a)') fmt(1 : len_trim(fmt)) + if (do_print) print '(1x, a)', fmt(1 : len_trim(fmt)) + + if (present(npts)) then + + write(unit=fmt, fmt='( a, "- n. of zone points: ", i0 )') & + MSGCONT, npts + write(this%iun_, '(1x, a)') fmt(1 : len_trim(fmt)) + if (do_print) print '(1x, a)', fmt(1 : len_trim(fmt)) + endif + + write(unit=fmt, fmt='(a, "- TOT. TIME: ", g0, " [s]")') & + MSGCONT, rtime + write(this%iun_, '(1x, a, /)') fmt(1 : len_trim(fmt)) + if (do_print) print '(1x, a, /)', fmt(1 : len_trim(fmt)) + end subroutine logZonePremeshingTotTime + + + + + + + + + + + + + + +!***************************************************************************************** +! ALLOCATION +!***************************************************************************************** + +#ifdef __BSA_ALLOC_DEBUG + module subroutine allocOKMsg_scalar_(name_, iloc, nbytes) + character(len = *), intent(in) :: name_ + integer(kind = 8), intent(in), optional :: iloc, nbytes + + write(unit_debug_, fmt='(3a)', advance='no') & + 'variable "', name_, '" allocated.' + + if (present(iloc)) then + write(unit_debug_, '(a, i0)', advance='no') & + 'Location in memory: ', iloc + endif + + if (present(nbytes)) then + write(unit_debug_, fmt='(a, i0, ".")', advance='no') & + 'Occupancy (bytes): ', nbytes + write(unit_debug_, *) '' + endif + end subroutine + + + module subroutine allocOKMsg_array_(name_, dims, iloc, nbytes) + character(len = *), intent(in) :: name_ + integer, intent(in) :: dims(..) + integer(kind = 8), intent(in), optional :: iloc, nbytes + integer :: dim, ndims + + write(unit_debug_, fmt='(3a)', advance='no') & + 'variable "', name_, '" allocated.' + + select rank (dims) + rank (0) + dim = dims + write(unit_debug_, '(a, i0)') & + 'Dimension: ', dim + rank (1) + ndims = size(dims) + write(unit_debug_, '(a, i0, *(" - ", i0) )') & + 'Dimension: ', (dims(dim), dim = 1, ndims) + + rank default + + print '(1x, a, a)', & + ERRMSG, & + ' Dimensions for a NDrank array allocation must be at most 1D-rank array.' + call bsa_Abort() + end select + + if (present(iloc)) then + write(unit_debug_, '(a, i0)', advance='no') & + 'Location in memory: ', iloc + endif + + if (present(nbytes)) then + write(unit_debug_, fmt='(a, i0, ".")', advance='no') & + 'Occupancy (bytes): ', nbytes + write(unit_debug_, *) '' + endif + end subroutine + + + module subroutine deallocOKMsg(name_) + character(len = *), intent(in) :: name_ + + write(unit_debug_, fmt='(3a)') & + 'variable "', name_, '" de-allocated.' + end subroutine +#endif + + + + module subroutine allocKOMsg(name_, istat, emsg) + character(len = *), intent(in) :: name_, emsg + integer, intent(in) :: istat + + write(unit_debug_, fmt='(3a)') & + '[ERROR] variable "', name_, '" could not be allocated.' + write(unit_debug_, fmt='(15x, a, i0, 2a)') & + 'Exit code ', istat, '. Error message: ', emsg(1 : len_trim(emsg)) + + call bsa_Abort() + end subroutine + + + module subroutine deallocKOMsg(name_, istat, emsg) + character(len = *), intent(in) :: name_, emsg + integer, intent(in) :: istat + + write(unit_debug_, fmt='(3a)') & + '[ERROR] variable "', name_, '" could not be de-allocated.' + write(unit_debug_, fmt='(15x, a, i0, 2a)') & + 'Exit code ', istat, '. Error message: ', emsg(1 : len_trim(emsg)) + + call bsa_Abort() + end subroutine + + + +end submodule + + + + + + + + + + + + + + + + + + + + + + + + + + +! subroutine LogWindSpectralAnalysisHeader(logger, nz, ivaru, isu) +! ! in +! class(logger_t), intent(in) :: logger +! integer, intent(in) :: nz, ivaru +! integer, intent(in), optional :: isu + +! 10 format( //,& +! ' ANALYSE SPECTRALE VENT',/, & +! ' **********************',/, & +! ' NOMBRE DE ZONES : ',I4,/, & +! ' TYPE DE VARIATION DU VENT AVEC L ALTITUDE : ',A10,/ & +! ' DENSITE SPECTRALE DE VENT : VON KARMAN' / ) + +! 11 format( //,& +! ' ANALYSE SPECTRALE VENT',/, & +! ' **********************',/, & +! ' NOMBRE DE ZONES : ',I4,/, & +! ' TYPE DE VARIATION DU VENT AVEC L ALTITUDE : ',A12,/ & +! ' DENSITE SPECTRALE DE VENT : ', A12 / ) + + +! if (present(isu)) then +! write(logger%iun_, fmt=11), nz, CST_WIND_V_PROFILES(ivaru), CST_PSD_TYPES(isu) +! else +! write(logger%iun_, fmt=10), nz, CST_WIND_V_PROFILES(ivaru) +! endif +! end subroutine LogWindSpectralAnalysisHeader + + + + + + +! subroutine LogWindSPeedProfileType(logger, ivaru) +! class(logger_t), intent(in) :: logger +! integer, intent(in) :: ivaru + +! 10 format( & +! ' !!!!!!!!!!!LOI SPECIALE MILLAU ZREF= 260.07 !!!!!!!!!!', /& +! ' -------------------------------------------------------' ) +! 11 format( & +! ' !!!!!!!!!!!LOI SPECIALE MILLAU MAQU ZREF= 0.8669 !!!!!', /& +! ' ---------------------------------------------------------' ) +! if (ivaru == 3) then +! write(logger%iun_, fmt=10) +! elseif(ivaru == 4) then +! write(logger%iun_, fmt=11) +! endif +! end subroutine LogWindSPeedProfileType + + + + + +! subroutine LogWindZoneData(logger, iz, xlim, ub, alpha, al, ect, corr, expp) +! class(logger_t), intent(in) :: logger +! integer, intent(in) :: iz +! real, intent(in) :: xlim( : ), ub, alpha, ect( 3 ) +! real, intent(in), dimension(3,3) :: al, corr, expp +! ! local +! integer i, j + +! 10 format( /,& +! ' ZONE ',I2,' DE X = ',F10.2,' A X= ',F10.2,/, & +! ' -----------------------------------------',/, & +! ' VITESSE DE BASE : ', F10.3,/, & +! ' ALPHA / Z0 : ', F10.3,/, & +! ' I LXI LYI LZI EC.TYPE I',/, & +! ' U ',4F10.5 ,/ & +! ' V ',4F10.5 ,/ & +! ' W ',4F10.5 ,/ & +! ' I CORR.X I CORR.Y I CORR.Z I EXPP.X I EXPP.Y I EXPP.Z I', /, & +! ' U ',3(1x,g9.4),3F10.5 ,/& +! ' V ',3(1x,g9.4),3F10.5 ,/& +! ' W ',3(1x,g9.4),3F10.5 & +! ) + +! write(logger%iun_, 10), iz, xlim( iz ), xlim( iz + 1 ), ub, alpha, & +! ( & +! ( al( i,j ), j = 1,3 ), & +! ect( i ),& +! i = 1, 3 ), & +! ( & +! ( corr( i,j ), j = 1,3 ), & +! ( expp( i,j ), j = 1,3 ), & +! i = 1, 3 ) +! end subroutine LogWindZoneData + + + + + + + +! subroutine LogTransFuncType(logger, itran) +! class(logger_t), intent(in) :: logger +! integer, intent(in) :: itran + +! 10 format ( ' ITRAN = ', 1I1, & +! ' : TRANSFER MATRIX ASSUMED DIAGONAL (COUPLING COMES FROM THE ONE EXISTENT BETWEEN MODAL FORCES.)'/ ) +! 11 format ( ' ITRAN = ', 1I1, & +! ' : TRANSFER MATRIX COMPUTED ACCOUNTING FOR COUPLING (COMING FROM NON-PROPORTIONAL DAMPING.)'/ ) +! 12 format ( ' ITRAN = ', 1I1, & +! ' : TRANSFER MATRIX COMPUTED ACCOUNTING FOR COUPLING (SYMPLIFIED METHOD.)'/ ) + +! ! stocap ( french translation ) +! 13 format( ' ITRAN = ', 1I1, & +! ' : MATRICE DE TRANSFERT SUPPOSEE DIAGONALE'/ & +! ' (LE COUPLAGE PROVIENT DE CELUI EXISTANT ENTRE F.GEN.)'/ ) +! 14 format( ' ITRAN = ', 1I1, & +! ' : MATRICE DE TRANSFERT CALCULEE AVEC COUPLAGE'/ & +! ' (PROVENANT DE L''AMORTISSEMENT NON PROPORTIONNEL)'/ ) +! 15 format( ' ITRAN = ', 1I1, & +! ' : MATRICE DE TRANSFERT CALCULEE AVEC COUPLAGE'/ & +! ' (METHODE SIMPLIFIEE)'/ ) + + +! if ( logger%iun_ == 6 ) then + +! if (itran==3) then +! write(logger%iun_, 13), itran +! elseif (itran==2) then +! write(logger%iun_, 14), itran +! elseif ( itran==4) then +! write(logger%iun_, 15), itran +! endif + +! else + +! if (itran==3) then +! write(logger%iun_, 10), itran +! elseif (itran==2) then +! write(logger%iun_, 11), itran +! elseif ( itran==4) then +! write(logger%iun_, 12), itran +! endif +! endif +! end subroutine LogTransFuncType + + + + + + + + +! subroutine LogMaxValueType(logger, ityp, T) +! class(logger_t), intent(in) :: logger +! integer, intent(in) :: ityp +! real, intent(in) :: T +! ! local +! character(len = 40) :: typ_max + +! 10 format ( /' TYPE DU MAXIMUM : ', A40 ) +! 11 format ( ' DUREE OBSERVATION : ', 1F8.3 ) + +! if (ityp==0) then +! typ_max='GAUSS : G = 3' +! elseif (ityp==1) then +! typ_max='POISSON - CALCUL DE LA LARGEUR DE BANDE' +! elseif (ityp==2) then +! typ_max='VANMARCKE - POISSON MODIFIE' +! elseif (ityp==3) then +! typ_max='POISSON - PROCESSUS EN BANDE ETROITE' +! elseif (ityp==4) then +! typ_max='G - IMPOSE' +! endif + +! write( logger%iun_, 10 ) typ_max +! IF (ityp==1.OR.ityp==2) write( logger%iun_, 11 ), T +! end subroutine LogMaxValueType + + + + + +! subroutine LogElementWindLoad(logger, w, interv, y_c, z_c) +! class(logger_t), intent(in) :: logger +! real, intent(in) :: w ! element's width +! real, intent(in) :: interv ! delta_I ( incidence angle ) for derivative computation +! real, intent(in) :: y_c, z_c ! Y and Z coordinates of Center (cross-section) point + +! 10 format( /, 25X,& +! ' CHARGE DE VENT SUR L ELEMENT ',/, 25x, & +! ' ---------------------------- ',/, 25x, & +! ' MAITRE COUPLE : ',F10.4,/, 25x, & +! ' INTERVALLE POUR CALCUL DERIVEE : ',F10.4,/, 25x, & +! ' POSITON CENTRE M.C. : YFV = ', F10.4, ' ZFV = ', F10.4 ) + +! write(logger%iun_, 10), w, interv, y_c, z_c +! end subroutine LogElementWindLoad + + + + + +! subroutine LOgDLMWindCoeffs(logger, n_coefs, ai, cx, cz, cm) +! class(logger_t), intent(in) :: logger +! integer, intent(in) :: n_coefs ! num of coeffs ( for given incidence angle ) +! real, intent(in), dimension(:) :: ai ! angles of incidence ( given ) ( ERS ) +! real, intent(in), dimension(:) :: cx, cz, cm ! wind DRAG/LIFT/MOMENT coeffs (in GWRS ) +! ! local +! integer i + +! 10 format( & +! 25x, ' COEFFICIENTS DE TRAINEE ET PORTANCE',/, & +! 25X, ' I Y Z M ', /, & +! (25x, 4F10.4) ) + +! write(logger%iun_, 10), (ai(i), cx(i), cz(i), cm(i), i = 1, n_coefs) +! end subroutine LOgDLMWindCoeffs + + + + + + + +! subroutine LogElementWindIncidenceAngles(logger, ai0, ain1, ain2) +! class(logger_t), intent(in) :: logger +! real, intent(in) :: ai0 ! mean incidence angle +! real, intent(in) :: ain1 ! ?? +! real, intent(in) :: ain2 ! ?? + +! 10 format( 25X, ' ANGLES D INCIDENCE : I0= ', g12.5, ' I1= ', g12.5, ' I2= ', g12.5 ) +! write(logger%iun_, 10), ai0, ain1, ain2 +! end subroutine LogElementWindIncidenceAngles + + + + + + + +! subroutine LogElemWindNodalVel(logger, u1, u2) +! implicit none +! class(logger_t), intent(in) :: logger +! real, intent(in) :: u1, u2 + +! 10 format( 25X,' VITESSES : U1= ',F10.2,' U2= ',F10.2 ) +! write(logger%iun_, 10), u1, u2 +! end subroutine LogElemWindNodalVel \ No newline at end of file diff --git a/src/BsaLib/IO/io.f90 b/src/BsaLib/IO/io.f90 new file mode 100644 index 0000000..5cc3d87 --- /dev/null +++ b/src/BsaLib/IO/io.f90 @@ -0,0 +1,276 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_IO + + use BsaLib_CONSTANTS + implicit none + public + private :: setDefFileNameFromUnitNum_ + + + !************************************************************************** + ! I/O UNITs (mutables) + !************************************************************************** + ! dumpfile + integer(kind = 4) :: unit_dump_bfm_ = 999 + integer(kind = 4) :: unit_dump_brm_ = 1204 + + ! debug + integer(kind = 4) :: unit_debug_ = 99999 + character(len = :), allocatable :: undebug_fname_ + + + !************************************************************************** + ! EXPORTING STATE VARIABLES + !************************************************************************** + character(len = :), allocatable :: exp_dir_ ! either export, or default (out) if none set. + logical :: export_in_cwd_ = .true. + + ! NOTE: might be private.. + character(len = :), private, allocatable :: export_file_access_ + character(len = :), private, allocatable :: export_file_action_ + character(len = :), private, allocatable :: export_file_async_ + character(len = :), private, allocatable :: export_file_buffrd_ + character(len = :), private, allocatable :: export_file_form_ + character(len = :), private, allocatable :: export_file_position_ + character(len = :), private, allocatable :: export_file_status_ + +contains + + + + subroutine io_setExportAppendMode(imode) + integer(kind = 4), intent(in) :: imode + + if (imode == BSA_EXPORT_MODE_APPEND) then + export_file_position_ = IO_POSITION_APPEND + elseif (imode == BSA_EXPORT_MODE_REPLACE) then + export_file_status_ = IO_STATUS_REPLACE ! overrides if exists. + endif + end subroutine + + + subroutine io_setExportDirectory(dirname) + !! Sets export directory to a different path than outdir. + character(len = *), intent(in) :: dirname + + exp_dir_ = appendFilesep(dirname) + end subroutine + + + subroutine io_setExportInCurrDir() + export_in_cwd_ = .true. + end subroutine + + + subroutine io_setExportPathPrefix() + if (export_in_cwd_ .or. .not.allocated(exp_dir_)) exp_dir_ = '' + end subroutine + + + + subroutine io_setExportFileFormat(iform) + integer(kind = 4), intent(in) :: iform + + if (iform == BSA_EXPORT_FORMAT_FORMATTED) then + export_file_form_ = IO_FORM_FORMATTED + elseif (iform == BSA_EXPORT_FORMAT_UNFORMATTED) then + export_file_form_ = IO_FORM_UNFORMATTED + endif + end subroutine + + + + + subroutine io_exportMomentToFile(fname, vec, form) + character(len = *), intent(in) :: fname + real(kind = 8), intent(in) :: vec(:) + character(len = *), intent(in), optional :: form + integer :: iun, i, dim + character(len = :), allocatable :: exp_form_ + + exp_form_ = export_file_form_ + if (present(form)) export_file_form_ = form + + iun = io_openExportFileByName(exp_dir_ // fname) + if (iun == 0) return + dim = size(vec) + if (export_file_form_ == IO_FORM_FORMATTED) then + write(iun, *) dim + do i = 1, dim + write(iun, *) vec(i) + enddo + else + write(iun) dim + do i = 1, dim + write(iun) vec(i) + enddo + endif + close(iun) + + if (present(form)) call io_setExportDefaultSpecifiers() + end subroutine + + + + + subroutine io_setExportSpecifiers() + if (.not. allocated(export_file_access_)) export_file_access_ = IO_ACCESS_SEQUEN + if (.not. allocated(export_file_action_)) export_file_action_ = IO_ACTION_WRITE + if (.not. allocated(export_file_async_)) export_file_async_ = IO_ASYNC_NO + if (.not. allocated(export_file_buffrd_)) export_file_buffrd_ = IO_BUFFERED_NO + if (.not. allocated(export_file_form_)) export_file_form_ = IO_FORM_FORMATTED + if (.not. allocated(export_file_position_)) export_file_position_ = IO_POSITION_ASIS + if (.not. allocated(export_file_status_)) export_file_status_ = IO_STATUS_UNKNOWN + end subroutine + + + + + subroutine io_setExportDefaultSpecifiers() + export_file_access_ = IO_ACCESS_SEQUEN + export_file_action_ = IO_ACTION_WRITE + export_file_async_ = IO_ASYNC_NO + export_file_buffrd_ = IO_BUFFERED_NO + export_file_form_ = IO_FORM_FORMATTED + export_file_position_ = IO_POSITION_ASIS + export_file_status_ = IO_STATUS_UNKNOWN + end subroutine + + + + + function io_openExportFileByName(file) result(iun) + !! Opens a file, returning its intenal integer unit descriptor. + character(len = *), intent(in) :: file + integer :: iun + integer :: ierr_ + + open(newunit=iun, file=file & + , iostat=ierr_ & + , access=export_file_access_ & + , action=export_file_action_ & + , asynchronous=export_file_async_ & + , buffered=export_file_buffrd_ & + , form=export_file_form_ & + , position=export_file_position_ & + , status=export_file_status_) + + + if (ierr_ == 0) return + + iun = 0 + print '(/ 1x, a, a, a, """.")', & + ERRMSG, '@IO::io_openExportFileByName() : error trying opening export file "', file + print '(1x, a, a, i0)', & + MSGCONT, 'Exiting with status ', ierr_ + end function + + + + subroutine io_getVerifiedFile(iun, fname, openfile) + integer(kind = 4), intent(inout) :: iun + character(len = *), intent(inout) :: fname + logical, intent(in), optional :: openfile + logical :: is_opn + + ! BUG: maybe throw an error + if (iun == 0) return + + ! VERIFY UNIT + ! IF is open, it mean it is already in use -> use it! + ! NOTE: get its actual name! + inquire(unit=iun, opened=is_opn) + if (is_opn) then + inquire(unit=iun, name=fname) + return + endif + + + ! VERIFY FILENAME (and unit by consequence) + ! NOTE: unit not opened + + inquire(file=fname, opened=is_opn) + + ! set default name. + ! Since unic unit, surely name is available. However, double check + if (is_opn) then + + ! first check by setting default filename (accounts for unit number) + fname = setDefFileNameFromUnitNum_(iun) + inquire(file=fname, opened=is_opn) + + do while (is_opn) + + ! invalid first default name, increment unit number + iun = iun + 1 + + fname = setDefFileNameFromUnitNum_(iun) + inquire(file=fname, opened=is_opn) + + ! if valid filename, yet check if valid unit + ! If not open, we found combination. + if (.not. is_opn) Then + inquire(unit=iun, opened=is_opn) + endif + enddo + endif + + if (present(openfile) .and. openfile) then + open(unit=iun, file=fname & + , status='replace' & + , form='formatted' & + , access='sequential' & + , action='write') + endif + end subroutine + + + + + function setDefFileNameFromUnitNum_(iun) result(fname) + integer(kind = 4), intent(in) :: iun + character(len = :), allocatable :: fname + character(len = 64) :: tmpfname + + write(unit=tmpfname, fmt='(a, i0, a)') BSA_OUT_FILENAME_PREFIX_DEFAULT_, iun, '.bsa' + fname = tmpfname(1 : len_trim(tmpfname)) + end function + + + + + function appendFilesep(path) result(res) + character(len = *), intent(in) :: path + character(len = :), allocatable :: res + character(len = 1) :: filesep + integer :: ilen + + ilen = len_trim(path) +#ifdef _WIN32 + filesep = '\' +#else + filesep = '/' +#endif + if (path(ilen:ilen) == filesep) then + res = path + else + res = path//filesep + endif + end function + + +end module \ No newline at end of file diff --git a/src/BsaLib/bsa/BsaLibImpl.f90 b/src/BsaLib/bsa/BsaLibImpl.f90 new file mode 100644 index 0000000..08271ce --- /dev/null +++ b/src/BsaLib/bsa/BsaLibImpl.f90 @@ -0,0 +1,2008 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib) BsaLib_Impl + +#include "../precisions" + + use BsaLib_Data + use BsaLib_Utility + implicit none + + character(len = :), allocatable :: out_dir_ ! output directory + + logical :: only_diag_elems_ = .false. + logical :: is_only_msh_ = .false. + + +contains + + + + subroutine bsa_openFileHandles_() + !! BUG: not really adapted to logic... + + ! DEBUG unit + if (.not. allocated(undebug_fname_)) & + undebug_fname_ = 'bsadebug.bsa' + call io_getVerifiedFile(unit_debug_, undebug_fname_) + open(unit=unit_debug_, file=undebug_fname_, & + status='replace', form='formatted', action='write') + end subroutine + + + + + module subroutine bsa_Init() + integer(kind = 4) :: istat + character(len = 256) :: emsg + + if (.not. header_called_) call bsa_printBSAHeader() + + ! if (.not. allocated(out_dir_)) out_dir_ = BSA_OUT_DIRNAME_DEFAULT + ! istat = util_createDirIfNotExist(out_dir_) + + call bsa_openFileHandles_() + + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@BsaLib::bsa_Init() : bsa initialisation...' +#endif + + if (.not. allocated(settings)) then + allocate(settings, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('settings', loc(settings), sizeof(settings)) +#endif + else + call allocKOMsg('settings', istat, emsg) + endif + endif + + if (.not. allocated(wd)) then + allocate(wd, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('wd', loc(wd), sizeof(wd)) +#endif + else + call allocKOMsg('wd', istat, emsg) + endif + endif + + if (.not. allocated(struct_data)) then + allocate(struct_data, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('struct_data', loc(struct_data), sizeof(struct_data)) +#endif + else + call allocKOMsg('struct_data', istat, emsg) + endif + endif + + if (.not. allocated(timer)) then + allocate(timer, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('timer', loc(timer), sizeof(timer)) +#endif + else + call allocKOMsg('timer', istat, emsg) + endif + endif + + + if (.not. allocated(logger_debug)) then + allocate(logger_debug, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('logger_debug', loc(logger_debug), sizeof(logger_debug)) +#endif + else + call allocKOMsg('logger_debug', istat, emsg) + endif + endif + call logger_debug%init(unit_debug_, undebug_fname_) + + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@BsaLib::bsa_Init() : bsa initialisation -- ok.' +#endif + end subroutine + + + + module subroutine bsa_forceBsaClsExecution(bool) + logical, intent(in) :: bool + force_cls_execution_ = bool + end subroutine + + + + module subroutine bsa_setMaxBkgPeakRestriction(bool) + logical, intent(in) :: bool + do_restrict_bkgpeak_ = bool + end subroutine + + + + + module subroutine bsa_setPODTruncationThreshold(rval) + real(kind = 8), intent(in) :: rval + + if (rval > 0.d0) then + do_trunc_POD_ = .true. + POD_trunc_lim_ = rval / 100.d0 + endif + end subroutine + + + + + module subroutine bsa_Run(m2mf_cls, m2mr_cls, m2o2mr_cls, m3mf_msh, m3mr_msh, m3mf_cls, m3mr_cls) + use BsaLib_Functions + real(RDP), target, allocatable, dimension(:) :: & + m2mf_cls, m2mr_cls, m2o2mr_cls, m3mf_msh, m3mr_msh, m3mf_cls, m3mr_cls + + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@BsaLibImpl::run() : MAIN...' +#endif + + ! user asked for nothing ?? + if (settings%i_compute_psd_ == 0 .and. settings%i_compute_bisp_ == 0) then + print '(1x, 2a)', & + WARNMSG, 'Both PSD and BISP computation are disabled.' + return + endif + + + print * + block + integer(kind = 4) :: itmp + + call logger_debug%init(unit_debug_) ! setting up logger + call io_setExportSpecifiers() + + ! check before doing some bad things.. + call validateAll_() + + ! NOTE: recall this function since validateAll_() might have changed some.. + call setBsaFunctionLocalVars() + + +#ifdef __BSA_CL +# ifdef __BSA_USE_CUDA + call bsacl_AcquirePSDId(wd%i_psd_type_) +# endif + call bsacl_AcquireStructModMat(struct_data%modal_%phi_, struct_data%modal_%nat_freqs_) + call bsacl_AcquireLoadedNodesList(struct_data%n_load_) + call bsacl_AcquireTotalNOfNodes(struct_data%nn_) + call bsacl_AcquireUsedModesList(struct_data%modal_%modes_) + call bsacl_AcquireWindCoeffs(wd%wfc_) + call bsacl_AcquirePhiTimesCMat(PHItimesC_local_) + call bsacl_AcquireTurbComponentsList(wd%tc_) + call bsacl_AcquireEvaluationFunc(evaluatePSD) + call bsacl_AcquireNodalCorrelation(wd%nod_corr_) + + call bsacl_AcquireWindNodalVelocities(wd%u_node_) + call bsacl_AcquireWindNodalWindZones(wd%wz_node_) + call bsacl_AcquireWindTurbScales(wd%turb_scales_wz_, wd%nz_) + call bsacl_AcquireWindTurbStd(wd%sigmaUVW_wz_, wd%nz_) + + call bsacl_SetDeviceType(BSACL_DEVICE_TYPE_GPU) + + call bsacl_Init(ierr_cl_) + if (ierr_cl_ /= 0) goto 998 +#endif + + ! OK. check done. + if (settings%i_only_diag_ == 1) then + + only_diag_elems_ = .true. + + itmp = struct_data%nn_load_ * struct_data%nlibs_load_ + dimNf_psd_ = itmp + dimNf_bisp_ = itmp + dimM_psd_ = struct_data%modal_%nm_eff_ + dimM_bisp_ = dimM_psd_ + itmp = struct_data%nn_ * struct_data%ndofs_ + dimNr_psd_ = itmp + dimNr_bisp_ = itmp + + + ! classic fct pointers + getBFM_vect_cls => getFM_diag_tnlm_vect_cls_ + getBRM_vect_cls => getRM_diag_vect_cls_ + + getBFM_scalar_cls => getFM_diag_tnlm_scalar_cls_ + getBRM_scalar_cls => getRM_diag_scalar_cls_ + + + ! mesher fct pointers + getBFM_msh => getFM_diag_tnm_scalar_msh_ + getBRM_msh => getRM_diag_scalar_msh_ + + else ! == 0, full + + itmp = struct_data%nn_load_ * struct_data%nlibs_load_ + dimNf_psd_ = itmp * itmp ! itmp^2 + dimNf_bisp_ = dimNf_psd_ * itmp ! itmp^3 + + dimM_psd_ = struct_data%modal_%nm_eff_**2 + dimM_bisp_ = dimM_psd_ * struct_data%modal_%nm_eff_ ! nm^3 + + itmp = struct_data%nn_ * struct_data%ndofs_ + dimNr_psd_ = itmp * itmp + dimNr_bisp_ = itmp * dimNr_psd_ + + + ! classic fct pointers + getBFM_vect_cls => getFM_full_tnm_vect_cls_ + getBRM_vect_cls => getRM_full_vect_cls_ + + getBFM_scalar_cls => getFM_full_tnm_scalar_cls_ + getBRM_scalar_cls => getRM_full_scalar_cls_ + + + ! mesher fct pointers + if (settings%i_use_svd_ == 0) then + getBFM_msh => getFM_full_tnm_scalar_msh_ + else + getBFM_msh => getFM_full_tm_scalar_msh_POD_ + endif + getBRM_msh => getRM_full_scalar_msh_ + end if + + + if (.not. do_export_brm_ .and. .not. associated(write_brm_fptr_)) & + write_brm_fptr_ => exportBRM_void_internal_ + + +#ifdef __BSA_CL + settings%i_suban_type_ = 1 ! force CLS execution + settings%i_compute_bisp_ = 1 + settings%i_compute_psd_ = 0 +#endif + +#ifdef __BSA_CHECK_NOD_COH_SVD + settings%i_suban_type_ = 2 ! force MSH execution +#endif + + is_only_msh_ = settings%i_suban_type_ == 2 + if (is_only_msh_ .or. settings%i_suban_type_ == 3) & + call mainMesher_(m3mf_msh, m3mr_msh) + +#ifdef __BSA_CHECK_NOD_COH_SVD + goto 998 +#endif + + ! NOTE: in case we cannot have 2nd order moments, force it here + if (.not. is_only_msh_ .or. force_cls_execution_) then + if (is_only_msh_) then ! only 2nd order stats + settings%i_compute_bisp_ = 0 + settings%i_compute_psd_ = 1 + endif + call mainClassic_(m2mf_cls, m2mr_cls, m2o2mr_cls, m3mf_cls, m3mr_cls) + endif + end block + + 998 continue +#ifdef __BSA_CL + call bsacl_Finalise() + if (ierr_cl_ /= BSACL_PROBLEM_DIMENSIONS_TOO_SMALL) then + if (ierr_cl_ == 0) then + print '(1x, 2a)', INFOMSG, " BSACL returned correctly." + else + call bsa_Abort(" BSACL returned with error.") + endif + endif +#endif + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@BsaLibImpl::run() : MAIN -- ok.' +#endif + end subroutine bsa_Run + + + + + + + subroutine validateAll_() + ! character(len=64) :: msg + +! #ifdef __BSA_DEBUG + character(len=64) :: fmt + character(len=64) :: fmt2 + integer(kind = 4) :: i + + + write(unit_debug_, *) INFOMSG//'@BsaLibImpl::CheckVars() : log checking internal variables...' +! #endif + + ! ====================== + ! GENERAL + ! ====================== + call setExportPathPrefix_() + + + ! ====================== + ! SETTINGS + ! ====================== +! #ifdef __BSA_DEBUG + write(fmt, '(a)') '(" - ", a, i10)' + + write(unit_debug_, *) '### settings:' + write(unit_debug_, fmt) 'SUBANALYSIS TYPE = ', settings%i_suban_type_ + write(unit_debug_, fmt) 'VERSION = ', settings%i_vers_ + write(unit_debug_, fmt) 'CONVENTION USED = ', settings%i_def_scaling_ + write(unit_debug_, fmt) 'COMPUTE PSDs = ', settings%i_compute_psd_ + write(unit_debug_, fmt) 'COMPUTE BISP = ', settings%i_compute_bisp_ + write(unit_debug_, fmt) 'ONLY DIAG ELEMENTS = ', settings%i_only_diag_ + write(unit_debug_, fmt) 'TESTING MODE = ', settings%i_test_mode_ + write(unit_debug_, fmt) 'DUMP MODAL INFO = ', settings%i_dump_modal_ + + write(unit_debug_, fmt) 'USE BISP SYM = ', settings%i_bisp_sym_ + write(unit_debug_, fmt) 'USE 3D MATRIX SYM = ', settings%i_3d_sym_ + write(unit_debug_, fmt) 'N. OF FREQUENCIES = ', settings%nfreqs_ + write(unit_debug_, '(" - ", a, g10.5)') 'DELTA FREQ = ', settings%df_ + + write(unit_debug_, fmt) 'USE "SVD" DECOMP = ', settings%i_use_svd_ + write(unit_debug_, fmt) 'BKG_AERA_EXT = ', settings%bkg_area_extension_ + write(unit_debug_, fmt) 'BKG_BASE_RFMT = ', settings%bkg_base_rfmnt_ + write(unit_debug_, fmt) 'GEN_PEAK_AREA_EXT = ', settings%gen_peak_area_extension_ + write(unit_debug_, fmt) 'MAX AREA EXTENSION = ', settings%max_area_extension_ + write(unit_debug_, fmt) 'DO FULL COVERAGE = ', settings%i_full_coverage_ + ! write(unit_debug_, fmt) 'ROUNDING PRECISION = ', settings%i_round_prec_ +! #endif + + + if (POD_trunc_lim_ == 0.d0 .or. POD_trunc_lim_ == 1.d0) do_trunc_POD_ = .false. + if (I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ <= 0) I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 2 + if (I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ <= 0) I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 3 + + associate(ibispsym => settings%i_bisp_sym_) + if (.not. (ibispsym == 1 .or. ibispsym == 2 .or. ibispsym == 4)) then + print '(1x, a, a, i0)', WARNMSG, 'Unsupported value "iBispSym"= ', ibispsym + print '(1x, a, a)', MSGCONT, 'Valid values are: 1 (FULL, default), 2, 4.' + print '(1x, a, a)', MSGCONT, 'Setting default value.' + ibispsym = 1 + endif + + if (ibispsym == 4 .and. settings%i_3d_sym_ == 1) then + print '(1x, a, a)', WARNMSG, 'Cannot use 3D matrix symmetry if computing only 1/4 in space.' + print '(1x, a, a)', MSGCONT, 'Disabling it..' + settings%i_3d_sym_ = 0 + endif + end associate + + + ! ====================== + ! STRUCTURE + ! ====================== + + if (struct_data%ndofs_ == 0) struct_data%ndofs_ = struct_data%nn_ * struct_data%nlibs_ + + if (do_validate_modal_) call validateModalInfo_() + +! #ifdef __BSA_DEBUG + write(unit_debug_, *) '### structure:' + write(unit_debug_, fmt) 'NLIBS = ', struct_data%nlibs_ + write(unit_debug_, fmt) 'NNODES = ', struct_data%nn_ + write(unit_debug_, fmt) 'NDOFS = ', struct_data%ndofs_ + + write(unit_debug_, fmt) 'NLIBS LOADED = ', struct_data%nlibs_load_ + write(unit_debug_, '(*(i5))') struct_data%libs_load_ + + write(unit_debug_, fmt) 'NODES LOADED = ', struct_data%nn_load_ + write(unit_debug_, '(*(10i5))') struct_data%n_load_ + + ! BUG: only actual loaded nodes are saved !! + write(fmt2, '(a)') '( " - ", a)' + write(unit_debug_, fmt2) 'NODAL COORDS = ' + write(fmt2, '(a)') '( "n.", i5, ":", 3(2x, g10.4) )' + do i = 1, struct_data%nn_ + write(unit_debug_, fmt2) i, struct_data%coords_(:, i) + enddo + + ! modal + write(unit_debug_, fmt) 'N. MODES = ', struct_data%modal_%nm_ + write(unit_debug_, fmt) 'N. MODES EFF = ', struct_data%modal_%nm_eff_ + + write(fmt2, '(a)') '( " - ", a, /, *(g10.4) )' + write(unit_debug_, fmt2) 'MODES KEPT = ', struct_data%modal_%modes_ + write(unit_debug_, fmt2) 'NAT. FREQS = ', struct_data%modal_%nat_freqs_ + + + write(fmt2, '(a, i5, a)') ' ( " - ", a, /, *(', struct_data%modal_%nm_, '(2x, g12.6), /) )' + + ! WARNING: creates a temporary array.. + write(unit_debug_, fmt2) 'MOD. MAT = ', (struct_data%modal_%phi_(i, :), i = 1, struct_data%ndofs_) + + write(unit_debug_, fmt2) 'M* = ', struct_data%modal_%Mm_ + write(unit_debug_, fmt2) 'K* = ', struct_data%modal_%Km_ + + ! WARNING: creates a temporary array.. + write(unit_debug_, fmt2) 'C* = ', (struct_data%modal_%Cm_(i, :), i = 1, struct_data%modal_%nm_) + + write(unit_debug_, fmt2) 'XSI = ', struct_data%modal_%xsi_ +! #endif + + + if (.not. allocated(struct_data%bkg_peak_width_)) then + block + real(RDP) :: vtmp(3, 3, wd%nz_) + real(RDP) :: vtmp2(3, 3) + integer(kind = 4) :: itmp + + do itmp = 1, wd%nz_ + vtmp(:, :, itmp) = wd%turb_scales_wz_(:, :, itmp) / wd%u_mean_ref_wz_(itmp) + enddo + + vtmp2 = maxval(vtmp, dim=3) + + call struct_data%computeBKGPeakWidths(vtmp2) + end block + endif + + + ! ====================== + ! WIND + ! ====================== + + ! BUG: check correctly + if (.not. (allocated(wd%tc_) .and. allocated(wd%dirs_))) & + call wd%SetTurbCompsAndDirsDefault() + + if (.not. associated(wd%phi_times_A_ndegw_)) then + print '(1x, a, a)', & + WARNMSG, 'Using local PHItimesC instance.' + print '(1x, a, a /)', & + MSGCONT, 'Consider using external for less memory usage.' + call setPhitimesCLocalInstance_() + endif + +! #ifdef __BSA_DEBUG + write(unit_debug_, fmt) 'WIND ZONES = ', wd%nz_ + write(unit_debug_, fmt) 'PSD TYPE = ', wd%i_psd_type_ + write(unit_debug_, fmt) 'EQ. NOD. VEL= ', wd%i_eq_nod_wind_speed_ + write(unit_debug_, fmt) 'WIND PROF = ', wd%i_wind_prof_ + write(unit_debug_, fmt) 'WIND iVERT = ', wd%i_vert_ + + + write(unit_debug_, fmt) 'TURB COMP = ', wd%i_ntc_ + write(unit_debug_, '(*(i5))') wd%tc_ + + write(unit_debug_, fmt) 'WIND DIRS = ', wd%i_ndirs_ + write(unit_debug_, '(*(i5))') wd%dirs_ + + write(unit_debug_, fmt) 'WIND SPEEDS = ', size(wd%u_node_) + write(unit_debug_, '(*(10(" ", g10.4), /))') wd%u_node_ + + write(unit_debug_, fmt) 'NODE W. ZONE= ' + write(unit_debug_, '(*(10(" ", g10.4), /))') wd%wz_node_ + + write(unit_debug_, fmt) 'NODE W. ALT = ' + write(unit_debug_, '(*(10(" ", g10.4), /))') wd%wAlt_node_ + + + ! WARNING: creates temporary because of non-contiguous memory.. + write(unit_debug_, fmt) 'NODAL COHER = ', size(wd%nod_corr_, 1) + write(unit_debug_, '(*(10(" ", g10.4), /))') wd%nod_corr_(:, 1) + + + write(unit_debug_, fmt) 'W. F. C. = ' + write(fmt2, '( 2(a, i5), a)') ' ( ', size(wd%wfc_, 2), '(', size(wd%wfc_, 1), '(2x, g10.4), /) )' + do i = 1, size(wd%wfc_, 3) + write(unit_debug_, fmt2) wd%wfc_(:, :, i) + enddo + + + write(fmt2, '(a, i2, a)') '( ', wd%nz_, '( 3g10.4, 1x, / ) )' + write(unit_debug_, fmt) 'WZ. STD. DEV= ' + write(unit_debug_, fmt2) wd%sigmaUVW_wz_ + + write(fmt2, '(a, i2, a)') '( ', wd%nz_, '(g10.4, 1x), / )' + write(unit_debug_, fmt) 'WZ. ZREF = ' + write(unit_debug_, fmt2) wd%Zref_wz_ + + write(unit_debug_, fmt) 'WZ. UB ZREF = ' + write(unit_debug_, fmt2) wd%u_mean_ref_wz_ + + write(unit_debug_, fmt) 'WZ. INC ANG = ' + write(unit_debug_, fmt2) wd%incAng_wz_ + + write(fmt2, '(a, i2, a)') '( ', wd%nz_ + 1, '(g10.4, 1x), / )' + write(unit_debug_, fmt) 'WZ. LIMITS = ' + write(unit_debug_, fmt2) wd%limits_wz_ + + + + write(fmt2, '(a, i2, a)') '( ', wd%nz_, '( 3(3g12.4, 1x, /), / ) )' + write(unit_debug_, fmt) 'WZ. LXYZ = ' + write(unit_debug_, fmt2) wd%turb_scales_wz_ + + write(unit_debug_, fmt) 'WZ. CORR COF= ' + write(unit_debug_, fmt2) wd%corrCoeffs_wz_ + + write(unit_debug_, fmt) 'WZ. CORR EXP= ' + write(unit_debug_, fmt2) wd%corrExp_wz_ + + write(unit_debug_, fmt) 'WZ. lROTW2G = ' + write(unit_debug_, fmt2) wd%rot_LW2G_wz_ +! #endif + end subroutine validateAll_ + + + + !> Modal info validation step. + !> Mainly to avoid having mode shapes non 1-normalised + !> (i.e. modes in torsion, etc..) + !> NOTE: here is where NMODES_EFF is actually set. + !> Better not to give user the chance to do it. + subroutine validateModalInfo_() + real(RDP), dimension(struct_data%modal_%nm_) :: maxvals + integer(kind = 4) :: i, j, nskip, ilocmax(1), ilib + integer(kind = 4) :: nmk + integer(kind = 4), allocatable :: modesk(:) + integer(kind = 4) :: istat + character(len = 256) :: emsg + + maxvals = maxval(abs(struct_data%modal_%phi_), dim=1) + nskip = 0 + do i = 1, struct_data%modal_%nm_ + + if (maxvals(i) == 1._RDP) cycle + + ! ! NOTE: might also be greater than 1.. + ! if (maxvals(i) < 1._RDP .or. maxvals(i) > 1._RDP + incr) then + + print '(1x, a, a, i3, a)', & + WARNMSG, 'Mode ', i, ' is not 1-normalised. Ignoring it..' + + nskip = nskip + 1 + + ! check at which lib happens the MAX + ilocmax = maxloc(abs(struct_data%modal_%phi_(:, i)), kind = 4) + ilib = mod(ilocmax(1), struct_data%nlibs_) + if (ilib == 0) ilib = struct_data%nlibs_ + print '(1x, a, a, i0 /)', MSGCONT, 'Its local max abs value is for LIB= ', ilib + ! endif + enddo + + if (nskip == 0) then + struct_data%modal_%nm_eff_ = struct_data%modal_%nm_ + if (.not. allocated(struct_data%modal_%modes_)) call struct_data%SetKeptModesDefault() + return + endif + + ! we have found some mode shapes not 1-normalised + nmk = struct_data%modal_%nm_ - nskip + + allocate(modesk(nmk), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('modesk', int(nmk), loc(modesk), sizeof(modesk)) +#endif + else + call allocKOMsg('modesk', istat, emsg) + endif + + j = 1 + do i = 1, struct_data%modal_%nm_ + + if (maxvals(i) == 1._RDP) then + modesk(j) = i + j = j + 1 + endif + enddo + + struct_data%modal_%nm_eff_ = nmk + struct_data%modal_%modes_ = int(modesk, 4) + deallocate(modesk, stat=istat) + end subroutine validateModalInfo_ + + + + + + + !> This routine sets WindData PHItimesC variable + !> to point to a locally computed (and allocated) + !> instance, instead of externally acquired one. + !> This is to avoid memory error if NMODES_EFF < NMODES + !> but externally PHItimesC is allocated using NMODES. + subroutine setPhitimesCLocalInstance_() + integer(kind = 4) :: ndegw, nlib_l, nnodes_l, nmodes, ndofs + integer(kind = 4) :: id, in, im, n, m, skip + integer(kind = 4) :: istat + character(len = 256) :: emsg + + if (.not. associated(wd%wfc_)) & + call bsa_Abort('Wind force coefficients were not acquired. Aborting.') + + nlib_l = size(wd%wfc_, 1) + ndegw = size(wd%wfc_, 2) + nnodes_l= size(wd%wfc_, 3) + + if (nnodes_l /= struct_data%nn_load_) call bsa_Abort('N. of loaded nodes does not match.') + + if (nlib_l /= struct_data%nlibs_load_) call bsa_Abort('N. of loaded libs does not match.') + + if (.not. associated(struct_data%modal_%phi_)) call bsa_Abort('Modal matrix was not acquired. Aborting.') + + ndofs = size(struct_data%modal_%phi_, 1) + nmodes = size(struct_data%modal_%phi_, 2) + + if (ndofs /= struct_data%nn_ * struct_data%nlibs_) call bsa_Abort('Incorrect value for ndofs.') + + if (nmodes /= struct_data%modal_%nm_) & + call bsa_Abort('N. of modes does not match between local PHI instance and nm_ value.') + + if (struct_data%modal_%nm_eff_ == 0) & + call bsa_Abort('Effective number of modes to be kept is 0. Validate modal info before this step.') + + if (struct_data%nn_load_ == 0) call bsa_Abort('No nodes are loaded. Aborting.') + + allocate(PHItimesC_local_(struct_data%modal_%nm_eff_, nnodes_l, ndegw), & + stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('PHItimesC_local_', & + int([struct_data%modal_%nm_eff_, nnodes_l, ndegw]), loc(PHItimesC_local_), sizeof(PHItimesC_local_)) +#endif + else + call allocKOMsg('PHItimesC_local_', istat, emsg) + endif + PHItimesC_local_ = 0._RDP + + + do in = 1, nnodes_l + + n = struct_data%n_load_(in) + skip = (n - 1) * struct_data%nlibs_ + + do id = 1, ndegw + + do im = 1, struct_data%modal_%nm_eff_ + + m = struct_data%modal_%modes_(im) + + PHItimesC_local_(im, in, id) = PHItimesC_local_(im, in, id) + & + sum(wd%wfc_(:, id, in) * struct_data%modal_%phi_(skip + struct_data%libs_load_, m)) + enddo + enddo + enddo + +! #ifdef __BSA_DEBUG +! do id = 1, ndegw +! do im = 1, struct_data%modal_%nm_eff_ +! write(unit=1372, fmt='(*(1x, f12.5))') & +! PHItimesC_local_(im, :, id) +! enddo +! enddo +! #endif + + call wd%SetPhitimesC(PHItimesC_local_) + end subroutine setPhitimesCLocalInstance_ + + + + + + logical pure module function bsa_isCleaned() + bsa_isCleaned = is_data_cleaned_ + end function + + + + module subroutine bsa_Finalise() + call cleanBSAData_() + end subroutine bsa_Finalise + + + + + + + +!========================================================================================= +!========================================================================================= +!========================================================================================= +! +! SETTERS section +! +!========================================================================================= +!========================================================================================= +!========================================================================================= + + + + + module subroutine bsa_setOutputDirectory(dirname) + character(len=*), intent(in) :: dirname + + out_dir_ = appendFilesep(dirname) + end subroutine + + + module subroutine bsa_setExportDirectory(dirname) + !! Sets export directory to a different path than outdir. + character(len = *), intent(in) :: dirname + + call io_setExportDirectory(dirname) + end subroutine + + + module subroutine bsa_setExportInCurrDir() + call io_setExportInCurrDir() + end subroutine + + + module subroutine bsa_setOutUnit(iunit) + integer(kind = 4), intent(in) :: iunit + + unit_debug_ = iunit + end subroutine + + module subroutine bsa_setOutFileName(fname) + character(len=*), intent(in) :: fname + + undebug_fname_ = fname + end subroutine + + + + subroutine setExportPathPrefix_() + if (export_in_cwd_) then + exp_dir_ = '' + out_dir_ = '' + else + if (allocated(exp_dir_)) return + if (.not. allocated(out_dir_)) out_dir_ = BSA_OUT_DIRNAME_DEFAULT + exp_dir_ = out_dir_ + endif + end subroutine + + + + module subroutine bsa_setSpatialSymmetry(isym) + integer(kind = 4), intent(in) :: isym + + select case (isym) + case (BSA_SPATIAL_SYM_NONE) + settings%i_bisp_sym_ = isym + case (BSA_SPATIAL_SYM_FOUR) + settings%i_bisp_sym_ = isym + case default + if (.not. isym == BSA_SPATIAL_SYM_HALF) then + print '(1x, 2a, i0, a)', & + WARNMSG, 'Invalid ', isym, ' spatial symmetry value.' + print '(1x, 2a)', & + MSGCONT, 'Setting default (HALF).' + endif + settings%i_bisp_sym_ = BSA_SPATIAL_SYM_HALF + end select + end subroutine + + + module subroutine bsa_setBfmMLR(bool) + logical, intent(in) :: bool + + test_no_bfm_mlr_ = .not. bool + end subroutine + + + module subroutine bsa_setPremeshType(itype) + integer(kind = 4), intent(in) :: itype + + select case (itype) + case (BSA_PREMESH_TYPE_DIAG_CREST_YES) + ipre_mesh_type = itype + case default + if (.not. itype == BSA_PREMESH_TYPE_DIAG_CREST_NO) then + print '(1x, 2a, i0, a)', & + WARNMSG, 'Invalid ', itype, ' pre-meshing type value.' + print '(1x, 2a)', & + MSGCONT, 'Setting default (NO DIAG).' + endif + end select + end subroutine + + + module subroutine bsa_setPremeshMode(imode) + integer(kind = 4), intent(in) :: imode + + select case (imode) + case (BSA_PREMESH_MODE_BASE) + ipre_mesh_mode = imode + case default + if (.not. imode == BSA_PREMESH_MODE_ZONE_REFINED) then + print '(1x, 2a, i0, a)', & + WARNMSG, 'Invalid ', imode, ' pre-meshing mode value.' + print '(1x, 2a)', & + MSGCONT, 'Setting default (ZONE REFINED).' + endif + end select + end subroutine + + + + module subroutine bsa_doValidateModalData(bool) + logical, intent(in) :: bool + + do_validate_modal_ = bool + end subroutine + + + + ! module subroutine bsa_doValidateZoneDeltas(bool) + ! logical, intent(in) :: bool + + ! do_validate_deltas_ = bool + ! end subroutine + + + module subroutine bsa_setValidateDeltasPolicy(id) + integer, intent(in) :: id + + select case (id) + case (BSA_VALIDATE_DELTAS_POLICY_NONE) + do_validate_deltas_ = .false. + return + case (BSA_VALIDATE_DELTAS_POLICY_LIGHT) + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 2 + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 2 + case (BSA_VALIDATE_DELTAS_POLICY_MEDIUM) + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 3 + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 3 + case (BSA_VALIDATE_DELTAS_POLICY_HIGH) + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 4 + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 4 + case (BSA_VALIDATE_DELTAS_POLICY_STRICT) + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 5 + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 5 + case default + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 2 + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 3 + end select + + if (.not.do_validate_deltas_) & + do_validate_deltas_ = .true. + end subroutine + + + module subroutine bsa_setValidateDeltasValues(ibkg, ires) + integer, intent(in) :: ibkg, ires + + I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = ibkg + I_RES_PEAK_DELTAF_BFM_REFMT_FCT_ = ires + end subroutine + + + module subroutine bsa_closeUnitsAtEnd() + close_deb_unit_ = .true. + end subroutine + + + + module subroutine bsa_setExportFileFormat(iform) + integer(kind = 4), intent(in) :: iform + + call io_setExportFileFormat(iform) + end subroutine + + + module subroutine bsa_setExportAppendMode(imode) + integer(kind = 4), intent(in) :: imode + + call io_setExportAppendMode(imode) + end subroutine + + + + + + + + ! TODO: settings might be set via direct assignment ?? + + + !===================================== + ! SETTINGS + !===================================== + + + module elemental function bsa_isFullComp() result(bool) + logical :: bool + + bool = .not. only_diag_elems_ + end function + + + module subroutine bsa_setSubanType(isuban) + integer(kind = 4), intent(in) :: isuban + + call settings%SetSubanType(isuban) + end subroutine + + + module subroutine bsa_setVersion(ivers) + integer(kind = 4), intent(in) :: ivers + + call settings%SetVersion(ivers) + end subroutine + + + module subroutine bsa_setScalingConv(iconv) + integer(kind = 4), intent(in) :: iconv + + call settings%SetScalingType(iconv) + end subroutine + + + module subroutine bsa_setSpectraComputation(ipsd, ibisp) + integer(kind = 4), intent(in), optional :: ipsd, ibisp + + call settings%ActivateSpectraComputation(ipsd, ibisp) + end subroutine + + + + module subroutine bsa_setSpectraExtension(ionlydiag) + integer(kind = 4), intent(in) :: ionlydiag + + call settings%SetExtension(ionlydiag) + end subroutine + + module subroutine bsa_setTestMode(itest) + integer(kind = 4), intent(in) :: itest + + call settings%TestMode(itest) + end subroutine + + + module subroutine bsa_setSymmetries(ibispsym, i3dsym) + integer(kind = 4), intent(in) :: ibispsym, i3dsym + + call settings%setSymmetries(ibispsym, i3dsym) + end subroutine + + + module subroutine bsa_setupClassic(nfreqs, df) + integer(kind = 4), intent(in) :: nfreqs + real(RDP), intent(in) :: df + + call settings%setClsSettings(nfreqs, df) + end subroutine + + module subroutine bsa_setupMesher(isvd, bkgrfmt, bkgaext, genpaext, maxaext, ifcov, idumpmod) + integer(kind = 4), intent(in) :: isvd, bkgrfmt, maxaext + integer(kind = 4), intent(in) :: bkgaext, genpaext, ifcov, idumpmod + + call settings%SetMshrSetts(isvd, bkgrfmt, bkgaext, genpaext, maxaext, ifcov, idumpmod) + end subroutine + + + + + + + !===================================== + ! WIND DATA + !===================================== + + module subroutine bsa_setWindDirections(dirs, ndirs) + integer(kind = 4), intent(in) :: dirs(:) + integer(kind = 4), intent(in), optional :: ndirs + + call wd%setWindDirections(dirs, ndirs) + end subroutine + + + module subroutine bsa_setWindTurbComps(tc, ntc) + integer(kind = 4), intent(in) :: tc(:) + integer(kind = 4), intent(in), optional :: ntc + + call wd%setTurbComps(tc, ntc) + end subroutine + + + + module subroutine bsa_setWindVertProf(iwprof) + integer(kind = 4), intent(in) :: iwprof + call wd%SetWindvertProf(iwprof) + end subroutine + + + module subroutine bsa_setPSDType(ipsd) + integer(kind = 4), intent(in) :: ipsd + + call wd%SetPSDType(ipsd) + end subroutine + + + module subroutine bsa_setWindAltDir(ivert) + integer(kind = 4), intent(in) :: ivert + + call wd%SetMainVertDir(ivert) + end subroutine + + + module subroutine bsa_setWindZoneLimits(lim, ilim) + real(RDP), intent(in) :: lim(..) + integer(kind = 4), intent(in), optional :: ilim(..) + + call wd%SetWindZoneLimits(lim, ilim) + end subroutine + + + module subroutine bsa_setAirDensity(aird) + real(RDP), intent(in) :: aird + + call wd%SetAirDensity(aird) + end subroutine + + + module subroutine bsa_setGlobalRotMatW2G(rotW2G) + real(RDP), intent(in) :: rotW2G(3, 3) + + call wd%SetGlobalW2G(rotW2G) + end subroutine + + + module subroutine bsa_setWZMeanWindVel(mat) + real(RDP), target, intent(in) :: mat(:) + + call wd%SetWZMeanWindVel(mat) + end subroutine + + + module subroutine bsa_setWZRefAlt(Zref) + real(RDP), target, intent(in) :: Zref(:) + + call wd%SetWZRefAlt(Zref) + end subroutine + + + module subroutine bsa_setTurbWindScales(L) + real(RDP), target, intent(in) :: L(3, 3, *) + + call wd%SetTurbWindScales(L) + end subroutine + + + module subroutine bsa_setTurbWindSDT(sigma) + real(RDP), target, intent(in) :: sigma(3, *) + + call wd%SetTurbWindSDT(sigma) + end subroutine + + + module subroutine bsa_setWindCorrCoeffs(ccoeffs) + real(RDP), target, intent(in) :: ccoeffs(3, 3, *) + + call wd%SetWindCorrCoeffs(ccoeffs) + end subroutine + + + module subroutine bsa_setWindCorrExpnts(cexpn) + real(RDP), target, intent(in) :: cexpn(3, 3, *) + + call wd%SetWindCorrExpnts(cexpn) + end subroutine + + + module subroutine bsa_setIncidenceAngles(incang) + real(RDP), target, intent(in) :: incang(:) + + call wd%SetIncidenceAngles(incang) + end subroutine + + + module subroutine bsa_setWZRotMatW2G(rotW2G_L) + real(RDP), target, intent(in) :: rotW2G_L(3, 3, *) + + call wd%SetLocalRotMatW2G(rotW2G_L) + end subroutine + + + + module subroutine bsa_setNodalVel(Unod) + real(RDP), target, intent(in) :: Unod(:) + + call wd%SetNodalVel(Unod) + end subroutine + + + module subroutine bsa_setNodalWindZones(NodWZ) + integer(kind = 4), target, intent(in) :: NodWZ(:) + + call wd%SetNodalWindZones(NodWZ) + end subroutine + + + module subroutine bsa_setNodalWindAltitudes(WnodAlt) + real(RDP), target, intent(in) :: WnodAlt(:) + + call wd%SetNodalWindAltitudes(WnodAlt) + end subroutine + + + module subroutine bsa_setSpatialNodalCorr(nodCorr) + real(RDP), target, intent(in) :: nodCorr(:, :) + + call wd%SetSpatialNodalCorr(nodCorr) + end subroutine + + + + module subroutine bsa_setWindFCoeffs(wfc) + real(RDP), target, intent(in) :: wfc(:, :, :) + + call wd%SetWindFCoeffs(wfc) + end subroutine + + + + module subroutine bsa_setPhitimesC(phiTc) + real(RDP), target, intent(in) :: phiTc(:, :, :) + + call wd%SetPhitimesC(phiTc) + end subroutine bsa_setPhitimesC + + + + + !===================================== + ! NODAL DATA + !===================================== + + module subroutine bsa_setNodalCoords(nn, coords) + integer(kind = 4), intent(in) :: nn + real(RDP), target, allocatable :: coords(:, :) + + call struct_data%SetNodalCoords(nn, coords) + end subroutine + + + + module subroutine bsa_setNodalNOfDOFs(nlibs) + integer(kind = 4), intent(in) :: nlibs + + call struct_data%SetNOfNodalDOFs(nlibs) + end subroutine + + + + module subroutine bsa_setTotalNOfNodes(nn) + integer(kind = 4), intent(in) :: nn + + call struct_data%SetTotalNOfNodes(nn) + end subroutine + + + + module subroutine bsa_setLoadedNodalDOFs(libs_l, nlibs_l) + integer(kind = 4), intent(in), target, allocatable :: libs_l(:) + integer(kind = 4), intent(in), optional :: nlibs_l + integer(kind = 4) :: siz + + if (.not. allocated(libs_l)) return + + if (.not. present(nlibs_l)) then + siz = size(libs_l) + else + if (.not. (nlibs_l == size(libs_l))) & + call bsa_Abort('Passed number of loaded LIBs does not match size of array.') + siz = nlibs_l + endif + + call struct_data%SetLoadedNodalDOFs(siz, libs_l) + end subroutine + + + + module subroutine bsa_setLoadedNodes(nodes_l, nn_l) + integer(kind = 4), intent(in), target, allocatable :: nodes_l(:) + integer(kind = 4), intent(in), optional :: nn_l + integer(kind = 4) :: siz + + if (.not. allocated(nodes_l)) return + + if (.not. present(nn_l)) then + siz = size(nodes_l) + else + if (.not. (nn_l == size(nodes_l))) & + call bsa_Abort('Passed number of loaded LIBs does not match size of array.') + siz = nn_l + endif + + call struct_data%SetLoadedNodes(siz, nodes_l) + end subroutine + + + + + + + + + + !===================================== + ! MODAL DATA + !===================================== + + module subroutine bsa_setModalInfo(ndofs, nm, Phi, natf) + integer(kind = 4), intent(in) :: ndofs, nm + real(RDP), intent(in), target :: Phi(ndofs, nm), natf(nm) + + call struct_data%SetModalInfo(ndofs, nm, Phi, natf) + end subroutine + + + + module subroutine bsa_setModalMatrices(nm, Mgen, Kgen, Cgen) + integer(kind = 4), intent(in) :: nm + real(RDP), intent(in), target, dimension(nm) :: Mgen, Kgen + real(RDP), intent(in), target :: Cgen(nm, nm) + + call struct_data%SetModalMatrices(nm, Mgen, Kgen, Cgen) + end subroutine + + + module subroutine bsa_setKeptModalShapes(modes) + integer(kind = 4), intent(in) :: modes(:) + + call struct_data%SetKeptModes(modes) + end subroutine + + + + module subroutine bsa_setTotDamping(xsi) + real(RDP), target, intent(in) :: xsi(:) + + call struct_data%SetTotDamping(xsi) + end subroutine + + + module pure function bsa_getUsedModeShapes() result(modes) + integer(kind = 4), allocatable :: modes(:) + + modes = struct_data%modal_%modes_ + end function + + + +!========================================================================================= +!========================================================================================= +!========================================================================================= +! +! COMPUTING SECTION +! +!========================================================================================= +!========================================================================================= +!========================================================================================= + + + + + module subroutine bsa_computeBRdecomp(m2mf, bkg, res) + use BsaLib_Functions, only: getBR_SFm_val_ + real(RDP), intent(in) :: m2mf(:) + real(RDP), allocatable, intent(out) :: bkg(:), res(:) + + integer :: im, m + + associate(nm => struct_data%modal_%nm_eff_, modes => struct_data%modal_%modes_, & + Km => struct_data%modal_%Km_, f => struct_data%modal_%nat_freqs_) + + + block + integer :: istat + allocate(bkg(nm), stat=istat) + if (istat /= 0) then + print '(1x, a, a)', & + ERRMSG, 'Cannot allocate resources for BR decomposition computation. Skipping.' + return + endif + allocate(res(nm), stat=istat) + if (istat /= 0) then + print '(1x, a, a)', & + ERRMSG, 'Cannot allocate resources for BR decomposition computation. Skipping.' + return + endif + end block + + block + integer :: idim2, ipsd, ibisp, dimPSD, dimBSP, id + integer :: iun, idxi, idxe, itc_, idir_ + real(RDP) :: fnat, SFm_fnat, rtmp(1), Km_loc2_ + real(RDP), allocatable :: S_uvw(:, :), S_pad(:) + + + ! NOTE: backup this data, for later reset to right values + ! We want ONLY PSDs here.. + ipsd = settings%i_compute_psd_ + ibisp = settings%i_compute_bisp_ + dimPSD = dimM_psd_ + dimBSP = dimM_bisp_ + ! NOTE: force these values before calling "getBFM_scalar_cls" fct pointer. + dimM_psd_ = 1 + dimM_bisp_ = 1 + settings%i_compute_psd_ = 1 + settings%i_compute_bisp_ = 0 + + + + ! BUG: avoid code copy-paste !! + idim2 = struct_data%nn_load_ * wd%i_ndirs_ * wd%i_ntc_ + allocate(S_uvw(nm, idim2)) + allocate(S_pad(idim2)) + + idxi = 1 + idxe = struct_data%nn_load_ + do itc_ = 1, wd%i_ntc_ + + do idir_ = 1, wd%i_ndirs_ + + ! BUG: difference between idir and itc ??? + ! NOTE: done for all the loaded nodes at once ! + S_uvw(:, idxi:idxe) = wd%evalPSD(nm, f(modes), & + struct_data%nn_load_, struct_data%n_load_, wd%dirs_(idir_), wd%tc_(itc_)) + + idxi = idxe + 1 + idxe = idxe + struct_data%nn_load_ + enddo ! i direction + enddo ! i turb comp + + + ! do concurrent (im = 1 : nm) local(fnat, SFm_fnat, m, Km_loc2_) & + ! shared(bkg, res, Km, f, modes, S_pad, S_uvw, rtmp) + + ! m = modes(im) + ! Km_loc2_ = Km(m) + ! Km_loc2_ = Km_loc2_ * Km_loc2_ + + ! if (settings%i_only_diag_ == 1) then + ! bkg(im) = m2mf(im) / Km_loc2_ + ! else + ! id = (im-1)*nm + 1 + ! bkg(im) = m2mf(id) / Km_loc2_ + ! endif + + ! fnat = f(m) + + ! ! BUG: adapt back to use already existing procedures.. + ! ! call getBFM_scalar_cls(1, 1, fnat, 0.0_RDP, S_uvw, S_pad, SFm_fnat, rtmp) + ! call getBR_SFm_val_(nm, S_uvw, fnat, im, m, SFm_fnat) + ! if (settings%i_def_scaling_ == 1) SFm_fnat = SFm_fnat / CST_PIt4 + + ! res(im) = CST_PIGREC * CST_PIt2 * fnat * SFm_fnat & + ! / (2 * struct_data%modal_%xsi_(m) * Km_loc2_) + ! enddo + + do im = 1 , nm + + m = modes(im) + Km_loc2_ = Km(m) + Km_loc2_ = Km_loc2_ * Km_loc2_ + + if (settings%i_only_diag_ == 1) then + bkg(im) = m2mf(im) / Km_loc2_ + else + id = (im-1)*nm + im + bkg(im) = m2mf(id) / Km_loc2_ + endif + + + fnat = f(m) + ! call getBFM_scalar_cls(im, 1, fnat, 0.0_RDP, S_uvw, S_pad, SFm_fnat, rtmp) + call getBR_SFm_val_(nm, S_uvw, fnat, im, m, SFm_fnat) + ! if (settings%i_def_scaling_ == 1) SFm_fnat = SFm_fnat / CST_PIt4 + + res(im) = CST_PIGREC * CST_PIt2 * fnat * SFm_fnat & + / (2 * struct_data%modal_%xsi_(m) * Km_loc2_) + enddo + + ! reset old (right) values + settings%i_compute_psd_ = ipsd + settings%i_compute_bisp_ = ibisp + dimM_psd_ = dimPSD + dimM_bisp_ = dimBSP + + end block + end associate + + end subroutine bsa_computeBRdecomp + + + + + + + + module subroutine bsa_computePeakFactors(& + m2, m2o2, obs_time, peak_g, sk, peak_ng_pos, peak_ng_neg) + real(kind = 8), intent(in) :: m2(:), m2o2(:) + real(kind = 8), intent(in) :: obs_time + real(kind = 8), allocatable, intent(inout) :: peak_g(:) + real(kind = 8), intent(in), allocatable :: sk(:) + real(kind = 8), allocatable, intent(inout) :: peak_ng_pos(:) + real(kind = 8), allocatable, intent(inout), optional :: peak_ng_neg(:) + + !> Euler's constant + real(kind = 8), parameter :: gamma_ = 0.5772d0 + real(kind = 8), allocatable :: beta(:) + + if (all(m2o2 == 0)) then + print '(/ 1x, a, a)', & + WARNMSG, '"m2_ord2" is null. Cannot compute extremes. Skipping.' + return + endif + + beta = sqrt(m2o2 / m2) / CST_PIt2 * obs_time + if (any(beta < 1.d0)) then + print '(1x, a, f7.2, a)', & + WARNMSG, 'Observation time of ', obs_time, ' sec. is too short.' + return + endif + beta = sqrt(2 * log(beta)) + + peak_g = gamma_ / beta + peak_g = peak_g + beta + + if (allocated(sk)) then + + block + real(kind = 8), parameter :: PI2 = CST_PIGREC * CST_PIGREC + real(kind = 8), allocatable :: rtmp(:), g4(:), h3(:), h40(:), h4(:) + real(kind = 8), allocatable :: k(:), beta2(:), beta3(:), pk_ng_neg_(:) + + ! NOTE: excess kurtosis evaluated empirically + ! based on the "parabolic" relationship with + ! skewness coefficient, quite acceptable in Wind Engineering + ! (from conducted experiments). + ! However, in future, maybe estimate numerically g4 as well! + rtmp = sk * sk + g4 = CST_3d2 * rtmp + + ! NOTE: formulation based on Kwon-Kareem-2014-revisited paper (Eq. 1) + h40 = sqrt(1.d0 + 1.5d0 * g4) + h3 = sk / (4.d0 + 2.d0 *h40) + h4 = (h40 - 1.d0) / 18.0d0 + + ! ! NOTE: Revised Hermite Model improved formulation (Eqs. 7) + ! h40 = ((1 + 1.25d0 * g4)**(1.d0 / 3.d0) - 1.d0) / 10.d0 + ! h3 = sk / 6.d0 * (1.d0 - 0.015d0*abs(sk) + 0.3d0*rtmp) / (1.d0 + 0.2d0*g4) + ! h4 = h40 * (1.d0 - 1.43d0*rtmp/g4)**(1.d0 - 0.1d0 * g4**(0.8d0)) + + k = 1.d0 / (sqrt(1 + 2.d0*h3*h3 + 6.d0*h4*h4)) + beta2 = beta * beta + beta3 = beta2 * beta + + ! third term, multipliying h4 + peak_ng_pos = 5.44d0 / (beta3) + peak_ng_pos = peak_ng_pos + (3.d0 / beta * (PI2 / 6.d0 - gamma_ + (gamma_**2))) + peak_ng_pos = peak_ng_pos + (beta3 + 3*beta*(gamma_ - 1)) + peak_ng_pos = peak_ng_pos * h4 + + pk_ng_neg_ = peak_ng_pos + rtmp = h3 * (beta2 + 2.d0 * gamma_ - 1. + 1.98d0 / beta2) + peak_ng_pos = peak_ng_pos + rtmp + pk_ng_neg_ = pk_ng_neg_ - rtmp + + peak_ng_pos = peak_ng_pos + peak_g + peak_ng_pos = peak_ng_pos * k + + if (present(peak_ng_neg)) then + peak_ng_neg = pk_ng_neg_ + peak_g + peak_ng_neg = peak_ng_neg * k + endif + end block + endif + + end subroutine + + + + + + + + + +!========================================================================================= +!========================================================================================= +!========================================================================================= +! +! EXPORTING SECTION +! +!========================================================================================= +!========================================================================================= +!========================================================================================= + + + + module subroutine bsa_exportBR_nocompute_(fname, bkg, res, xsi) + !! BUG: adapt to a more general XSI management.. + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: bkg(:), res(:), xsi(:) + integer :: iun, im, j + ! integer :: s2 + + ! s2 = size(bkg, 2) + iun = io_openExportFileByName(fname) + if (iun == 0) call bsa_Abort() + write(iun, *) struct_data%modal_%nm_eff_ + write(iun, *) struct_data%modal_%modes_ + ! write(iun, *) s2 + ! do j = 1, s2 + write(iun, *) xsi(:) + do im = 1, struct_data%modal_%nm_eff_ + write(iun, *) bkg(im), res(im) + enddo + ! enddo + close(iun) + end subroutine + + + + + + module subroutine bsa_exportMomentToFile(fname, vec) + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: vec(:) + integer :: iun, i, dim + + iun = io_openExportFileByName(exp_dir_ // fname) + if (iun == 0) call bsa_Abort() + dim = size(vec) + write(iun, *) dim + do i = 1, dim + write(iun, *) vec(i) + enddo + close(iun) + end subroutine + + + + + module subroutine bsa_exportSkewness_nocompute_(fname, sk) + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: sk(:) + + associate(nm => struct_data%modal_%nm_eff_, modes => struct_data%modal_%modes_) + call exportSkewness_(fname, dimM_bisp_, sk, nm, modes) + end associate + end subroutine + + + + module subroutine bsa_exportSkewness_compute_(fname, m2, m3) + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: m2(:), m3(:) + real(RDP), allocatable :: sk(:) + + associate(nm => struct_data%modal_%nm_eff_, modes => struct_data%modal_%modes_) + sk = computeSkewness_(nm, m2, m3, only_diag_elems_) + call exportSkewness_(fname, dimM_bisp_, sk, nm, modes) + end associate + end subroutine + + + + + function computeSkewness_(dim, m2, m3, only_diag) result(sk) +#ifdef __BSA_DEBUG + use, intrinsic :: ieee_arithmetic +#endif + integer(kind = 4), intent(in) :: dim + real(RDP), intent(in) :: m2(:), m3(:) + logical, intent(in) :: only_diag + real(RDP), allocatable :: sk(:) + real(RDP), parameter :: cst3d2 = 3._RDP / 2._RDP + + if (only_diag) then + sk = m3 / (m2)**(cst3d2) + return + endif + + block + integer :: szm2, szm3 + integer :: pm3, pm2 + integer :: k, j, i, l + integer :: ik, ij, ii + integer :: s2 + + real(RDP), allocatable :: sigm(:) + real(RDP) :: denK, denJ + + ! s2 = size(m2, 2) + ! if (.not. size(m3, 2) == s2) then + ! print '(1x, a, a)', ERRMSG, '2nd size mismatch between m2 and m3. Skipping.' + ! return + ! endif + + szm2 = size(m2, 1) + szm3 = size(m3, 1) + + allocate(sk(szm3)) + sk = 0._RDP + + sigm = sqrt(m2) ! std + + ! do l = 1, s2 + + pm3 = 1 + ik = 1 + do k = 1, dim + + denK = sigm(ik) + + ij = 1 + do j = 1, dim + + denJ = denK * sigm(ij) + + ii = 1 + do i = 1, dim + + sk(pm3) = m3(pm3) / (denJ * sigm(ii)) + +#ifdef __BSA_DEBUG + if (ieee_is_nan(sk(pm3))) then + print '(1x, a, a, 2i6)', & + ERRMSG, 'SK is NaN at indexes ', pm3, l + goto 99 ! exit loop + endif +#endif + + pm3 = pm3 + 1 + ii = i * dim + i + 1 + enddo ! i modes + + ij = j * dim + j + 1 + enddo ! j modes + + ik = k * dim + k + 1 + enddo ! k modes + + ! enddo + + 99 continue + + end block + end function + + + + + + subroutine exportSkewness_(fname, dim, vec, nmodes, modes) + character(len = *), intent(in) :: fname + integer(kind = 4), intent(in) :: dim, nmodes + integer(kind = 4), intent(in) :: modes(nmodes) + real(RDP), intent(in) :: vec(:) + integer :: iun, i + + iun = io_openExportFileByName(exp_dir_ // fname) + if (iun == 0) call bsa_Abort() + + ! header + write(iun, *) nmodes + write(iun, *) modes + + ! actual data + write(iun, *) dim + do i = 1, dim + write(iun, *) vec(i) + enddo + close(iun) + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, 2a, " -- ok.")') & +! INFOMSG, '@::exportSkewness_() : writing to file ', fname +! #endif + end subroutine + + + + + + + module subroutine bsa_exportPeakOrExtremesToFile(fname, rvar) + character(len = *), intent(in) :: fname + real(RDP), intent(in) :: rvar(:) + integer :: ndofs, iun, i + + iun = io_openExportFileByName(fname) + if (iun == 0) call bsa_Abort() + + ndofs = size(rvar) + write(iun, *) ndofs + do i = 1, ndofs + write(iun, *) rvar(i) + enddo + close(iun) + end subroutine + + + + + ! BUG: should also providfe a way to pass pointer to user defined exporting data + ! structure that has to be finally dereferenced in actual exporting routine! + module subroutine bsa_setBRMExportFunction(fptr) +#ifdef __BSA_OMP + procedure(exportBRMinterf_vect_all_), pointer, intent(in) :: fptr +#else + procedure(exportBRMinterf_scalar_), pointer, intent(in) :: fptr +#endif + write_brm_fptr_ => fptr + + ! if user provides its own function, make sure it does not get overridden + i_brmexport_mode_ = BSA_EXPORT_BRM_MODE_USR + end subroutine + + + + + + subroutine exportBRM_void_internal_(f1, f2, brm, pdata) +#ifdef __BSA_OMP + real(kind = 8), intent(in) :: f1(:), f2(:), brm(:, :) +#else + real(kind = 8), intent(in) :: f1, f2, brm(:) +#endif + class(*), pointer, intent(in) :: pdata + + ! do nothing + end subroutine + + + + ! BUG: this should be called via a function pointer + subroutine exportBRM_baseHeaderWriter_internal_(pdata) + type(BrmExportBaseData_t), pointer, intent(in) :: pdata + + ! BUG: maybe general header written only ONCE in a separate procedure.. + ! do print general header + if (pdata%i_doNotPrintGenHeader_ == 0) then + write(unit_dump_brm_) pdata%nm_ + write(unit_dump_brm_) pdata%modes_ + write(unit_dump_brm_) pdata%ncomb_ + write(unit_dump_brm_) pdata%ispsym_ + write(unit_dump_brm_) pdata%nzones_ + endif + + ! do print zone info header + if (pdata%i_doNotPrintZonHeader_ == 0) then + write(unit_dump_brm_) pdata%idZone_ + write(unit_dump_brm_) pdata%nI_ + write(unit_dump_brm_) pdata%nJ_ + +! #ifdef __BSA_OMP +! print *, ' Dumping zone with id, ni, nj = ', & +! pdata%idZone_, pdata%nI_, pdata%nJ_ +! #endif + endif + end subroutine + + + + subroutine exportBRM_base_internal_(fi, fj, brm, pdata) +#ifdef __BSA_OMP + real(kind = 8), intent(in) :: fi(:), fj(:), brm(:, :) +#else + real(kind = 8), intent(in) :: fi, fj, brm(:) +#endif + class(*), pointer, intent(in) :: pdata + + ! Need to verify if to print headers + if (associated(pdata)) then + select type (pdata) + type is (BrmExportBaseData_t) + call exportBRM_baseHeaderWriter_internal_(pdata) + class default + call bsa_Abort("Expecting pdata to be of type ""BrmExportBaseData_t"".") + end select + endif + +#ifdef __BSA_OMP + block + integer :: i, siz + + siz = size(fi) + do i= 1, siz + write(unit_dump_brm_) real(fi(i), kind=4), real(fj(i), kind=4), real(brm(:, i), kind=4) + enddo + endblock +#else + write(unit_dump_brm_) real(fi, kind=4), real(fj, kind=4), real(brm, kind=4) +#endif + end subroutine + + + + + module subroutine bsa_setBRMExportDefaultMode(imode) + integer(kind = 4), intent(in) :: imode + integer(kind = 4) :: iost + + select case (imode) + + case (BSA_EXPORT_BRM_MODE_NONE) + return + + case default ! includes (BSA_EXPORT_BRM_MODE_BASE) + if (.not. imode == BSA_EXPORT_BRM_MODE_BASE) & + print '(1x, a, a)', WARNMSG, 'Unknown BRM export mode. Setting default (base).' + + do_export_brm_ = .true. + write_brm_fptr_ => exportBRM_base_internal_ + end select + + open(& + unit=unit_dump_brm_, & + file=brm_export_file_name_, & + form=IO_FORM_UNFORMATTED, & + access=IO_ACCESS_STREAM, & + status=IO_STATUS_REPLACE, & + iostat=iost) + + if (iost /= 0) then + print '(1x, 4a)', & + WARNMSG, 'Error while opening BRM export file "', brm_export_file_name_, '".' + print '(1x, 2a)', MSGCONT, 'Disabling exporting.' + do_export_brm_ = .false. + write_brm_fptr_ => null() + endif + end subroutine + + + + + module subroutine bsa_saveCoordinatesToFile(fname, coords) + character(len = *), intent(in) :: fname + real(RDP), intent(in), target, optional :: coords(:, :) + real(RDP), pointer :: coords_(:, :) + integer(kind = 4) :: iun, istat, i, nn_ + + if (.not. present(coords) .and. .not. associated(struct_data%coords_)) then + print '(1x, a, a)', & + WARNMSG, 'Cannot save coordinates to file. Data not provided. Skipping.' + return + endif + + ! TODO: adapt to output in BSA folder + open(unit=iun, file=fname, form='formatted', action='write', status='replace', & + iostat=istat) + if (istat /= 0) return + + if (present(coords)) then + coords_ => coords + else + coords_ => struct_data%coords_ + endif + + nn_ = size(coords_, 2) + write(iun, *) nn_ + do i = 1, nn_ + write(iun, *) coords_(:, i) ! dims (3, nn) + enddo + close(iun) + end subroutine + + + + + + + + module subroutine bsa_exportPSDToFile(fname, psd, varname, f) + character(len = *), intent(in) :: fname + character(len = *), intent(in), optional :: varname + real(RDP), intent(in), optional :: f(:) + real(RDP), intent(in) :: psd(:, :) + real(RDP), allocatable :: tmp(:) + + integer :: s1, s2, iun, j + + s1 = size(psd, 1) + s2 = size(psd, 2) + + iun = io_openExportFileByName(exp_dir_ // fname) + if (iun == 0) call bsa_Abort() +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, 3a, ", shapes = ", 2i5)') & +! INFOMSG//' writing psd to file ', fname, shape(psd) +! #endif + + write(iun, *) s1 + write(iun, *) s2 + + + ! NOTE: different from writing bisp + ! BUG: need this dummy variable in order to avoid + ! I/O runtime warning... + allocate(tmp(s2)) + if (present(f)) then + do j = 1, s1 + tmp = psd(j, :) + write(iun, '(*(g, 1x))') f(j), tmp + enddo + else + do j = 1, s1 + tmp = psd(j, :) + write(iun, '(*(g, 1x))') tmp + enddo + endif + close(iun) + deallocate(tmp) + +! #ifdef __BSA_DEBUG +! if (present(varname)) & +! write(unit_debug_, '(1x, 5a)') & +! INFOMSG, '@Utils::bsa_exportPSDToFile() : ', varname, & +! ' correctly written to file ', fname +! #endif + end subroutine + + + + + module subroutine bsa_exportBispToFile(fname, bisp, varname) + character(len = *), intent(in) :: fname + character(len = *), intent(in), optional :: varname + real(RDP), intent(in) :: bisp(:, :, :) + + integer :: s1, s2, s3, iun, i, j + + s1 = size(bisp, 1) + s2 = size(bisp, 2) + if (s2 /= s1) call bsa_Abort('First two dimensions of bisp do not match.') + s3 = size(bisp, 3) + + iun = io_openExportFileByName(exp_dir_ // fname) + if (iun == 0) call bsa_Abort() + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, 3a, ", shapes = ", 3i5)') & +! INFOMSG, ' writing bisp to file ', fname, shape(bisp) +! #endif + + write(iun, *) s1 + write(iun, *) s2 + write(iun, *) s3 + do j = 1, s3 + do i = 1, s2 + write(iun, '(*(g, 1x))') bisp(:, i, j) + enddo + enddo + close(iun) + +! #ifdef __BSA_DEBUG +! if (present(varname)) & +! write(unit_debug_, '(1x, 5a)') & +! INFOMSG, '@Utils::bsa_exportBispToFile() : ', varname, ' correctly written to file ', fname +! #endif + end subroutine + + + +end submodule BsaLib_Impl \ No newline at end of file diff --git a/src/BsaLib/bsa/classic/BsaClassicImpl.f90 b/src/BsaLib/bsa/classic/BsaClassicImpl.f90 new file mode 100644 index 0000000..b70de46 --- /dev/null +++ b/src/BsaLib/bsa/classic/BsaClassicImpl.f90 @@ -0,0 +1,524 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib) BsaLib_ClassicImpl + +#include "../../precisions" + + use BsaLib_Data + implicit none + +contains + + + !> BUG: now only supports EVENLY SPACED FREQUENCIES.. + module subroutine mainClassic_(m2mf_cls, m2mr_cls, m2o2mr_cls, m3mf_cls, m3mr_cls) + use BsaLib_Functions + real(RDP), allocatable :: m2mf_cls(:), m2mr_cls(:), m2o2mr_cls(:), m3mf_cls(:), m3mr_cls(:) + integer :: idim2 + real(RDP), allocatable :: S_uvw(:, :), f(:) + integer :: itc_, idir_, idxi, idxe + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG, '@BsaClassicImpl::mainClassic_() : Init BSA-Classic main...' +#endif + + call computeFreqsVect_(settings, struct_data, f) + + ! NOTE: reset in case NFREQs has been changed in previous call + NFREQS = settings%nfreqs_ + + ! some shared memory allocation + if (settings%i_compute_psd_ == 1) then + allocate(m2mf_cls(dimM_psd_)) + m2mf_cls = 0._RDP + + allocate(m2mr_cls(dimM_psd_)) + m2mr_cls = 0._RDP + + allocate(m2o2mr_cls(dimM_psd_)) + m2o2mr_cls = 0._RDP + endif + if (settings%i_compute_bisp_== 1) then + allocate(m3mf_cls(dimM_bisp_)) + m3mf_cls = 0._RDP + + allocate(m3mr_cls(dimM_bisp_)) + m3mr_cls = 0._RDP + endif + + +#ifdef __BSA_DEBUG + print '(1x, a, a, i0)', INFOMSG, 'n. of frequencies to be computed=', settings%nfreqs_ + print '(1x, a, a, i0)', INFOMSG, 'PSD modal extension=', dimM_psd_ + print '(1x, a, a, i0)', INFOMSG, 'BISP modal extension=', dimM_bisp_ + + + write(unit_debug_, *) INFOMSG, '@BsaClassicImpl::mainClassic_() : computing nodal wind turbulence PSDs...' +#endif + + idim2 = struct_data%nn_load_ * wd%i_ntc_ * wd%i_ndirs_ + allocate(S_uvw(settings%nfreqs_, idim2)) + idxi = 1 + idxe = struct_data%nn_load_ + do itc_ = 1, wd%i_ntc_ + + do idir_ = 1, wd%i_ndirs_ + + ! BUG: difference between idir and itc ??? + ! NOTE: done for all the loaded nodes at once ! + S_uvw(:, idxi:idxe) = wd%evalPSD(settings%nfreqs_, f, & + struct_data%nn_load_, struct_data%n_load_, wd%dirs_(idir_), wd%tc_(itc_)) + + idxi = idxe + 1 + idxe = idxe + struct_data%nn_load_ + enddo ! i direction + enddo ! i turb comp + + +#ifdef __BSA_CL + block + real(RDP), allocatable :: S_uvw_T_(:, :) + + call bsacl_AcquireResultBFMVect(m3mf_cls) + call bsacl_AcquireComputationFreqs(NFREQS, f, NFREQS, f) + S_uvw_T_ = transpose(S_uvw) ! n_dim_ x n_freqs + deallocate(S_uvw) + call bsacl_AcquireBaseWindTurbPSD(S_uvw_T_) + call bsacl_Run(ierr_cl_) + if (ierr_cl_ == BSACL_PROBLEM_DIMENSIONS_TOO_SMALL) then + print '(1x, 2a)', WARNMSG, & + 'Problem dimensions are too small for GPU parallelisation. Using CPU.' + S_uvw = transpose(S_uvw_T_) + deallocate(S_uvw_T_) + goto 997 ! CPU computation + endif + end block + goto 998 +#endif + + 997 continue + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG, '@BsaClassicImpl::mainClassic_() : computing nodal wind turbulence PSDs -- ok.' + + call bsa_exportPSDToFile('psdS_UVW.txt', S_uvw, 'psdS_UVW', f) +#endif + + block + real(RDP) :: m2(idim2) + + call intgSpectraVect_(settings%nfreqs_, f, psd=S_uvw, m2=m2) + call bsa_exportMomentToFile('m2_PSDs.txt', m2) + end block + + + call checkMaxAllocation_() + + ! BUG: set it from .dat file + settings%i_scalar_vers_ = 0 ! 0=vectorised, 1=scalar + + + if (settings%i_scalar_vers_ == 0) then ! VECTORISED + + print '(/1x, 2a)', INFOMSG, 'Using VECTORISED version' + + block + real(RDP), allocatable :: psd(:, :), bisp(:, :, :) + + + !=========================================================== + ! MODAL FORCES + ! + call getBFM_vect_cls(f, S_uvw, psd, bisp) + if (allocated(S_uvw)) deallocate(S_uvw) + call intgSpectraVect_(settings%nfreqs_, f, psd=psd, m2=m2mf_cls, bisp=bisp, m3=m3mf_cls) + if (settings%i_compute_psd_ == 1) call bsa_exportPSDToFile('psdmf.txt', psd, 'psdmf', f) + + + !=========================================================== + ! MODAL RESPONSES + ! + call getBRM_vect_cls(f, psd, bisp) + call intgSpectraVect_(settings%nfreqs_, f, psd=psd, m2=m2mr_cls, bisp=bisp, m3=m3mr_cls) + if (settings%i_compute_psd_ == 1) call bsa_exportPSDToFile('psdmr.txt', psd, 'psdmr', f) + + block + real(RDP), allocatable :: omegas(:) + integer :: i + + omegas = f * CST_PIt2 + do concurrent (i = 1 : dimM_psd_) shared(omegas, psd) + psd(:, i) = psd(:, i) * omegas(:) * omegas(:) + enddo + call intgSpectraVect_(settings%nfreqs_, f, psd=psd, m2=m2o2mr_cls) + end block + + + if (allocated(psd)) deallocate(psd) + if (allocated(bisp)) deallocate(bisp) + end block + + + + !=============== + else ! SCALAR VERSION + !=============== + + + print '(/1x, 2a)', INFOMSG, 'Using SCALAR version' + + print '(/ 1x, a, a /)', & + WARNMSG, 'For scalar version, computation of m2o2_mr not yet implemented !' + + block + real(RDP) :: fi, fj, dw, dw2, omg + real(RDP), allocatable :: S_uvw_pad(:, :) + + integer, pointer :: jfr_ext => null() + integer, target :: one_ext = 1 + + integer :: lpad, indxi, indxe + + real(RDP), dimension(dimM_psd_) :: psdfm, psdrm, r_tmp + real(RDP), dimension(dimM_bisp_) :: bispfm, bisprm + + psdfm = 0._RDP + psdrm = 0._RDP + bispfm = 0._RDP + bisprm = 0._RDP + + dw = (f(2) - f(1)) * CST_PIt2 ! [rad/s] + dw2 = dw*dw + ! get padded length + lpad = (settings%nfreqs_ - 1) / 2 + indxi = lpad + 1 + indxe = lpad + settings%nfreqs_ + lpad = 2*lpad + settings%nfreqs_ + + allocate(S_uvw_pad(idim2, lpad)) + S_uvw_pad(:, indxi : indxe) = transpose(S_uvw) + + + if (settings%i_compute_bisp_ == 0) then + jfr_ext => one_ext + else + jfr_ext => settings%nfreqs_ + endif + + + do ifr = 1, settings%nfreqs_ + + fi = f(ifr) + omg = fi * CST_PIt2 + + do jfr = 1, jfr_ext + + fj = f(jfr) + + call getBFM_scalar_cls(ifr, jfr, fi, fj, S_uvw, S_uvw_pad(:, ifr - 1 + jfr), psdfm, bispfm) + + ! NOTE: using same infl area for each point in space! + m3mf_cls = m3mf_cls + bispfm * dw2 + + + call getBRM_scalar_cls(ifr, jfr, fi, fj, psdfm, psdrm, bispfm, bisprm) + m3mr_cls = m3mr_cls + bisprm * dw2 + enddo ! i freqs + + if (settings%i_compute_psd_ == 1) then + m2mf_cls = m2mf_cls + psdfm * dw + r_tmp = psdrm * dw + m2mr_cls = m2mr_cls + r_tmp + m2o2mr_cls = m2o2mr_cls + r_tmp * omg*omg + endif + + print '(1x, a, 2(i12, a))', & + INFOMSG, ifr*settings%nfreqs_, ' out of ', settings%nfreqs_**2, ' done...' + + enddo ! j freqs + end block + + endif ! vect/scalar versions + + + 998 continue + if (allocated(f)) deallocate(f) + +#ifdef __BSA_DEBUG + write(unit_debug_, *) & + INFOMSG, '@BsaClassicImpl::mainClassic_() : Init BSA-Classic main -- ok.' +#endif + end subroutine mainClassic_ + + + + + + + + subroutine checkMaxAllocation_() + integer :: itmp + + if (settings%i_test_mode_ == 0) then + + ! Computing max allocation size if it was VECTORISED. + if (settings%i_compute_bisp_ == 1) then + itmp = settings%nfreqs_**2 * dimM_bisp_ + else + itmp = settings%nfreqs_ * dimM_bisp_ + endif + + if (settings%i_scalar_vers_ == 0) then + + if (itmp > MAX_VECT_ALLOC_ELEMS) then + + print '( /, 1x, a, a, i0, ")" )', WARNMSG, 'Too high allocation size for VECTORISED BSA version (', itmp + print '( 1x, a, a, / )', MSGCONT, 'Switching to SCALAR version.' + + settings%i_scalar_vers_ = 1 + endif + + else ! user wants SCALAR. + + ! NOTE: if just PSDs, we can ALWAYS go for vectorised + if (settings%i_compute_bisp_ == 0) then + + ! Still, check, better. + if (settings%nfreqs_ * dimM_psd_ < MAX_VECT_ALLOC_ELEMS) then + + print '( /, 1x, a, a )', NOTEMSG, 'Requested SCALAR BSA version, but for only PSDs computation.' + print '(1x, a, a)', MSGCONT, 'Switching to VECTORISED for perf.' + settings%i_scalar_vers_ = 0 + endif + + else ! BISPs as well -> just warn, do not force changing.. + + if (itmp < MAX_VECT_ALLOC_ELEMS) then + + print '( /, 1x, a, a )', NOTEMSG, 'Running SCALAR BSA version, but VECTORISED (preferable) is possible.' + print '(1x, a, a)', MSGCONT, 'Consider changing setting.' + endif + endif + endif + + else ! testing mode (==1, yes), keep things as such. + + print '(/1x, a, a)', & + WARNMSG, 'Frequency definition not being checked for optimal values !' + endif + end subroutine + + + + + + + + + subroutine computeFreqsVect_(setts, struct, f) + ! class(bsa_classic_t), intent(inout) :: this + class(settings_t), intent(inout) :: setts + class(StructureData_t), intent(inout) :: struct + real(RDP), allocatable, intent(out) :: f(:) + + logical :: l_df_big = .false. + integer :: nfreqs_1 + real(RDP) :: df_ref, max_freq, max_freq_ref + + if (setts%nfreqs_ == 0 .or. setts%df_ == 0._RDP) & + call bsa_Abort('Either NFREQs or DF are == 0.') + + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) INFOMSG, '@BsaClassicImpl::computeFreqsVect_() : computing frequencies...' +! #endif + + ! NOTE: make sure resonant peak are computed + call struct%ComputeResPeakWidths() + + ! BUG: let the user choose the dividend + df_ref = minval(struct%res_peak_width_) / 5 + + if (setts%df_ > df_ref) then + + l_df_big = .true. + print '( /, 1x, a, 2(a, f12.5))', WARNMSG, 'specified df=', setts%df_, & + ' is bigger than suggested=', df_ref + + ! BUG: also here, let user choose limit + elseif (setts%df_ < df_ref / 10) then + + print '( /, 1x, a, 2(a, f12.5))', WARNMSG, 'specified df=', setts%df_, & + ' is smaller than 1/10th of suggested=', df_ref + print '(1x, a, a /)', MSGCONT, 'Consider increasing it.' + endif + + nfreqs_1 = setts%nfreqs_ - 1 ! NOTE: do not consider 0 freq + + if (settings%i_test_mode_ == 0) then ! Do actual check only if NO TESTING MODE. + + max_freq = setts%df_ * nfreqs_1 + max_freq_ref = maxval(struct%modal_%nat_freqs_) + + if (max_freq < max_freq_ref) then + + if (l_df_big) then ! try with suggested one + + max_freq = df_ref * nfreqs_1 + if (max_freq < max_freq_ref) then ! find for the right nfreq value (using df ref) + + nfreqs_1 = ceiling(max_freq_ref / df_ref) + max_freq = max_freq_ref + + print '(/ 1x, a, a, i0, a )', & + WARNMSG, '"nfreq=', setts%nfreqs_, '" is too small to reach max frequency (even with suggested "df").' + print '( 1x, a, a, i0 /)', & + MSGCONT, 'To avoid errors in estimation, it is going to be considered nfreqs= ', nfreqs_1+1 + else + + print '( /, 1x, a, a, i0, a / )', & + WARNMSG, 'with specified "nfreq', setts%nfreqs_, & + '", full frequency range coverage is ensured using suggested "df".' + endif + + setts%df_ = df_ref ! override df with suggested value + + + else ! chosen "df" is OK. + + + nfreqs_1 = ceiling(max_freq_ref / setts%df_) + print '( /, 1x, a, a, i0, a /, 20x, a, i5, / )', & + WARNMSG, '"nfreq=', setts%nfreqs_ ,'" is too small to reach max frequency.' + + print '(1x, a, a, i0 /)', & + MSGCONT, 'To avoid errors in estimation, it is going to be considered nfreqs=', nfreqs_1+1 + + max_freq = max_freq_ref + endif + + else + + if (l_df_big) then + + print '( /, 1x, a, a, f12.5, " > ", f12.5, ")")', & + WARNMSG, & + 'chosen "df" is greater than suggested one (', setts%df_, df_ref + endif + endif + endif ! test mode == 0 + + + ! Actual freqs computation + if (setts%i_def_scaling_ == 1) then + + ! NOTE: automatically odd (because of the +1) + setts%nfreqs_ = (nfreqs_1 * 2) + 1 + if (mod(setts%nfreqs_, 2) == 0) call bsa_Abort('Needing odd n. of frequencies.') + allocate(f(setts%nfreqs_)) + f = [-nfreqs_1 : nfreqs_1] * setts%df_ + + else ! ==2 (frequencies conventions) [WARNING] + + if (mod(nfreqs_1, 2) /= 0) nfreqs_1 = nfreqs_1 + 1 ! make nfreqs-1 even + + setts%nfreqs_ = nfreqs_1 + 1 ! NOTE: +1 because we consider 0 as well. + allocate(f(setts%nfreqs_)) + f = [0 : nfreqs_1] * setts%df_ + + endif + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG, '@BsaClassicImpl::computeFreqsVect_() : computing frequencies -- ok.' +#endif + end subroutine computeFreqsVect_ + + + + + + + subroutine intgSpectraVect_(nf, f, psd, m2, bisp, m3) + integer, intent(in) :: nf + real(RDP), intent(in) :: f(nf) + ! integer, intent(in), optional :: dimpsd, dimbisp + real(RDP), intent(in), optional :: psd(nf, *), bisp(nf, nf, *) + real(RDP), intent(out), optional :: m2(:), m3(:) + + integer :: nf_1 = 0, dim = 0, i + real(RDP) :: delta + real(RDP) :: rtmp, d_2, d2, d2_2 + + + delta = f(2) - f(1) + if (settings%i_def_scaling_ == 1) delta = delta * CST_PIt2 ! [rad/s] + d_2 = delta / 2._RDP + + ! PSDs + if (present(psd) .and. present(m2)) then + + ! full integration + dim = size(m2) + m2 = sum(psd(:, 1:dim), dim=1) * delta + + ! removing excess from vertexes + m2(:) = m2(:) - ((psd(1, 1:dim) + psd(nf, 1:dim)) * d_2) + endif + + + ! BISPs + if (present(bisp) .and. present(m3)) then + + d2 = delta * delta + + ! full integration + dim = size(m3) + m3 = sum(sum(bisp(:, :, 1:dim), 1), 1) * d2 + + + ! removing excess from vertexes/borders + + rtmp = CST_3d2 * d2 + d2_2 = d2 / 2._RDP + nf_1 = nf - 1 + + ! LEFT + ! vertex + m3(:) = m3(:) - (bisp(1, 1, 1:dim) * rtmp) + ! side + m3(:) = m3(:) - sum(bisp(2:nf_1, 1, 1:dim) * d2_2, 1) + ! vertex + m3(:) = m3(:) - (bisp(nf, 1, 1:dim) * rtmp) + + ! sides (up/down) + do i = 2, nf_1 + m3(:) = m3(:) - bisp(1, i, 1:dim) * d2_2 + m3(:) = m3(:) - bisp(nf, i, 1:dim) * d2_2 + enddo + + ! RIGHT + ! vertex + m3(:) = m3(:) - (bisp(1, nf, 1:dim) * rtmp) + ! side + m3(:) = m3(:) - sum(bisp(2:nf_1, nf, 1:dim) * d2_2, 1) + ! vertex + m3(:) = m3(:) - (bisp(nf, nf, 1:dim) * rtmp) + endif + end subroutine intgSpectraVect_ + + + +end submodule \ No newline at end of file diff --git a/src/BsaLib/bsa/data/BsaLibData.f90 b/src/BsaLib/bsa/data/BsaLibData.f90 new file mode 100644 index 0000000..401a033 --- /dev/null +++ b/src/BsaLib/bsa/data/BsaLibData.f90 @@ -0,0 +1,238 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_Data + +#include "../../precisions" + + use Logging + use BsaLib_Timing + use BsaLib_CONSTANTS + use BsaLib_Settings + use BsaLib_Structure + use BsaLib_WindData + !$ use omp_lib +#ifdef __BSA_CL + use BsaCL +#endif + implicit none + public + + + !==================================== + ! MODULE VARIABLES + !==================================== + + type(settings_t), allocatable, target :: settings + type(WindData_t), allocatable, target :: wd + type(StructureData_t), allocatable, target :: struct_data + type(timer_t), allocatable, target :: timer + type(logger_t), allocatable, target :: logger_debug + + logical :: is_data_cleaned_ = .false. + logical :: close_deb_unit_ = .true. + + logical :: do_validate_modal_ = .true. + + integer(kind = 4) :: dimNf_psd_ = 0, dimNf_bisp_ = 0 + integer(kind = 4) :: dimNr_psd_ = 0, dimNr_bisp_ = 0 + integer(kind = 4) :: dimM_psd_ = 0, dimM_bisp_ = 0 + + real(RDP), allocatable, target :: PHItimesC_local_(:, :, :) + + real(RDP), allocatable :: peak_exts_(:) + logical :: do_restrict_bkgpeak_ = .false. + + logical :: do_export_brm_ = .false. + integer(kind = 4) :: i_brmexport_mode_ = BSA_EXPORT_BRM_MODE_BASE + character(len = *), parameter :: brm_export_file_name_ = 'bsaexport.brm' +#ifdef __BSA_OMP + procedure(exportBRMinterf_vect_all_), pointer :: write_brm_fptr_ => null() +#else + procedure(exportBRMinterf_scalar_), pointer :: write_brm_fptr_ => null() +#endif + type, public :: BrmExportBaseData_t + + integer(kind = 4) :: i_doNotPrintGenHeader_ = 0 ! == 0 means DO PRINT !! + integer(kind = 4) :: nm_ = 0 + integer(kind = 4) :: ncomb_ = 0 + integer(kind = 4) :: ispsym_ = 0 + integer(kind = 4) :: nzones_ = 0 + integer(kind = 4), pointer :: modes_(:) => null() + + integer(kind = 4) :: i_doNotPrintZonHeader_ = 0 + integer(kind = 4) :: idZone_ = 0 + integer(kind = 4) :: nI_ = 0 + integer(kind = 4) :: nJ_ = 0 + end type + + +#ifdef __BSA_CL + integer, target :: ierr_cl_ +#endif + + +#ifdef __BSA_CHECK_NOD_COH_SVD + real(RDP), allocatable :: nod_corr_full_(:, :) + real(RDP), allocatable :: nod_corr_EVLs_(:), nod_corr_EVTs_(:, :) +#endif + + + ! ========================= + ! ==== classic related + ! + logical :: force_cls_execution_ = .false. + integer(kind = 4), parameter :: MAX_VECT_ALLOC_ELEMS = 1000000000 ! 1B -> almost 8Gb + integer(kind = 4) :: ifr = 0, jfr = 0 + ! real(RDP), pointer :: m2mf_cls_ptr_(:), m2mr_cls_ptr_(:) ! 2nd order moments + ! real(RDP), pointer :: m3mf_cls_ptr_(:), m3mr_cls_ptr_(:) ! 3rd order moments + + procedure(getBFMClsVect), pointer :: getBFM_vect_cls => null() + procedure(getBRMClsVect), pointer :: getBRM_vect_cls => null() + abstract interface + subroutine getBFMClsVect(f, Suvw, psd, bisp) + import :: RDP + import :: settings, struct_data, wd + real(RDP), intent(in) :: f(settings%nfreqs_) + real(RDP), intent(in) :: Suvw(settings%nfreqs_, struct_data%nn_load_ * wd%i_ndirs_ * wd%i_ntc_) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + end subroutine + + subroutine getBRMClsVect(f, psd, bisp) + import :: RDP + import :: settings + real(RDP), intent(in) :: f(settings%nfreqs_) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + end subroutine + end interface + + + procedure(getBFMClsScalar), pointer :: getBFM_scalar_cls => null() + procedure(getBRMClsScalar), pointer :: getBRM_scalar_cls => null() + abstract interface + pure subroutine getBFMClsScalar(ii, ij, fi, fj, Suvw, Suvw_pad, psd, bisp) + import :: RDP, dimM_psd_, dimM_bisp_ + import :: settings, struct_data, wd + integer, intent(in) :: ii, ij + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: Suvw(settings%nfreqs_, struct_data%nn_load_ * wd%i_ndirs_ * wd%i_ntc_) + real(RDP), intent(in) :: Suvw_pad(struct_data%nn_load_ * wd%i_ndirs_ * wd%i_ntc_) + real(RDP), intent(inout) :: psd(dimM_psd_), bisp(dimM_bisp_) + end subroutine + + subroutine getBRMClsScalar(ii, ij, fi, fj, psdin, psdout, bispin, bispout) + import :: RDP, dimM_psd_, dimM_bisp_ + integer, intent(in) :: ii, ij ! freqs indexes + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: psdin(dimM_psd_), bispin(dimM_bisp_) + real(RDP), intent(out) :: psdout(dimM_psd_), bispout(dimM_bisp_) + end subroutine + end interface + + + + + ! ========================= + ! ==== mesher related + ! + real(RDP), pointer :: m3mf_msh_ptr_(:) => null(), m3mr_msh_ptr_(:) => null() + +#ifndef __BSA_OMP + !> Shared instance of undumped BFM. + !> It holds the max N. of points of all the dumped zones, so that no overflows occur. + real(RDP), allocatable :: bfm_undump(:, :) +#endif + + integer(kind = 4), public :: ipre_mesh_type = BSA_PREMESH_TYPE_DIAG_CREST_NO + integer(kind = 4), public :: ipre_mesh_mode = BSA_PREMESH_MODE_ZONE_REFINED + integer(kind = 4), public :: msh_iZone + + !> Controls if checking zone's deltas or not. + logical :: do_validate_deltas_ = .true. + + integer(kind = 4), public :: I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ = 2 + integer(kind = 4), public :: I_RES_PEAK_DELTAF_BFM_REFMT_FCT_ = 3 + + ! Total pre-mesh/post-mesh phase points + integer(kind = 4), public :: msh_bfmpts_pre_ + integer(kind = 4), public :: msh_bfmpts_post_ + integer(kind = 4), public :: msh_brmpts_post_ + + !> Code "-1" means that interest modes have to be read from the NEXT (right) + !> limit only, since this is the first limit in the list + integer(kind = 4), public, parameter :: CODE_PRE_PEAK_OK = -1 + + !> Code "-2" means that interest modes have to be read from + !> NEXT (right) limit only, since this is the first limit in the list. + !> However, info is MISSING from the left side (BKG) peak + !> in which some modes fall within, but we cannot know which + !> one is close to this zone's limit, in order to determine if + !> to be added to its interest modes. + !> Hence, it is a sort of "ALARM". Info will not be accurate in this case. + integer(kind = 4), public, parameter :: CODE_PRE_PEAK_KO = -2 + + !> Limit zones interest modes indexes + integer(kind = 4), public, allocatable :: msh_ZoneLimsInterestModes(:) + + !> Tot n. of zones counter. + integer(kind = 4), public, target :: msh_NZones = 0 + + !> Controls whether employing new BFM MLR method or not + logical :: test_no_bfm_mlr_ = .false. + + !> Controls whether to perform modal truncation or not + logical :: do_trunc_POD_ = .false. + real(kind = 8) :: POD_trunc_lim_ = 0.d0 + + !> Stores width of background peak + real(RDP) :: bkg_peakw_ = 0._RDP + + ! Mesher function pointer (pre/post meshing) + procedure(getMshBFM), pointer :: getBFM_msh => null() + procedure(getMshBRM), pointer :: getBRM_msh => null() + abstract interface + function getMshBFM(fi, fj) result(vals) + import RDP, dimM_bisp_ + real(RDP), intent(in) :: fi, fj + real(RDP) :: vals(dimM_bisp_) + end function + + function getMshBRM(bfm, fi, fj) result(vals) + import RDP, dimM_bisp_ + real(RDP), intent(in) :: bfm(dimM_bisp_) + real(RDP), intent(in) :: fi, fj + real(RDP) :: vals(dimM_bisp_) + end function + end interface + + + interface + module function evaluatePSD(f, nf, itc) result(PSD) + integer(kind = 4), intent(in) :: nf, itc + real(kind = 8), intent(in) :: f(nf) + real(kind = 8), allocatable, target :: PSD(:, :) + end function + + module subroutine cleanBSAData_() + end subroutine + + module subroutine bsa_Abort(emsg) + character(len = *), intent(in), optional :: emsg + end subroutine + end interface + + + +end module BsaLib_Data \ No newline at end of file diff --git a/src/BsaLib/bsa/data/BsaLibDataImpl.f90 b/src/BsaLib/bsa/data/BsaLibDataImpl.f90 new file mode 100644 index 0000000..73aab57 --- /dev/null +++ b/src/BsaLib/bsa/data/BsaLibDataImpl.f90 @@ -0,0 +1,170 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib_Data) BsaLib_DataImpl + + use BsaLib_IO, only: & + INFOMSG, WARNMSG, ERRMSG, MSGCONT, DBGMSG, & + unit_debug_, unit_dump_bfm_, unit_dump_brm_ + implicit none + +contains + + + module function evaluatePSD(f, nf, itc) result(PSD) + integer(kind = 4), intent(in) :: nf, itc + real(kind = 8), intent(in) :: f(nf) + real(kind = 8), allocatable, target :: PSD(:, :) + + PSD = wd%evalPSD(nf, f, struct_data%nn_load_, struct_data%n_load_, 1, itc) + end function + + + + + module subroutine cleanBSAData_() + integer(kind = 4) :: istat + character(len = 256) :: emsg + logical :: isopn + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@BsaLibData::cleanBSAData_() : cleaning...' +#endif + + if (allocated(wd)) call wd%clean() + if (allocated(struct_data)) call struct_data%clean() + + ! if (associated(m2mf_cls_ptr_)) nullify(m2mf_cls_ptr_) + ! if (associated(m2mr_cls_ptr_)) nullify(m2mr_cls_ptr_) + ! if (associated(m3mf_cls_ptr_)) nullify(m3mf_cls_ptr_) + ! if (associated(m3mr_cls_ptr_)) nullify(m3mr_cls_ptr_) + + if (associated(m3mf_msh_ptr_)) nullify(m3mf_msh_ptr_) + if (associated(m3mr_msh_ptr_)) nullify(m3mr_msh_ptr_) + + + if (allocated(PHItimesC_local_)) then + deallocate(PHItimesC_local_, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('PHItimesC_local_') +#endif + else + call deallocKOMsg('PHItimesC_local_', istat, emsg) + endif + endif + + + if (allocated(peak_exts_)) then + deallocate(peak_exts_, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('peak_exts_') +#endif + else + call deallocKOMsg('peak_exts_', istat, emsg) + endif + endif + + + if (allocated(settings)) then + deallocate(settings, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('settings') +#endif + else + call deallocKOMsg('settings', istat, emsg) + endif + endif + + if (allocated(wd)) then + deallocate(wd, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('wd') +#endif + else + call deallocKOMsg('wd', istat, emsg) + endif + endif + + if (allocated(struct_data)) then + deallocate(struct_data, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('struct_data') +#endif + else + call deallocKOMsg('struct_data', istat, emsg) + endif + endif + + if (allocated(timer)) then + deallocate(timer, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('timer') +#endif + else + call deallocKOMsg('timer', istat, emsg) + endif + endif + + if (allocated(logger_debug)) then + deallocate(logger_debug, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('logger_debug') +#endif + else + call deallocKOMsg('logger_debug', istat, emsg) + endif + endif + + is_data_cleaned_ = .true. + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@BsaLibData::cleanBSAData_() : cleaning -- ok.' +#endif + + ! NOTE: keep conditions since they might be provided from + ! host program, so they would not want me to close them. + ! They'll manage it ;) + if (close_deb_unit_) then + inquire(unit = unit_debug_, opened = isopn) + if (isopn) close(unit_debug_) + endif + + inquire(unit = unit_dump_bfm_, opened = isopn) + if (isopn) close(unit_dump_bfm_) + + inquire(unit = unit_dump_brm_, opened = isopn) + if (isopn) close(unit_dump_brm_) + end subroutine + + + + module subroutine bsa_Abort(emsg) + character(len = *), intent(in), optional :: emsg + external :: abort + + if (present(emsg)) print '(/ 1x, a, a/)', ERRMSG, emsg + + call cleanBSAData_() ! free memory before halting + error stop + end subroutine + +end submodule \ No newline at end of file diff --git a/src/BsaLib/bsa/functions/functions.f90 b/src/BsaLib/bsa/functions/functions.f90 new file mode 100644 index 0000000..40c3a0a --- /dev/null +++ b/src/BsaLib/bsa/functions/functions.f90 @@ -0,0 +1,198 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_Functions + +#include "../../precisions" + + use BsaLib_Data, only: wd, struct_data, settings, dimM_bisp_, dimM_psd_ + implicit none + public + + + private :: wd, struct_data, settings, dimM_bisp_, dimM_psd_ + + + ! make a local internal copy + integer(kind = 4) :: NFREQS, NNODES, NNODESL, NLIBS, NLIBSL + integer(kind = 4) :: NMODES, NMODES_EFF + integer(kind = 4), allocatable :: MODES(:) + integer(kind = 4) :: NPSDEL, NTCOMPS, NDIRS = 1 + integer(kind = 4), allocatable :: TCOMPS(:), DIRS(:) + + integer(kind = 8) :: MSHR_SVD_LWORK = - 1 + integer(kind = 8), allocatable :: MSHR_SVD_INFO + double precision, allocatable :: MSHR_SVD_WORK(:) + + + interface + + module subroutine setBsaFunctionLocalVars() + end subroutine + + + module subroutine prefetchSVDWorkDim_() + end subroutine + + module subroutine cleanSVDWorkInfo_() + end subroutine + + + + module function getFM_full_tnm_scalar_msh_(fi, fj) result(bfm) + real(RDP), intent(in) :: fi, fj + real(RDP) :: bfm(dimM_bisp_) + end function + + + module function getFM_full_tm_scalar_msh_POD_(fi, fj) result(bfm) + real(RDP), intent(in) :: fi, fj + real(RDP) :: bfm(dimM_bisp_) + end function + + + module function getRM_full_scalar_msh_(bfm, fi, fj) result(brm) + real(RDP), intent(in) :: bfm(dimM_bisp_), fi, fj + real(RDP) :: brm(dimM_bisp_) + end function + + + + module function getFM_diag_tnm_scalar_msh_(fi, fj) result(bfm) + real(RDP), intent(in) :: fi, fj + real(RDP) :: bfm(dimM_bisp_) + end function + + + module function getRM_diag_scalar_msh_(bfm, fi, fj) result(brm) + real(RDP), intent(in) :: bfm(dimM_bisp_), fi, fj + real(RDP) :: brm(dimM_bisp_) + end function + + + + + + + + + + !> BUG: this routine is adapted to the case where we use + !> convention on PULSATION. + !> Please, adpapt it to the case of convention over FREQUENCIES. + module subroutine getFM_full_tnlm_vect_cls_(f, Suvw, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + end subroutine + + + module subroutine getFM_full_tnm_vect_cls_(f, Suvw, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + end subroutine + + + + module subroutine getRM_full_vect_cls_(f, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + end subroutine + + + + module subroutine getFM_diag_tnlm_vect_cls_(f, Suvw, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), intent(inout), allocatable :: psd(:, :), bisp(:, :, :) + end subroutine + + + + module subroutine getRM_diag_vect_cls_(f, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + end subroutine + + + + + + + + !> BUG: this routine is adapted to the case where we use + !> convention on PULSATION. + !> Please, adapt it to the case of convention over FREQUENCIES. + module pure subroutine getFM_full_tnlm_scalar_cls_(ii, ij, fi, fj, Suvw, Suvw_pad, psd, bisp) + integer, intent(in) :: ii, ij + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), intent(in) :: Suvw_pad(NPSDEL) + real(RDP), intent(inout) :: psd(dimM_psd_), bisp(dimM_bisp_) + end subroutine + + + + module pure subroutine getFM_full_tnm_scalar_cls_(ii, ij, fi, fj, Suvw, Suvw_pad, psd, bisp) + integer, intent(in) :: ii, ij + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), intent(in) :: Suvw_pad(NPSDEL) + real(RDP), intent(inout) :: psd(dimM_psd_), bisp(dimM_bisp_) + end subroutine + + + + module subroutine getRM_full_scalar_cls_(ii, ij, fi, fj, psdin, psdout, bispin, bispout) + integer, intent(in) :: ii, ij + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: psdin(dimM_psd_), bispin(dimM_bisp_) + real(RDP), intent(out) :: psdout(dimM_psd_), bispout(dimM_bisp_) + end subroutine + + + !> BUG: this routine is adapted to the case where we use + !> convention on PULSATION. + !> Please, adapt it to the case of convention over FREQUENCIES. + module pure subroutine getFM_diag_tnlm_scalar_cls_(ii, ij, fi, fj, Suvw, Suvw_pad, psd, bisp) + integer, intent(in) :: ii, ij + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), intent(in) :: Suvw_pad(NPSDEL) + real(RDP), intent(inout) :: psd(dimM_psd_), bisp(dimM_bisp_) + end subroutine + + + + module subroutine getRM_diag_scalar_cls_(ii, ij, fi, fj, psdin, psdout, bispin, bispout) + integer, intent(in) :: ii, ij ! freqs indexes + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: psdin(dimM_psd_), bispin(dimM_bisp_) + real(RDP), intent(out) :: psdout(dimM_psd_), bispout(dimM_bisp_) + end subroutine + + + + + module pure subroutine getBR_SFm_val_(nm, Suvw, fnat, im, m, psd) + integer, intent(in) :: im, m, nm + real(RDP), intent(in) :: Suvw(nm, NPSDEL), fnat + real(RDP), intent(inout) :: psd + end subroutine + + end interface + +end module BsaLib_Functions \ No newline at end of file diff --git a/src/BsaLib/bsa/functions/functionsImpl.f90 b/src/BsaLib/bsa/functions/functionsImpl.f90 new file mode 100644 index 0000000..43545f4 --- /dev/null +++ b/src/BsaLib/bsa/functions/functionsImpl.f90 @@ -0,0 +1,3384 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib_Functions) BsaLib_FunctionsImpl + +#include "../../precisions" + + use BsaLib_CONSTANTS + use Logging + use BsaLib_Utility + use BsaLib_Data, only: bsa_Abort, do_trunc_POD_, POD_trunc_lim_ + use BsaLib_IO, only: INFOMSG, WARNMSG, ERRMSG, MSGCONT, DBGMSG, NOTEMSG & + , unit_dump_bfm_, unit_debug_, undebug_fname_ + implicit none + + +contains + + + module subroutine setBsaFunctionLocalVars() + + NFREQS = settings%nfreqs_ + + ! nodal + NNODES = struct_data%nn_ + NNODESL = struct_data%nn_load_ + NLIBS = struct_data%nlibs_ ! tot n. of LIBs per node + NLIBSL = struct_data%nlibs_load_ ! actual n. of loaded LIBs + + ! modal + NMODES = struct_data%modal_%nm_ + NMODES_EFF = struct_data%modal_%nm_eff_ + MODES = struct_data%modal_%modes_ + + ! wind + NTCOMPS = wd%i_ntc_ + TCOMPS = wd%tc_ + NDIRS = wd%i_ndirs_ + DIRS = wd%dirs_ + NPSDEL = NNODESL * NTCOMPS * NDIRS + end subroutine + + + + + module function getFM_full_tnm_scalar_msh_(fi, fj) result(bfm) + real(RDP), intent(in) :: fi, fj + real(RDP) :: bfm(dimM_bisp_) + + real(RDP) :: fiPfj(1), abs_fi, abs_fj, abs_fiPfj + + ! indexes + integer(kind = 4) :: itc, tc, tcP3, iposM + integer(kind = 4) :: iposNK, iposNJ, iposNI + integer(kind = 4) :: ink, inj, ini + integer(kind = 4) :: nk, nj, ni + integer(kind = 4) :: posKi, posJi, posIi + ! integer(kind = 4) :: posKe, posJe, posIe + integer(kind = 4) :: imk, imj, imi + integer(kind = 4) :: ilk + + ! modal matrix slices + real(RDP) :: phiJ(1, NLIBSL), phiI(NLIBSL, 1) !, phiK(1, 1, NLIBSL) + real(RDP) :: phiK_(NMODES_EFF), phiK + + ! wind forces coeffs + real(RDP), dimension(1, NLIBSL) :: ajU, aj + real(RDP), dimension(NLIBSL, 1) :: aiU, ai, akU, ak + + ! basic PSDs + real(RDP), dimension(1, NNODESL) :: S_IJK_fi, S_IJK_fj, S_IJK_fiPfj + real(RDP) :: S_K_fi, S_K_fj, S_K_fiPfj + real(RDP) :: S_J_fi, S_J_fj, S_J_fiPfj + real(RDP) :: S_I_fi, S_I_fj, S_I_fiPfj + + ! nodal spactial correlations + real(RDP) :: corrIJ, corrIK, corrJK + + ! crossed PSDs + real(RDP) :: S_JK_fi, S_JK_fj + real(RDP) :: term1, term2, term3, BF_IJK_ijk(NLIBSL, NLIBSL) + real(RDP), dimension(NLIBSL, NLIBSL) :: tmp1, tmp2, tmp3 + + ! frequencies values + fiPfj = fi + fj + abs_fi = abs(fi) + abs_fj = abs(fj) + abs_fiPfj = abs(fiPfj(1)) + + + ! NOTE: preinitalise to 0, to avoid uninitialised precision errors + ! Like using memset() in C. + bfm = 0._RDP + + + do itc = 1, NTCOMPS + + tc = wd%tc_(itc) + tcP3 = tc + 3 + + ! prefetch wind turbulence PSDs for all loaded nodes + S_IJK_fi = wd%evalPSD(1, [fi], NNODESL, struct_data%n_load_, 1, tc) + + S_IJK_fj = wd%evalPSD(1, [fj], NNODESL, struct_data%n_load_, 1, tc) + + S_IJK_fiPfj = wd%evalPSD(1, fiPfj, NNODESL, struct_data%n_load_, 1, tc) + + + iposNK = 1 + do ink = 1, NNODESL + + nk = struct_data%n_load_(ink) + + ! BUG: must be this because of anoher bug ahead.. + posKi = (nk - 1) * NLIBS + ! posKi = (nk - 1) * NLIBSL + 1 + ! posKe = nk * NLIBSL + + + S_K_fi = S_IJK_fi (1, iposNK) + S_K_fj = S_IJK_fj (1, iposNK) + S_K_fiPfj = S_IJK_fiPfj(1, iposNK) + + + ! NOTE: use node index and NOT values + ! since we only store actually loaded ones. + ! This applies also to actually loaded LIBs. + ! Since we use it all -> : syntax + ! akU(1, 1, :) = wd%wfc_(tc, :, ink) + ! ak(1, 1, :) = wd%wfc_(tcP3, :, ink) + + + akU(:, 1) = wd%wfc_(struct_data%libs_load_, tc, ink) + ak (:, 1) = wd%wfc_(struct_data%libs_load_, tcP3, ink) + + + iposNJ = 1 + do inj = 1, NNODESL + + nj = struct_data%n_load_(inj) + + posJi = (nj - 1) * NLIBS + ! posJi = (nj - 1) * NLIBSL + 1 + ! posJe = nj * NLIBSL + + S_J_fi = S_IJK_fi (1, iposNJ) + S_J_fj = S_IJK_fj (1, iposNJ) + S_J_fiPfj = S_IJK_fiPfj(1, iposNJ) + + ! BUG: should we put what?? DIR?? TC?? + corrJK = wd%nod_corr_(util_getCorrVectIndex(nj, nk, NNODES), tc) + + ! NOTE: we can precompute for perf + S_JK_fi = corrJK**(abs_fi) * sqrt(S_J_fi * S_K_fi) + S_JK_fj = corrJK**(abs_fj) * sqrt(S_J_fj * S_K_fj) + + + ajU(1, :) = wd%wfc_(struct_data%libs_load_, tc, inj) + aj (1, :) = wd%wfc_(struct_data%libs_load_, tcP3, inj) + + + + iposNI = 1 + do ini = 1, NNODESL + + ni = struct_data%n_load_(ini) + + posIi = (ni - 1) * NLIBS + ! posIi = (ni - 1) * NLIBSL + 1 + ! posIe = ni * NLIBSL + + S_I_fi = S_IJK_fi (1, iposNI) + S_I_fj = S_IJK_fj (1, iposNI) + S_I_fiPfj = S_IJK_fiPfj(1, iposNI) + + + aiU(:, 1) = wd%wfc_(struct_data%libs_load_, tc, ini) + ai (:, 1) = wd%wfc_(struct_data%libs_load_, tcP3, ini) + + + corrIJ = wd%nod_corr_(util_getCorrVectIndex(ni, nj, NNODES), tc) + corrIK = wd%nod_corr_(util_getCorrVectIndex(ni, nk, NNODES), tc) + + + ! term1 + term1 = corrIJ**(abs_fi) * sqrt(S_I_fi * S_J_fi) + term1 = corrIK**(abs_fj) * sqrt(S_I_fj * S_K_fj) * term1 + + tmp1 = matmul(ai, ajU) * term1 + + + ! term2 + term2 = corrIJ**(abs_fiPfj) * sqrt(S_I_fiPfj * S_J_fiPfj) + term2 = S_JK_fj * term2 + + tmp2 = matmul(aiU, aj) * term2 + + + ! term3 + term3 = corrIK**(abs_fiPfj) * sqrt(S_I_fiPfj * S_K_fiPfj) + term3 = S_JK_fi * term3 + + tmp3 = matmul(aiU, ajU) * term3 + + + ! BUG: apparently, cannot make a 3D product.. + do ilk = 1, NLIBSL + + + phiK_ = struct_data%modal_%phi_(posKi + struct_data%libs_load_(ilk), MODES) + + + ! BUG: this formulation DOES NOT account for + ! interaction between turbulent components + ! (i.e. uv, uw, vw) + BF_IJK_ijk = 2 * & + ( & + (tmp1 * akU(ilk, 1)) + & + (tmp2 * akU(ilk, 1)) + & + (tmp3 * ak (ilk, 1)) & + ) + + + iposM = 1 + do imk = 1, NMODES_EFF + + phiK = phiK_(imk) + + do imj = 1, NMODES_EFF + + phiJ(1, :) = struct_data%modal_%phi_(posJi + struct_data%libs_load_, MODES(imj)) + + do imi = 1, NMODES_EFF + + phiI(:, 1) = struct_data%modal_%phi_(posIi + struct_data%libs_load_, MODES(imi)) + + ! bfm(iposM) = bfm(iposM) + & + ! sum(BF_IJK_ijk(:, :, :) * (matmul(phiI, phiJ) * phiK(:, :, :))) + + bfm(iposM) = bfm(iposM) + & + sum(BF_IJK_ijk(:, :) * (matmul(phiI, phiJ) * phiK)) + + iposM = iposM + 1 + enddo ! modes I + + enddo ! modes J + + enddo ! modes K + + + enddo ! lib K + + + iposNI = iposNI + 1 + enddo ! nodes I + + iposNJ = iposNJ + 1 + enddo ! nodes J + + iposNK = iposNK + 1 + enddo ! nodes K + + enddo ! itc + + end function getFM_full_tnm_scalar_msh_ + + + + + + + + + module subroutine prefetchSVDWorkDim_() + double precision :: tmpmat(NNODESL, NNODESL) + ! double precision, allocatable :: tmpmat(:, :) + + double precision, dimension(NNODESL) :: tmpv + + double precision, dimension(1) :: optWork + double precision, dimension(1) :: tmp1arr + + integer :: istat + character(len = 256) :: emsg + + interface +#ifdef BSA_USE_SVD_METHOD__ + SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, & + VT, LDVT, WORK, LWORK, INFO ) + ! .. Scalar Arguments .. + CHARACTER JOBU, JOBVT + INTEGER LDA, LDU, LDVT, M, N + integer info, lwork + ! .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),& + VT( LDVT, * ), WORK( * ) + end subroutine +#else + SUBROUTINE dsyev( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) + ! .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N + ! .. + ! .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) + END SUBROUTINE +#endif + end interface + + + if (.not. allocated(MSHR_SVD_INFO)) then + allocate(MSHR_SVD_INFO, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('MSHR_SVD_INFO', loc(MSHR_SVD_INFO), sizeof(MSHR_SVD_INFO)) +#endif + else + call allocKOMsg('MSHR_SVD_INFO', istat, emsg) + endif + endif + + MSHR_SVD_INFO = 0 +#ifdef BSA_USE_SVD_METHOD__ + call dgesvd(& + 'O' & ! min(M,N) columns of U are returned in array U + , 'N' & ! no rows of V are computed + , NNODESL & ! n. of rows M + , NNODESL & ! n. of cols N + , tmpmat & ! A matrix + , NNODESL & + , tmpv & + , tmp1arr & ! U array + , 1 & + , tmp1arr & + , 1 & + , optWork & + , MSHR_SVD_LWORK & + , MSHR_SVD_INFO & + ) +#else + call dsyev('V', 'L', & + NNODESL, tmpmat, NNODESL, tmp1arr, optWork, MSHR_SVD_LWORK, MSHR_SVD_INFO) +#endif + + if (MSHR_SVD_INFO == 0) then + + MSHR_SVD_LWORK = int(optWork(1), kind = 8) +! #ifdef __BSA_DEBUG + print '(1x, a, a, i0 /)', & + INFOMSG, 'WORK query ok. Optimal work dimension = ', MSHR_SVD_LWORK +! #endif + + if (allocated(MSHR_SVD_WORK)) then + if (size(MSHR_SVD_WORK) /= MSHR_SVD_LWORK) then + deallocate(MSHR_SVD_WORK) + allocate(MSHR_SVD_WORK(MSHR_SVD_LWORK), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('MSHR_SVD_WORK', & + int(MSHR_SVD_LWORK), loc(MSHR_SVD_WORK), sizeof(MSHR_SVD_WORK)) +#endif + else + call allocKOMsg('MSHR_SVD_WORK', istat, emsg) + endif + endif + else + allocate(MSHR_SVD_WORK(MSHR_SVD_LWORK), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('MSHR_SVD_WORK', & + int(MSHR_SVD_LWORK), loc(MSHR_SVD_WORK), sizeof(MSHR_SVD_WORK)) +#endif + else + call allocKOMsg('MSHR_SVD_WORK', istat, emsg) + endif + endif + return ! correct execution flow + endif + + + print '(1x, a, a, i0)', & + ERRMSG, 'WORK query for SVD decomposition returned code ', MSHR_SVD_INFO + print '(1x, a, a)', & + MSGCONT, 'Please, check again.' + call bsa_Abort() + end subroutine + + + + + module subroutine cleanSVDWorkInfo_() + integer :: istat + character(len = 256) :: emsg + + ! NOTE: reset to -1 so that next call is going to query again. + MSHR_SVD_LWORK = - 1 + + if (allocated(MSHR_SVD_INFO)) then + deallocate(MSHR_SVD_INFO, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('MSHR_SVD_INFO') +#endif + else + call deallocKOMsg('MSHR_SVD_INFO', istat, emsg) + endif + endif + + if (allocated(MSHR_SVD_WORK)) then + deallocate(MSHR_SVD_WORK, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('MSHR_SVD_WORK') +#endif + else + call deallocKOMsg('MSHR_SVD_WORK', istat, emsg) + endif + endif + +#ifdef __BSA_DEBUG + print '(1x, a, a)', & + INFOMSG, 'SVD related data cleaned -- ok.' +#endif + end subroutine + + + + + + + module function getFM_full_tm_scalar_msh_POD_(fi, fj) result(bfm) + real(RDP), intent(in) :: fi, fj + real(RDP) :: bfm(dimM_bisp_) + + real(RDP) :: fiPfj(1), fi_(1), fj_(1) + + ! wind turbulent comps indexes + integer(kind = 4) :: itc, tc, tcP3 + + ! n. of kept modes from wind fields decomposition + integer :: nmw1, nmw2, nmw1w2 + integer :: p, q + integer :: m, n, o, posm + + double precision, allocatable :: S_uvw_w1 (:, :) + double precision, allocatable :: S_uvw_w2 (:, :) + double precision, allocatable :: S_uvw_w1w2(:, :) + + ! tmp vec for interfacing, BUG: might be avoided? + double precision :: tmpv(1, NNODESL) + + ! singular values vectors (DECREASING ordering!) + double precision :: D_S_uvw_w1 (NNODESL) + double precision :: D_S_uvw_w2 (NNODESL) + double precision :: D_S_uvw_w1w2(NNODESL) + + double precision, dimension(NNODESL, 1) :: eigvp, eigvq + double precision, dimension(NMODES_EFF, 1) :: tmpm1, tmpm2, tmpm3 + double precision :: tmpDp, tmpTq, tmpo, tmpn + + interface +#ifdef BSA_USE_SVD_METHOD__ + SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, & + VT, LDVT, WORK, LWORK, INFO ) + ! .. Scalar Arguments .. + CHARACTER JOBU, JOBVT + INTEGER LDA, LDU, LDVT, M, N + integer info, lwork + ! .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),& + VT( LDVT, * ), WORK( * ) + end subroutine +#else + SUBROUTINE dsyev( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) + ! .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N + ! .. + ! .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) + END SUBROUTINE +#endif + end interface + + bfm = 0._RDP + fi_(1) = fi + fj_(1) = fj + fiPfj(1) = fi + fj + + + allocate(S_uvw_w1 (NNODESL, NNODESL)) + allocate(S_uvw_w2 (NNODESL, NNODESL)) + allocate(S_uvw_w1w2(NNODESL, NNODESL)) + + + do itc = 1, NTCOMPS + + tc = wd%tc_(itc) + tcP3 = tc + 3 + + ! + ! NODAL WIND TURBULENCEs PSDs (for given tc) + ! + S_uvw_w1(:, 1:1) = & + reshape(wd%evalPSD(1, fi_, NNODESL, struct_data%n_load_, 1, tc), [NNODESL, 1]) + S_uvw_w2(:, 1:1) = & + reshape(wd%evalPSD(1, fj_, NNODESL, struct_data%n_load_, 1, tc), [NNODESL, 1]) + S_uvw_w1w2(:, 1:1) = & + reshape(wd%evalPSD(1, fiPfj, NNODESL, struct_data%n_load_, 1, tc), [NNODESL, 1]) + +#ifdef __BSA_CHECK_NOD_COH_SVD + if (itc == 1) then + write(5482, *) fj_ + do nmw1 = 1, NNODESL + write(5482, *) S_uvw_w2(nmw1, 1) + enddo + endif +#endif + + ! + ! applying spatial nodal coherence + ! + S_uvw_w1 = wd%getFullNodalPSD(NNODESL, struct_data%n_load_, S_uvw_w1(:, 1), fi, 1) + S_uvw_w2 = wd%getFullNodalPSD(NNODESL, struct_data%n_load_, S_uvw_w2(:, 1), fj, 1) + S_uvw_w1w2 = wd%getFullNodalPSD(NNODESL, struct_data%n_load_, S_uvw_w1w2(:, 1), fiPfj(1), 1) + +#ifdef __BSA_CHECK_NOD_COH_SVD + if (itc == 1) then + do nmw1 = 1, NNODESL + write(5483, *) S_uvw_w2(:, nmw1) + enddo + endif +#endif + + !$omp critical +#ifdef BSA_USE_SVD_METHOD__ + call dgesvd(& + 'O' & ! min(M,N) columns of U are overwritten on array A (saves memory) + , 'N' & ! no rows of V are computed + , NNODESL & ! n. of rows M + , NNODESL & ! n. of cols N + , S_uvw_w1 & ! A matrix (overwritten with left-singular vectors) + , NNODESL & + , D_S_uvw_w1 & ! singular values + , tmpv & ! U + , 1 & + , tmpv & ! VT + , 1 & + , MSHR_SVD_WORK & + , MSHR_SVD_LWORK & + , MSHR_SVD_INFO & + ) +#else + call dsyev('V', 'L', & + NNODESL, S_uvw_w1, NNODESL, D_S_uvw_w1, MSHR_SVD_WORK, MSHR_SVD_LWORK, MSHR_SVD_INFO) +#endif + if (MSHR_SVD_INFO /= 0) then + print '(1x, a, a, i0)', & + ERRMSG, 'Error applying SVD to S_uvw_w1. Exit code ', MSHR_SVD_INFO + call bsa_Abort() + endif + + +#ifdef BSA_USE_SVD_METHOD__ + call dgesvd(& + 'O' & ! min(M,N) columns of U are overwritten on array A (saves memory) + , 'N' & ! no rows of V are computed + , NNODESL & ! n. of rows M + , NNODESL & ! n. of cols N + , S_uvw_w2 & ! A matrix (overwritten with left-singular vectors) + , NNODESL & + , D_S_uvw_w2 & ! singular values + , tmpv & ! U + , 1 & + , tmpv & ! VT + , 1 & + , MSHR_SVD_WORK & + , MSHR_SVD_LWORK & + , MSHR_SVD_INFO & + ) +#else + call dsyev('V', 'L', & + NNODESL, S_uvw_w2, NNODESL, D_S_uvw_w2, MSHR_SVD_WORK, MSHR_SVD_LWORK, MSHR_SVD_INFO) +#endif + if (MSHR_SVD_INFO /= 0) then + print '(1x, a, a, i0)', & + ERRMSG, 'Error applying SVD to S_uvw_w2. Exit code ', MSHR_SVD_INFO + call bsa_Abort() + endif + +#ifdef __BSA_CHECK_NOD_COH_SVD + if (itc == 1) then + write(5484, *) NNODESL + write(5484, *) D_S_uvw_w2 + do nmw1 = 1, NNODESL + write(5484, *) S_uvw_w2(:, nmw1) + enddo + endif +#endif + +#ifdef BSA_USE_SVD_METHOD__ + call dgesvd(& + 'O' & ! min(M,N) columns of U are overwritten on array A (saves memory) + , 'N' & ! no rows of V are computed + , NNODESL & ! n. of rows M + , NNODESL & ! n. of cols N + , S_uvw_w1w2 & ! A matrix (overwritten with left-singular vectors) + , NNODESL & + , D_S_uvw_w1w2 & ! singular values + , tmpv & ! U + , 1 & + , tmpv & ! VT + , 1 & + , MSHR_SVD_WORK & + , MSHR_SVD_LWORK & + , MSHR_SVD_INFO & + ) +#else + call dsyev('V', 'L', & + NNODESL, S_uvw_w1w2, NNODESL, D_S_uvw_w1w2, MSHR_SVD_WORK, MSHR_SVD_LWORK, MSHR_SVD_INFO) +#endif + if (MSHR_SVD_INFO /= 0) then + print '(1x, a, a, i0)', & + ERRMSG, 'Error applying SVD to S_uvw_w1w2. Exit code ', MSHR_SVD_INFO + call bsa_Abort() + endif + !$omp end critical + + +#ifdef __BSA_CHECK_NOD_COH_SVD + return +#endif + + + if (do_trunc_POD_) then + nmw1 = 1 + if (.not. all(D_S_uvw_w1 == D_S_uvw_w1(1))) then + tmpn = POD_trunc_lim_ * D_S_uvw_w1(1) + nmw1 = 2 + do while (D_S_uvw_w1(nmw1) >= tmpn) + nmw1 = nmw1 + 1 + enddo + nmw1 = nmw1 - 1 + endif + + nmw2 = 1 + if (.not. all(D_S_uvw_w2 == D_S_uvw_w2(1))) then + tmpn = POD_trunc_lim_ * D_S_uvw_w2(1) + nmw2 = 2 + do while (D_S_uvw_w2(nmw2) >= tmpn) + nmw2 = nmw2 + 1 + enddo + nmw2 = nmw2 - 1 + endif + + nmw1w2 = 1 + if (.not. all(D_S_uvw_w1w2 == D_S_uvw_w1w2(1))) then + tmpn = POD_trunc_lim_ * D_S_uvw_w1w2(1) + nmw1w2 = 2 + do while (D_S_uvw_w1w2(nmw1w2) >= tmpn) + nmw1w2 = nmw1w2 + 1 + enddo + nmw1w2 = nmw1w2 - 1 + endif + + else + nmw1 = NNODESL + nmw2 = nmw1 + nmw1w2 = nmw2 + endif + + + ! 5-2-2, 2-2-5 (6-3-3, 3-3-6) (7-4-4, 4-4-7) + do p = 1, nmw1 + + eigvp(:, 1) = S_uvw_w1(:, p) + + ! V_lin_w1 + ! tmpm1 = matmul(wd%phi_times_A_ndegw_(:, :, tc), eigvp) + do q = 1, NMODES_EFF + tmpm1(q, 1) = sum(wd%phi_times_A_ndegw_(q, :, tc) * eigvp(:, 1)) + enddo + + + ! D_p_w1 + tmpDp = D_S_uvw_w1(p) + + + ! 5-2-2 (6-3-3, 7-4-4) + do q = 1, nmw2 + + eigvq(:, 1) = S_uvw_w2(:, q) + + ! VZ_quad_w1w2 + tmpm2 = matmul(wd%phi_times_A_ndegw_(:, :, tcP3), eigvp * eigvq) + + ! Z_lin_w2 + tmpm3 = matmul(wd%phi_times_A_ndegw_(:, :, tc), eigvq) + + ! T_q_w2 + tmpTq = D_S_uvw_w2(q) + + + posm = 1 + do o = 1, NMODES_EFF + + tmpo = tmpm3(o, 1) + + do n = 1, NMODES_EFF + + tmpn = tmpm1(n, 1) + + do m = 1, NMODES_EFF + + bfm(posm) = bfm(posm) + & + (2 * tmpm2(m, 1) * & + tmpn * & + tmpo * tmpDp * tmpTq) + + posm = posm + 1 + enddo ! m modes + + enddo ! n modes + + enddo ! o modes + + enddo ! q = 1, nmw2 + + + + ! 2-2-5 (3-3-6, 4-4-7) + do q = 1, nmw1w2 + + eigvq(:, 1) = S_uvw_w1w2(:, q) + + ! Z_lin_w1w2 + tmpm2 = matmul(wd%phi_times_A_ndegw_(:, :, tc), eigvq) + + ! VZ_quad_w1w1w2 + tmpm3 = matmul(wd%phi_times_A_ndegw_(:, :, tcP3), eigvp * eigvq) + + ! T_q_w1w2 + tmpTq = D_S_uvw_w1w2(q) + + posm = 1 + do o = 1, NMODES_EFF + + tmpo = tmpm3(o, 1) + + do n = 1, NMODES_EFF + + tmpn = tmpm1(n, 1) + + do m = 1, NMODES_EFF + + bfm(posm) = bfm(posm) + & + (2 * tmpm2(m, 1) * & + tmpn * & + tmpo * tmpDp * tmpTq) + + posm = posm + 1 + enddo ! m modes + enddo ! n modes + + enddo ! o modes + enddo ! q = 1, nmw1w2 + + enddo ! p = 1, nmw1 + + + + ! 2-5-2 (3-6-3, 4-7-4) + do p = 1, nmw1w2 + + eigvp(:, 1) = S_uvw_w1w2(:, p) + + ! V_lin_w1w2 + tmpm1 = matmul(wd%phi_times_A_ndegw_(:, :, tc), eigvp) + + tmpDp = D_S_uvw_w1w2(p) + + do q = 1, nmw2 + + eigvq(:, 1) = S_uvw_w2(:, q) + + ! Z_lin_w2 + tmpm2 = matmul(wd%phi_times_A_ndegw_(:, :, tc), eigvq) + + ! VZ_quad_w1w2w2 + tmpm3 = matmul(wd%phi_times_A_ndegw_(:, :, tcP3), eigvp * eigvq) + + tmpTq = D_S_uvw_w2(q) + + posm = 1 + do o = 1, NMODES_EFF + + tmpo = tmpm2(o, 1) + + do n = 1, NMODES_EFF + + tmpn = tmpm3(n, 1) + + do m = 1, NMODES_EFF + + bfm(posm) = bfm(posm) + & + (2 * tmpm1(m, 1) * & + tmpn * & + tmpo * tmpDp * tmpTq) + + posm = posm + 1 + enddo ! m modes + enddo ! n modes + enddo ! o modes + + enddo ! q = 1, nmw2 + enddo ! p = 1, nmw1w2 + + enddo ! itc = 1, NTCOMPS + + ! !$omp critical + ! !$ write(4382, *) omp_get_thread_num() + ! write(4383, *) fi, fj + ! write(4383, '(21g)') S_uvw_w1 + ! write(4383, *) '' + ! write(4383, '(21g)') S_uvw_w1w2 + ! write(4383, *) MODES + ! !$ write(4384, *) omp_get_thread_num() + ! write(4384, '(g)') bfm + ! write(4384, *) '' + ! !$omp end critical + end function getFM_full_tm_scalar_msh_POD_ + + + + + + + + + + + + module function getRM_full_scalar_msh_(bfm, fi, fj) result(brm) + real(RDP), intent(in) :: bfm(dimM_bisp_), fi, fj + real(RDP) :: brm(dimM_bisp_) + + real(RDP) :: wi, wj, wiPwj + integer(kind = 4) :: posm, imk, imj, imi + + real(RDP), dimension(NMODES_EFF) :: Cdiag, rpart, ipart, htmp + real(RDP), dimension(NMODES_EFF) :: H1r, H1i + real(RDP), dimension(NMODES_EFF) :: H2r, H2i + real(RDP), dimension(NMODES_EFF) :: H12r, H12i + + real(RDP) :: H12k_r, H12k_i, H2j_r, H2j_i + + wi = fi * CST_PIt2 + wj = fj * CST_PIt2 + wiPwj = wi + wj + + + ! pre evaluate TFs (per mode) + + ! H1 + rpart = - (wi*wi * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + do imi = 1, NMODES_EFF + Cdiag(imi) = struct_data%modal_%Cm_(MODES(imi), MODES(imi)) + enddo + ipart = Cdiag * wi + htmp = rpart*rpart + ipart*ipart + H1r = rpart / htmp + H1i = - ipart / htmp + + ! H2 + rpart = - (wj*wj * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + ipart = Cdiag * wj + htmp = rpart*rpart + ipart*ipart + H2r = rpart / htmp + H2i = - ipart / htmp + + + ! H12 + rpart = - (wiPwj*wiPwj * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + ipart = Cdiag * wiPwj + htmp = rpart*rpart + ipart*ipart + H12r = rpart / htmp + H12i = - ipart / htmp + + posm = 1 + do imk = 1, NMODES_EFF + + H12k_r = H12r(imk) + H12k_i = H12i(imk) + + do imj = 1, NMODES_EFF + + H2j_r = H2r(imj) + H2j_i = H2i(imj) + + do imi = 1, NMODES_EFF + + brm(posm) = bfm(posm) * & + (& + H1r(imi) * H2j_r * H12k_r + & + H1r(imi) * H2j_i * H12k_i + & + H1i(imi) * H2j_r * H12k_i - & + H1i(imi) * H2j_i * H12k_r & + ) + + posm = posm + 1 + enddo ! imi + enddo ! imj + enddo ! imk + + end function getRM_full_scalar_msh_ + + + + + + + + + + + + module function getFM_diag_tnm_scalar_msh_(fi, fj) result(bfm) + real(RDP), intent(in) :: fi, fj + real(RDP) :: bfm(dimM_bisp_) + + real(RDP) :: fiPfj(1) + + integer(kind = 4) :: itc, tc, tcP3, posm, imode + integer(kind = 4) :: posi, inode, node, ilibk + + real(RDP), dimension(1, NNODESL) :: Suvw_fi, Suvw_fj, Suvw_fiPfj + real(RDP), dimension(NNODESL) :: Suvw_IJ, Suvw_IJI, Suvw_IJJ + + real(RDP) :: akU, ak, phik(NMODES_EFF) + real(RDP), dimension(NLIBSL, 1) :: aiU, ai + real(RDP), dimension(1, NLIBSL) :: ajU, aj + real(RDP), dimension(NLIBSL, NMODES_EFF) :: phi_ + + real(RDP) :: BF_ijk_I(NLIBSL, NLIBSL) + real(RDP), dimension(NLIBSL, NLIBSL) :: tmp1, tmp2, tmp3 + + bfm = 0._RDP + + fiPfj(1) = fi + fj + + do itc = 1, NTCOMPS + + tc = wd%tc_(itc) + tcP3 = tc + 3 ! quadratic term coeff + + Suvw_fi = wd%evalPSD(1, [fi], NNODESL, struct_data%n_load_, 1, tc) + + Suvw_fj = wd%evalPSD(1, [fj], NNODESL, struct_data%n_load_, 1, tc) + + Suvw_fiPfj = wd%evalPSD(1, fiPfj, NNODESL, struct_data%n_load_, 1, tc) + + + ! precompute for perf + Suvw_IJ = Suvw_fi(1, :) * Suvw_fj(1, :) + Suvw_IJI = Suvw_IJ(:) * Suvw_fi(1, :) + Suvw_IJJ = Suvw_IJ(:) * Suvw_fj(1, :) + + + do inode = 1, NNODESL + + node = int(struct_data%n_load_(inode), 4) + + posi = (node - 1) * NLIBS + phi_ = struct_data%modal_%phi_(posi + struct_data%libs_load_, MODES) + + + ajU(1, :) = wd%wfc_(struct_data%libs_load_, tc, inode) + aj (1, :) = wd%wfc_(struct_data%libs_load_, tcP3, inode) + + aiU(:, 1) = ajU(1, :) + ai (:, 1) = aj (1, :) + + + ! NOTE: this are tmp values !!!!! + ! Done for performance. + tmp1 = Suvw_IJ (inode) * matmul(ai , ajU) + tmp2 = Suvw_IJJ(inode) * matmul(aiU, aj ) + tmp3 = Suvw_IJI(inode) * matmul(aiU, ajU) + + + do ilibk = 1, NLIBSL + + phik = phi_(ilibk, :) + + akU = aiU(ilibk, 1) + ak = ai (ilibk, 1) + + + BF_ijk_I = 2 * (& + tmp1 * akU + & + tmp2 * akU + & + tmp3 * ak & + ) + + + posm = 1 + do imode = 1, NMODES_EFF + + bfm(posm) = bfm(posm) + & + sum( & + BF_ijk_I * & + (matmul(phi_(:, imode:imode), transpose(phi_(:, imode:imode))) & + * phik(imode)) ) + + posm = posm + 1 + enddo ! modes + + enddo ! libs loaded (k) + enddo ! nodes loaded + enddo ! n turb comps + + end function getFM_diag_tnm_scalar_msh_ + + + + + module function getRM_diag_scalar_msh_(bfm, fi, fj) result(brm) + real(RDP), intent(in) :: bfm(dimM_bisp_), fi, fj + real(RDP) :: brm(dimM_bisp_) + + real(RDP) :: wi, wj, wiPwj + integer(kind = 4) :: imi + + real(RDP), dimension(NMODES_EFF) :: Cdiag, rpart, ipart, htmp + real(RDP), dimension(NMODES_EFF) :: H1r, H1i + real(RDP), dimension(NMODES_EFF) :: H2r, H2i + real(RDP), dimension(NMODES_EFF) :: H12r, H12i + + + wi = fi * CST_PIt2 + wj = fj * CST_PIt2 + wiPwj = wi + wj + + + ! pre evaluate TFs (per mode) + + ! H1 + rpart = - (wi*wi * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + do imi = 1, NMODES_EFF + Cdiag(imi) = struct_data%modal_%Cm_(MODES(imi), MODES(imi)) + enddo + ipart = Cdiag * wi + htmp = rpart*rpart + ipart*ipart + H1r = rpart / htmp + H1i = - ipart / htmp + + ! H2 + rpart = - (wj*wj * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + ipart = Cdiag * wj + htmp = rpart*rpart + ipart*ipart + H2r = rpart / htmp + H2i = - ipart / htmp + + + ! H12 + rpart = - (wiPwj*wiPwj * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + ipart = Cdiag * wiPwj + htmp = rpart*rpart + ipart*ipart + H12r = rpart / htmp + H12i = - ipart / htmp + + brm = bfm * (& + H1r * H2r * H12r + & + H1r * H2i * H12i + & + H1i * H2r * H12i - & + H1i * H2i * H12r & + ) + + end function getRM_diag_scalar_msh_ + + + + + + + + + + + +!!======================================================================================== +!!======================================================================================== +!!======================================================================================== +!! +!! classic +!! +!!======================================================================================== +!!======================================================================================== +!!======================================================================================== + + + + + + !> BUG: this routine is adapted to the case where we use + !> convention on PULSATION. + !> Please, adapt it to the case of convention over FREQUENCIES. + module subroutine getFM_full_tnlm_vect_cls_(f, Suvw, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + + integer(kind = 4) :: innl3 + integer(kind = 4) :: iin, ien, itmp, ifrj + integer(kind = 4) :: i_n_pad, i_pad_len + + ! turb components related + integer(kind = 4) :: itc, tc, tc_posN, tc_pk, tc_pj, tc_pi + + ! nodes indexed values + integer(kind = 4) :: i_pos_nk, i_pos_nj, i_pos_ni + integer(kind = 4) :: pos_nk, pos_nj, pos_ni + integer(kind = 4) :: ink, inj, ini + integer(kind = 4) :: ni, nj, nk + + ! libs indexed values + integer(kind = 4) :: ilk, ilj, ili + ! integer(kind = 4) :: li, lj, lk + + ! modes indexed values + real(RDP), dimension(NLIBSL, NMODES_EFF) :: phik_, phij_, phii_ + real(RDP) :: phik, phij, phii + integer(kind = 4) :: posm_ + integer(kind = 4) :: imk, imj, imi + ! integer(kind = 4) :: mi, mj, mk + + integer(kind = 4) :: i_ncycles = 0 + + real(RDP) :: f_abs(NFREQS) + + ! local nodal correlations + real(RDP) :: corrJK, corrIK, corrIJ + + ! wfc extractions + integer(kind = 4) :: tcP3 + real(RDP), dimension(NLIBSL) :: aiU, ai, akU, ak + real(RDP), dimension(NLIBSL) :: ajU, aj + + ! PSDs local + real(RDP), allocatable :: S_uvw_i(:), S_uvw_j(:), S_uvw_k(:), PSDF_jk_JK_w(:) + real(RDP), allocatable :: S_uvw_JK(:), S_uvw_IK(:), S_uvw_IJ(:) + real(RDP), allocatable :: S_uvw_IK_w1w2(:), S_uvw_IJ_w1w2(:) + + ! BF local + real(RDP), allocatable :: BF_ijk_IJK_w_w2(:) + + character(len = 256) :: emsg + !======================================================================== + + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getFM_full_tnlm_vect_cls_() : computing modal forces spectra...' +#endif + + + f_abs = abs(f) + innl3 = NNODESL**3 + + + ! getting padded length and relative init/end indices (non zero zone) + itmp = NFREQS - 1 ! do not consider 0 (point of symmetry) + i_n_pad = itmp / 2 ! spread it on the two sides (left / right) + ! iin = i_n_pad + 1 + ! ien = in + itmp + ien = i_n_pad + NFREQS + iin = i_n_pad + 1 + i_pad_len = itmp + NFREQS + + +#ifdef __BSA_DEBUG + print '(1x, a, i5)', '@BsaClassicImpl::getFM_full_tnlm_vect_cls_() : i pad length = ', i_pad_len + print '(1x, a, i5)', '@BsaClassicImpl::getFM_full_tnlm_vect_cls_() : init index = ', iin + print '(1x, a, i5)', '@BsaClassicImpl::getFM_full_tnlm_vect_cls_() : end index = ', ien + print '(1x, a, i5)', '@BsaClassicImpl::getFM_full_tnlm_vect_cls_() : pad range = ', ien - iin + 1 +#endif + + + ! these are needed regardlessly of if PSDs or BISPs + + allocate(psd(NFREQS, dimM_psd_), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('psd', [NFREQS, dimM_psd_], loc(psd), sizeof(psd)) +#endif + else + call allocKOMsg('psd', ilk, emsg) + endif + psd = 0._RDP + + allocate(S_uvw_k(NFREQS), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_k', NFREQS, loc(S_uvw_k), sizeof(S_uvw_k)) +#endif + else + call allocKOMsg('S_uvw_k', ilk, emsg) + endif + + allocate(S_uvw_j(NFREQS), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_j', NFREQS, loc(S_uvw_j), sizeof(S_uvw_j)) +#endif + else + call allocKOMsg('S_uvw_j', ilk, emsg) + endif + + allocate(S_uvw_JK(NFREQS), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_JK', NFREQS, loc(S_uvw_JK), sizeof(S_uvw_JK)) +#endif + else + call allocKOMsg('S_uvw_JK', ilk, emsg) + endif + + allocate(PSDF_jk_JK_w(NFREQS), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('PSDF_jk_JK_w', NFREQS, loc(PSDF_jk_JK_w), sizeof(PSDF_jk_JK_w)) +#endif + else + call allocKOMsg('PSDF_jk_JK_w', ilk, emsg) + endif + + if (settings%i_compute_bisp_ == 1) then + + allocate(bisp(NFREQS, NFREQS, dimM_bisp_), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('bisp', [NFREQS, NFREQS, dimM_bisp_], loc(bisp), sizeof(bisp)) +#endif + else + call allocKOMsg('bisp', ilk, emsg) + endif + bisp = 0._RDP + + allocate(bf_ijk_IJK_w_w2(NFREQS), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg(& + 'bf_ijk_IJK_w_w2', NFREQS, loc(bf_ijk_IJK_w_w2), sizeof(bf_ijk_IJK_w_w2)) +#endif + else + call allocKOMsg('bf_ijk_IJK_w_w2', ilk, emsg) + endif + + allocate(S_uvw_i(NFREQS), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_i', NFREQS, loc(S_uvw_i), sizeof(S_uvw_i)) +#endif + else + call allocKOMsg('S_uvw_i', ilk, emsg) + endif + + allocate(S_uvw_IK(NFREQS), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_IK', NFREQS, loc(S_uvw_IK), sizeof(S_uvw_IK)) +#endif + else + call allocKOMsg('S_uvw_IK', ilk, emsg) + endif + + allocate(S_uvw_IJ(NFREQS), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_IJ', NFREQS, loc(S_uvw_IJ), sizeof(S_uvw_IJ)) +#endif + else + call allocKOMsg('S_uvw_IJ', ilk, emsg) + endif + + allocate(S_uvw_IK_w1w2(i_pad_len), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_IK_w1w2', i_pad_len, loc(S_uvw_IK_w1w2), sizeof(S_uvw_IK_w1w2)) +#endif + else + call allocKOMsg('S_uvw_IK_w1w2', ilk, emsg) + endif + + allocate(S_uvw_IJ_w1w2(i_pad_len), stat=ilk, errmsg=emsg) + if (ilk == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_IJ_w1w2', i_pad_len, loc(S_uvw_IJ_w1w2), sizeof(S_uvw_IJ_w1w2)) +#endif + else + call allocKOMsg('S_uvw_IJ_w1w2', ilk, emsg) + endif + + endif + + + + !======================================================================== + ! BUG: for the moment, only considering correlation + ! between same turbulence component (u, v, w). + ! No cross-correlation between turbulent components + ! i.e. E[uv]==E[uw]==E[vw] === 0 + do itc = 1, NTCOMPS + + tc = wd%tc_(itc) ! get actual turbulent component + tcP3 = tc + 3 ! quadratic term coeff + tc_posN = (itc - 1) * NNODESL + + + i_pos_nk = 1 + do ink = 1, NNODESL + + nk = struct_data%n_load_(ink) + pos_nk = (nk - 1) * NLIBS + tc_pk = tc_posN + i_pos_nk + + phik_ = struct_data%modal_%phi_(pos_nk + struct_data%libs_load_, MODES) + + akU(:) = wd%wfc_(struct_data%libs_load_, tc, ink) + ak (:) = wd%wfc_(struct_data%libs_load_, tcP3, ink) + + S_uvw_k = Suvw(:, tc_pk) + ! if (settings%i_only_psd_ == 0) S_uvw_pad_k(iin : ien) = S_uvw_k + + + i_pos_nj = 1 + do inj = 1, NNODESL + + nj = struct_data%n_load_(inj) + pos_nj = (nj - 1) * NLIBS + tc_pj = tc_posN + i_pos_nj + + phij_ = struct_data%modal_%phi_(pos_nj + struct_data%libs_load_, MODES) + + ajU(:) = wd%wfc_(struct_data%libs_load_, tc, inj) + aj (:) = wd%wfc_(struct_data%libs_load_, tcP3, inj) + + ! BUG: inserted itc, was 1 + corrJK = wd%nod_corr_(util_getCorrVectIndex(nj, nk, NNODES), tc) + + + S_uvw_j = Suvw(:, tc_pj) + ! if (settings%i_only_psd_ == 0) S_uvw_pad_j(iin : ien) = S_uvw_j + + S_uvw_JK = corrJK**(f_abs) * sqrt(S_uvw_k * S_uvw_j) + + + !! BISPs + if (settings%i_compute_bisp_ == 1) then + + i_pos_ni = 1 + do ini = 1, NNODESL + + ni = struct_data%n_load_(ini) + pos_ni = (ni - 1) * NLIBS + tc_pi = tc_posN + i_pos_ni + + phii_ = struct_data%modal_%phi_(pos_ni + struct_data%libs_load_, MODES) + + aiU(:) = wd%wfc_(struct_data%libs_load_, tc, ini) + ai (:) = wd%wfc_(struct_data%libs_load_, tcP3, ini) + + corrIK = wd%nod_corr_(util_getCorrVectIndex(ni, nk, NNODES), tc) + corrIJ = wd%nod_corr_(util_getCorrVectIndex(ni, nj, NNODES), tc) + + S_uvw_i = Suvw(:, tc_pi) + + + S_uvw_IK = corrIK**(f_abs) * sqrt(S_uvw_i * S_uvw_k) + S_uvw_IK_w1w2(iin : ien) = S_uvw_IK + + + S_uvw_IJ = corrIJ**(f_abs) * sqrt(S_uvw_i * S_uvw_j) + S_uvw_IJ_w1w2(iin : ien) = S_uvw_IJ + + + + ! loop on frequencies (second dimension, j) + itmp = NFREQS + do ifrj = 1, NFREQS + + + do ilk = 1, NLIBSL + + ! lk = struct_data%libs_load_(ilk) + + do ilj = 1, NLIBSL + + ! lj = struct_data%libs_load_(ilj) + + + do ili = 1, NLIBSL + + ! li = struct_data%libs_load_(ili) + + + BF_ijk_IJK_w_w2 = 2 * (& + ai (ili) * ajU(ilj) * akU(ilk) * (S_uvw_IJ * S_uvw_IK(ifrj)) + & + aiU(ili) * aj (ilj) * akU(ilk) * (S_uvw_IJ_w1w2(ifrj : itmp) * S_uvw_JK(ifrj)) + & + aiU(ili) * ajU(ilj) * ak (ilk) * (S_uvw_JK * S_uvw_IK_w1w2(ifrj : itmp)) & + &) + + + ! if (all(BF_ijk_IJK_w_w2 == 0._RDP)) cycle + + + posm_ = 1 + do imk = 1, NMODES_EFF + + ! mk = struct_data%modal_%modes_(imk) + phik = phik_(ilk, imk) + + do imj = 1, NMODES_EFF + + ! mj = struct_data%modal_%modes_(imj) + phij = phij_(ilj, imj) + + + ! TODO: this loop can be suppressed + do imi = 1, NMODES_EFF + + ! mi = struct_data%modal_%modes_(imi) + phii = phii_(ili, imi) + + bisp(:, ifrj, posm_) = bisp(:, ifrj, posm_) + & + phik * phij * phii * BF_ijk_IJK_w_w2 + + posm_ = posm_ + 1 + enddo ! i mode + enddo ! j mode + enddo ! k mode + + enddo ! i lib + enddo ! j lib + enddo ! k lib + + itmp = itmp + 1 + enddo ! n freqs j + + + i_pos_ni = i_pos_ni + 1 + enddo ! i node + +#ifdef __BSA_DEBUG + i_ncycles = i_ncycles + NNODESL + print '(1x, a, a, f10.4, " %")', & + INFOMSG, 'getFM_full_tnlm_vect_cls_() : done ', & + real(i_ncycles, RDP)/innl3*100 +#endif + + endif ! bisp computation + + + + !! PSDs + do ilk = 1, NLIBSL + + ! lk = struct_data%libs_load_(ilk) + ! if (akU(ilk) == 0.0_RDP) cycle + + + do ilj = 1, NLIBSL + + ! lj = struct_data%libs_load_(ilj) + ! if (ajU(ilj) == 0.0_RDP) cycle + + + ! PSD f + PSDF_jk_JK_w = ajU(ilj) * akU(ilk) * S_uvw_JK + + ! if (all(PSDF_jk_JK_w == 0.0_RDP)) cycle + + + posm_ = 1 + do imk = 1, NMODES_EFF + + ! mk = struct_data%modal_%modes_(imk) + phik = phik_(ilk, imk) + ! if (phik == 0.0_RDP) cycle + + do imj = 1, NMODES_EFF + + ! mj = struct_data%modal_%modes_(imj) + phij = phij_(ilj, imj) + ! if (phij == 0.0_RDP) cycle + + psd(:, posm_) = psd(:, posm_) + & + phik * phij * PSDF_jk_JK_w + +! #ifdef __BSA_DEBUG +! write(unit_debug_, & +! '(1x, a, 5(i0, ", "), i0, " ; ", 2(2x, g0, " - ", g0) )') & +! ' nk, nj, lk, lj, mk, mj : ', & +! nk, nj, & +! struct_data%libs_load_(ilk), struct_data%libs_load_(ilj), & +! imk, imj, & +! akU(ilk), ajU(ilj), & +! phik, phij +! #endif + + + posm_ = posm_ + 1 + enddo ! j mode + enddo ! k mode + + enddo ! j lib + enddo ! k lib + + + i_pos_nj = i_pos_nj + 1 + enddo ! j node + + + i_pos_nk = i_pos_nk + 1 + enddo ! k node + + + enddo ! itc + + + + ! deallocation + if (allocated(S_uvw_i)) deallocate(S_uvw_i) + if (allocated(S_uvw_j)) deallocate(S_uvw_j) + if (allocated(S_uvw_k)) deallocate(S_uvw_k) + if (allocated(PSDF_jk_JK_w)) deallocate(PSDF_jk_JK_w) + if (allocated(S_uvw_JK)) deallocate(S_uvw_JK) + if (allocated(S_uvw_IK)) deallocate(S_uvw_IK) + if (allocated(S_uvw_IJ)) deallocate(S_uvw_IJ) + if (allocated(S_uvw_IK_w1w2)) deallocate(S_uvw_IK_w1w2) + if (allocated(S_uvw_IJ_w1w2)) deallocate(S_uvw_IJ_w1w2) + if (allocated(BF_ijk_IJK_w_w2)) deallocate(BF_ijk_IJK_w_w2) + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getFM_full_tnlm_vect_cls_() : computing modal forces spectra -- ok.' +#endif + end subroutine getFM_full_tnlm_vect_cls_ + + + + + + + + + + + + + + !> BUG: this routine is adapted to the case where we use + !> convention on PULSATION. + !> Please, adapt it to the case of convention over FREQUENCIES. + module subroutine getFM_full_tnm_vect_cls_(f, Suvw, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + + integer(kind = 4) :: innl3 + integer(kind = 4) :: iin, ien, itmp, ifrj + integer(kind = 4) :: i_n_pad, i_pad_len + + ! turb components related + integer(kind = 4) :: itc, tc, tc_posN, tc_pk, tc_pj, tc_pi + + ! nodes indexed values + integer(kind = 4) :: i_pos_nk, i_pos_nj, i_pos_ni + integer(kind = 4) :: pos_nk, pos_nj, pos_ni + integer(kind = 4) :: ink, inj, ini + integer(kind = 4) :: ni, nj, nk + + ! modes indexed values + real(RDP), dimension(NMODES_EFF, 2) :: phik_, phij_, phii_ + real(RDP) :: phij_Ub_, phij_u_, phik_Ub_, phik_u_ + integer(kind = 4) :: posm_ + integer(kind = 4) :: imk, imj, imi + + integer(kind = 4) :: i_ncycles = 0 + + real(RDP) :: f_abs(NFREQS) + + ! local nodal correlations + real(RDP) :: corrJK, corrIK, corrIJ + + ! wfc extractions + integer(kind = 4) :: tcP3 + + ! PSDs local + real(RDP), allocatable :: S_uvw_i(:), S_uvw_j(:), S_uvw_k(:), PSDF_jk_JK_w(:) + real(RDP), allocatable :: S_uvw_JK(:), S_uvw_IK(:), S_uvw_IJ(:) + real(RDP), allocatable :: S_uvw_IK_w1w2(:), S_uvw_IJ_w1w2(:) + + ! BF local + real(RDP), allocatable :: BF_ijk_IJK_w_w2(:), tmp1(:), tmp2(:), tmp3(:) + + character(len = 256) :: emsg + !======================================================================== + + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getFM_full_tnm_vect_cls_() : computing modal forces spectra...' +#endif + + + f_abs = abs(f) + innl3 = NNODESL**3 + + + ! getting padded length and relative init/end indices (non zero zone) + itmp = NFREQS - 1 ! do not consider 0 (point of symmetry) + i_n_pad = itmp / 2 ! spread it on the two sides (left / right) + ! iin = i_n_pad + 1 + ! ien = in + itmp + ien = i_n_pad + NFREQS + iin = i_n_pad + 1 + i_pad_len = itmp + NFREQS + + +#ifdef __BSA_DEBUG + print '(1x, a, i5)', '@BsaClassicImpl::getFM_full_tnm_vect_cls_() : i pad length = ', i_pad_len + print '(1x, a, i5)', '@BsaClassicImpl::getFM_full_tnm_vect_cls_() : init index = ', iin + print '(1x, a, i5)', '@BsaClassicImpl::getFM_full_tnm_vect_cls_() : end index = ', ien + print '(1x, a, i5)', '@BsaClassicImpl::getFM_full_tnm_vect_cls_() : pad range = ', ien - iin + 1 +#endif + + + ! these are needed regardlessly of if PSDs or BISPs + + allocate(psd(NFREQS, dimM_psd_), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('psd', [NFREQS, dimM_psd_], loc(psd), sizeof(psd)) +#endif + else + call allocKOMsg('psd', itc, emsg) + endif + psd = 0._RDP + + allocate(S_uvw_k(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_k', NFREQS, loc(S_uvw_k), sizeof(S_uvw_k)) +#endif + else + call allocKOMsg('S_uvw_k', itc, emsg) + endif + + allocate(S_uvw_j(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_j', NFREQS, loc(S_uvw_j), sizeof(S_uvw_j)) +#endif + else + call allocKOMsg('S_uvw_j', itc, emsg) + endif + + allocate(S_uvw_JK(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_JK', NFREQS, loc(S_uvw_JK), sizeof(S_uvw_JK)) +#endif + else + call allocKOMsg('S_uvw_JK', itc, emsg) + endif + + allocate(PSDF_jk_JK_w(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('PSDF_jk_JK_w', NFREQS, loc(PSDF_jk_JK_w), sizeof(PSDF_jk_JK_w)) +#endif + else + call allocKOMsg('PSDF_jk_JK_w', itc, emsg) + endif + + if (settings%i_compute_bisp_ == 1) then + + allocate(bisp(NFREQS, NFREQS, dimM_bisp_), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('bisp', [NFREQS, NFREQS, dimM_bisp_], loc(bisp), sizeof(bisp)) +#endif + else + call allocKOMsg('bisp', itc, emsg) + endif + bisp = 0._RDP + + allocate(bf_ijk_IJK_w_w2(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg(& + 'bf_ijk_IJK_w_w2', NFREQS, loc(bf_ijk_IJK_w_w2), sizeof(bf_ijk_IJK_w_w2)) +#endif + else + call allocKOMsg('bf_ijk_IJK_w_w2', itc, emsg) + endif + + allocate(tmp1(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg(& + 'tmp1', NFREQS, loc(tmp1), sizeof(tmp1)) +#endif + else + call allocKOMsg('tmp1', itc, emsg) + endif + + allocate(tmp2(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg(& + 'tmp2', NFREQS, loc(tmp2), sizeof(tmp2)) +#endif + else + call allocKOMsg('tmp2', itc, emsg) + endif + + allocate(tmp3(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg(& + 'tmp3', NFREQS, loc(tmp3), sizeof(tmp3)) +#endif + else + call allocKOMsg('tmp3', itc, emsg) + endif + + allocate(S_uvw_i(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_i', NFREQS, loc(S_uvw_i), sizeof(S_uvw_i)) +#endif + else + call allocKOMsg('S_uvw_i', itc, emsg) + endif + + allocate(S_uvw_IK(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_IK', NFREQS, loc(S_uvw_IK), sizeof(S_uvw_IK)) +#endif + else + call allocKOMsg('S_uvw_IK', itc, emsg) + endif + + allocate(S_uvw_IJ(NFREQS), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_IJ', NFREQS, loc(S_uvw_IJ), sizeof(S_uvw_IJ)) +#endif + else + call allocKOMsg('S_uvw_IJ', itc, emsg) + endif + + allocate(S_uvw_IK_w1w2(i_pad_len), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_IK_w1w2', i_pad_len, loc(S_uvw_IK_w1w2), sizeof(S_uvw_IK_w1w2)) +#endif + else + call allocKOMsg('S_uvw_IK_w1w2', itc, emsg) + endif + + allocate(S_uvw_IJ_w1w2(i_pad_len), stat=itc, errmsg=emsg) + if (itc == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('S_uvw_IJ_w1w2', i_pad_len, loc(S_uvw_IJ_w1w2), sizeof(S_uvw_IJ_w1w2)) +#endif + else + call allocKOMsg('S_uvw_IJ_w1w2', itc, emsg) + endif + + endif ! i bisp allocation + + + + !======================================================================== + ! BUG: for the moment, only considering correlation + ! between same turbulence component (u, v, w). + ! No cross-correlation between turbulent components + ! i.e. E[uv]==E[uw]==E[vw] === 0 + do itc = 1, NTCOMPS + + tc = wd%tc_(itc) ! get actual turbulent component + tcP3 = tc + 3 ! quadratic term coeff + tc_posN = (itc - 1) * NNODESL + + + i_pos_nk = 1 + do ink = 1, NNODESL + + nk = struct_data%n_load_(ink) + pos_nk = (nk - 1) * NLIBS + tc_pk = tc_posN + i_pos_nk + + phik_(:, 1) = wd%phi_times_A_ndegw_(:, ink, tc ) + phik_(:, 2) = wd%phi_times_A_ndegw_(:, ink, tcP3) + + S_uvw_k = Suvw(:, tc_pk) + + i_pos_nj = 1 + do inj = 1, NNODESL + + nj = struct_data%n_load_(inj) + pos_nj = (nj - 1) * NLIBS + tc_pj = tc_posN + i_pos_nj + + phij_(:, 1) = wd%phi_times_A_ndegw_(:, inj, tc ) + phij_(:, 2) = wd%phi_times_A_ndegw_(:, inj, tcP3) + + corrJK = wd%nod_corr_(util_getCorrVectIndex(nj, nk, NNODES), tc) + + S_uvw_j = Suvw(:, tc_pj) + S_uvw_JK = corrJK**(f_abs) * sqrt(S_uvw_k * S_uvw_j) + + + !! BISPs + if (settings%i_compute_bisp_ == 1) then + + i_pos_ni = 1 + do ini = 1, NNODESL + + ni = struct_data%n_load_(ini) + pos_ni = (ni - 1) * NLIBS + tc_pi = tc_posN + i_pos_ni + + phii_(:, 1) = wd%phi_times_A_ndegw_(:, ini, tc ) + phii_(:, 2) = wd%phi_times_A_ndegw_(:, ini, tcP3) + + corrIK = wd%nod_corr_(util_getCorrVectIndex(ni, nk, NNODES), tc) + corrIJ = wd%nod_corr_(util_getCorrVectIndex(ni, nj, NNODES), tc) + + S_uvw_i = Suvw(:, tc_pi) + + S_uvw_IK = corrIK**(f_abs) * sqrt(S_uvw_i * S_uvw_k) + S_uvw_IK_w1w2(iin : ien) = S_uvw_IK + + S_uvw_IJ = corrIJ**(f_abs) * sqrt(S_uvw_i * S_uvw_j) + S_uvw_IJ_w1w2(iin : ien) = S_uvw_IJ + + + ! loop on frequencies (second dimension, j) + itmp = NFREQS + do ifrj = 1, NFREQS + + tmp1 = S_uvw_IJ * S_uvw_IK(ifrj) + tmp2 = S_uvw_IJ_w1w2(ifrj : itmp) * S_uvw_JK(ifrj) + tmp3 = S_uvw_JK * S_uvw_IK_w1w2(ifrj : itmp) + + posm_ = 1 + do imk = 1, NMODES_EFF + + phik_Ub_ = phik_(imk, 1) + phik_u_ = phik_(imk, 2) + + do imj = 1, NMODES_EFF + + phij_Ub_ = phij_(imj, 1) + phij_u_ = phij_(imj, 2) + + ! TODO: this loop can be suppressed + do imi = 1, NMODES_EFF + + bisp(:, ifrj, posm_) = bisp(:, ifrj, posm_) + & + 2 * ( & + (phii_(imi, 2) * phij_Ub_ * phik_Ub_ * tmp1) & + + (phii_(imi, 1) * phij_u_ * phik_Ub_ * tmp2) & + + (phii_(imi, 1) * phij_Ub_ * phik_u_ * tmp3) & + ) + + posm_ = posm_ + 1 + enddo ! i mode + enddo ! j mode + enddo ! k mode + + itmp = itmp + 1 + enddo ! n freqs j + + + i_pos_ni = i_pos_ni + 1 + enddo ! i node + +! #ifdef __BSA_DEBUG + i_ncycles = i_ncycles + NNODESL + print '(1x, a, a, f10.4, " %")', & + INFOMSG, 'getFM_full_tnm_vect_cls_() : done ', & + real(i_ncycles, RDP)/innl3*100 +! #endif + + endif ! bisp computation + + + + posm_ = 1 + do imk = 1, NMODES_EFF + + phik_Ub_ = phik_(imk, 1) + + do imj = 1, NMODES_EFF + + psd(:, posm_) = psd(:, posm_) + & + (phik_Ub_ * phij_(imj, 1) * S_uvw_JK) + + posm_ = posm_ + 1 + enddo ! j mode + enddo ! k mode + + + i_pos_nj = i_pos_nj + 1 + enddo ! j node + + + i_pos_nk = i_pos_nk + 1 + enddo ! k node + + enddo ! itc + + + + ! deallocation + if (allocated(S_uvw_i)) deallocate(S_uvw_i) + if (allocated(S_uvw_j)) deallocate(S_uvw_j) + if (allocated(S_uvw_k)) deallocate(S_uvw_k) + if (allocated(PSDF_jk_JK_w)) deallocate(PSDF_jk_JK_w) + if (allocated(S_uvw_JK)) deallocate(S_uvw_JK) + if (allocated(S_uvw_IK)) deallocate(S_uvw_IK) + if (allocated(S_uvw_IJ)) deallocate(S_uvw_IJ) + if (allocated(S_uvw_IK_w1w2)) deallocate(S_uvw_IK_w1w2) + if (allocated(S_uvw_IJ_w1w2)) deallocate(S_uvw_IJ_w1w2) + if (allocated(BF_ijk_IJK_w_w2)) deallocate(BF_ijk_IJK_w_w2) + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getFM_full_tnm_vect_cls_() : computing modal forces spectra -- ok.' +#endif + end subroutine getFM_full_tnm_vect_cls_ + + + + + + + + + + + module subroutine getRM_full_vect_cls_(f, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + + integer(kind = 4) :: ifrj + integer(kind = 4) :: posm_psd = 1, posm_bisp = 1 + + ! modal indexed + integer(kind = 4) :: imi, imj, imk, mi + + real(RDP) :: omegas(NFREQS, 1) + real(RDP), allocatable :: r_part(:, :), i_part(:, :), h_tmp(:, :), h_tmp2(:, :) + real(RDP), allocatable :: Hr_w(:, :), Hi_w(:, :) + real(RDP), allocatable :: Hr_w1w2(:, :, :), Hi_w1w2(:, :, :) + + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getRM_full_vect_cls_() : computing modal responses spectra...' +#endif + + ! BUG: check logic if correct + if (settings%i_compute_bisp_ == 1) then + + allocate(r_part(NFREQS, NFREQS)) + allocate(i_part(NFREQS, NFREQS)) + allocate(h_tmp(NFREQS, NFREQS)) + allocate(h_tmp2(NFREQS, NFREQS)) + allocate(Hr_w1w2(NFREQS, NFREQS, NMODES_EFF)) + allocate(Hi_w1w2(NFREQS, NFREQS, NMODES_EFF)) + + elseif (settings%i_compute_psd_ == 1) then + + allocate(r_part(NFREQS, 1)) + allocate(i_part(NFREQS, 1)) + allocate(h_tmp(NFREQS, 1)) + + else ! none of them ?? + return + endif + + + ! TRANSFER FUNCTION COMPUTATION + + omegas(:, 1) = f * CST_PIt2 + + allocate(Hr_w(NFREQS, NMODES_EFF)) + allocate(Hi_w(NFREQS, NMODES_EFF)) + + + do imi = 1, NMODES_EFF + + mi = MODES(imi) + + ! H1 / H2 + r_part(:, 1) = - (omegas(:, 1)*omegas(:, 1) * struct_data%modal_%Mm_(mi)) + struct_data%modal_%Km_(mi) + i_part(:, 1) = omegas(:, 1) * struct_data%modal_%Cm_(mi, mi) + h_tmp(:, 1) = r_part(:, 1)*r_part(:, 1) + i_part(:, 1)*i_part(:, 1) + + Hr_w(:, imi) = r_part(:, 1) / h_tmp(:, 1) + Hi_w(:, imi) = - i_part(:, 1) / h_tmp(:, 1) + + if (settings%i_compute_bisp_ == 1) then + ! H12 + do ifrj = 1, NFREQS + h_tmp(:, ifrj) = omegas(:, 1) + omegas(ifrj, 1) + enddo + r_part = - (h_tmp*h_tmp * struct_data%modal_%Mm_(mi)) + struct_data%modal_%Km_(mi) + i_part = h_tmp * struct_data%modal_%Cm_(mi, mi) + h_tmp = r_part*r_part + i_part*i_part + + Hr_w1w2(:, :, imi) = r_part / h_tmp + Hi_w1w2(:, :, imi) = - i_part / h_tmp + endif + enddo + + + ! first deallocation + if (allocated(r_part)) deallocate(r_part) + if (allocated(i_part)) deallocate(i_part) + + + ! BUG: optimise memory accesses !!! + do imk = 1, NMODES_EFF + + if (settings%i_compute_bisp_ == 1) then + h_tmp = Hr_w1w2(:, :, imk) + h_tmp2= Hi_w1w2(:, :, imk) + endif + + do imj = 1, NMODES_EFF + + psd(:, posm_psd) = & + psd(:, posm_psd) * & + ( Hr_w(:, imk) * Hr_w(:, imj) + & + Hi_w(:, imk) * Hi_w(:, imj) ) + + ! BISPs + if (settings%i_compute_bisp_ == 1) then + + do imi = 1, NMODES_EFF + + do ifrj = 1, NFREQS + + bisp(:, ifrj, posm_bisp) = & + bisp(:, ifrj, posm_bisp) * & + ( Hr_w(:, imi) * Hr_w(ifrj, imj) * h_tmp(:, ifrj) + & + Hr_w(:, imi) * Hi_w(ifrj, imj) * h_tmp2(:, ifrj) + & + Hi_w(:, imi) * Hr_w(ifrj, imj) * h_tmp2(:, ifrj) - & + Hi_w(:, imi) * Hi_w(ifrj, imj) * h_tmp(:, ifrj) ) + enddo + + posm_bisp = posm_bisp + 1 + enddo ! i mode + endif ! i bisp + + posm_psd = posm_psd + 1 + enddo ! j mode + enddo ! k mode + + + ! deallocate what s remained + if (allocated(Hr_w)) deallocate(Hr_w) + if (allocated(Hi_w)) deallocate(Hi_w) + if (allocated(h_tmp)) deallocate(h_tmp) + + if (settings%i_compute_bisp_ == 1) then + if (allocated(h_tmp2)) deallocate(h_tmp2) + if (allocated(Hr_w1w2)) deallocate(Hr_w1w2) + if (allocated(Hi_w1w2)) deallocate(Hi_w1w2) + endif + + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getRM_full_vect_cls_() : computing modal responses spectra -- ok.' +#endif + end subroutine getRM_full_vect_cls_ + + + + + + + + + module subroutine getFM_diag_tnlm_vect_cls_(f, Suvw, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), intent(inout), allocatable :: psd(:, :), bisp(:, :, :) + + integer(kind = 4) :: iin = 0, ien = 0, itmp = 0, ifrj = 0 + integer(kind = 4) :: i_n_pad = 0, i_pad_len = 0 + + ! turb components related + integer(kind = 4) :: itc = 0, tc_pos = 0, tc_posN = 0 + integer(kind = 4) :: tc, tcP3 + + ! node related indexes + integer(kind = 4) :: in, n, posN + + ! libs related vars + integer(kind = 4) :: ilk, ilj, ili, lk, lj, li + + ! modal amtrix related + real(RDP), dimension(NMODES_EFF) :: phik, phij, phii + integer(kind = 4) :: posk, posj, posi + + ! wind forces coeffs + real(RDP) :: ai, aiU, aj, ajU, ak, akU + + ! modes related + integer(kind = 4) :: im + + ! + ! real(RDP) :: S_N_curr(settings%nfreqs_) + real(RDP), allocatable :: Suvw_N_T(:, :), BF_ijk_III_w1w2(:, :) + real(RDP), allocatable :: tmp1(:, :), tmp2(:, :), tmp3(:, :) + real(RDP), allocatable :: Suvw_N_w1w2(:, :), Suvw_N_pad(:) + real(RDP), allocatable :: PSDF_jk_JJ_w(:) + + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getFM_diag_tnlm_vect_cls_() : computing modal forces spectra...' +#endif + + ! getting padded length and relative init/end indices (non zero zone) + itmp = NFREQS - 1 ! do not consider 0 (point of symmetry) + i_n_pad = itmp / 2 ! spread it on the two sides (left / right) + ien = i_n_pad + NFREQS + iin = i_n_pad + 1 + i_pad_len = itmp + NFREQS + + + if (settings%i_compute_psd_ == 1) then + + allocate(PSDF_jk_JJ_w(NFREQS)) + allocate(psd(NFREQS, dimM_psd_)) + psd = 0._RDP + endif + + if (settings%i_compute_bisp_ == 1) then + + allocate(Suvw_N_T(1, NFREQS)) + allocate(Suvw_N_pad(i_pad_len)) + allocate(Suvw_N_w1w2(NFREQS, NFREQS)) + + allocate(tmp1(NFREQS, NFREQS)) + allocate(tmp2(NFREQS, NFREQS)) + allocate(tmp3(NFREQS, NFREQS)) + + allocate(BF_ijk_III_w1w2(NFREQS, NFREQS)) + allocate(bisp(NFREQS, NFREQS, dimM_bisp_)) + bisp = 0._RDP + endif + + + !======================================================================== + ! BUG: for the moment, only considering correlation + ! between same turbulence component (u, v, w). + ! No cross-correlation between turbulent components + ! i.e. E[uv]==E[uw]==E[vw] === 0 + do itc = 1, NTCOMPS + + tc = wd%tc_(itc) + tcP3 = tc + 3 + tc_posN = (itc - 1) * NNODESL + + do in = 1, NNODESL + + n = struct_data%n_load_(in) + posN = (n - 1) * NLIBS + tc_pos = tc_posN + in + + + ! BISP + if (settings%i_compute_bisp_ == 1) then + + Suvw_N_pad(iin : ien) = Suvw(:, tc_pos) + Suvw_N_T(1, :) = Suvw(:, tc_pos) ! storing transpose once for all + + itmp = 0 +!DIR$ UNROLL= 10 + do ifrj = 1, NFREQS + + Suvw_N_w1w2(:, ifrj) = Suvw_N_pad(ifrj : NFREQS+itmp) + + tmp1(:, ifrj) = Suvw_N_w1w2(:, ifrj) * Suvw_N_T(1, ifrj) + tmp2(:, ifrj) = Suvw_N_w1w2(:, ifrj) * Suvw(:, tc_pos) + ! tmp3(:, ifrj) = Suvw(:, tc_pos) * Suvw_N_T(1, ifrj) + + itmp = itmp + 1 + enddo ! omega j + + ! original version + ! NOTE: had stack overflow not using /heap-arrays0 compile option + tmp3 = matmul(Suvw(:, tc_pos:tc_pos), Suvw_N_T) + + + do ilk = 1, NLIBSL + + lk = struct_data%libs_load_(ilk) + posk = posN + lk + phik = struct_data%modal_%phi_(posk, MODES) + + akU = wd%wfc_(lk, tc, in) + ak = wd%wfc_(lk, tcP3, in) + + + do ilj = 1, NLIBSL + + lj = struct_data%libs_load_(ilj) + posj = posN + lj + phij = struct_data%modal_%phi_(posj, MODES) + + ajU = wd%wfc_(lj, tc, in) + aj = wd%wfc_(lj, tcP3, in) + +!DIR$ UNROLL= 6 + do ili = 1, NLIBSL + + li = struct_data%libs_load_(ili) + posi = posN + li + phii = struct_data%modal_%phi_(posi, MODES) + + aiU = wd%wfc_(li, tc, in) + ai = wd%wfc_(li, tcP3, in) + + + BF_ijk_III_w1w2 = 2 * (& + ai * ajU * akU * tmp3 + & + aiU * aj * akU * tmp1 + & + aiU * ajU * ak * tmp2 & + &) + + + ! NOTE: no need to retrieve actual mode + ! since we are supposed to store only + ! kept mode for all related variables. +!DIR$ UNROLL= 10 + do im = 1, NMODES_EFF + + bisp(:, :, im) = bisp(:, :, im) + & + phik(im) * phij(im) * phii(im) * BF_ijk_III_w1w2 + enddo + + enddo ! i lib + enddo ! j lib + enddo ! k lib + + endif ! do bisp computation + + + ! PSDs + do ilk = 1, NLIBSL + + lk = struct_data%libs_load_(ilk) + posk = posN + lk + phik = struct_data%modal_%phi_(posk, MODES) + + akU = wd%wfc_(lk, tc, in) + +!DIR$ UNROLL= 6 + do ilj = 1, NLIBSL + + lj = struct_data%libs_load_(ilj) + posj = posN + lj + phij = struct_data%modal_%phi_(posj, MODES) + + ajU = wd%wfc_(lj, tc, in) + + + PSDF_jk_JJ_w = ajU * akU * Suvw(:, tc_pos) + +!DIR$ UNROLL= 10 + do im = 1, NMODES_EFF + + psd(:, im) = psd(:, im) + & + phij(im) * phik(im) * PSDF_jk_JJ_w + enddo + enddo ! j lib + enddo ! k lib + + +#ifdef __BSA_DEBUG + print '(1x, 2a, f10.4, " %")', & + INFOMSG, 'getFM_diag_tnlm_vect_cls_() : done ', real(in, RDP) / NNODESL * 100 +#endif + + enddo ! nodes + enddo ! turb comps + + if (allocated(PSDF_jk_JJ_w)) deallocate(PSDF_jk_JJ_w) + if (allocated(Suvw_N_T)) deallocate(Suvw_N_T) + if (allocated(Suvw_N_pad)) deallocate(Suvw_N_pad) + if (allocated(Suvw_N_w1w2)) deallocate(Suvw_N_w1w2) + if (allocated(tmp1)) deallocate(tmp1) + if (allocated(tmp2)) deallocate(tmp2) + if (allocated(tmp3)) deallocate(tmp3) + if (allocated(BF_ijk_III_w1w2)) deallocate(BF_ijk_III_w1w2) + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getFM_diag_tnlm_vect_cls_() : computing modal forces spectra -- ok.' +#endif + end subroutine + + + + module subroutine getRM_diag_vect_cls_(f, psd, bisp) + real(RDP), intent(in) :: f(NFREQS) + real(RDP), allocatable, intent(inout) :: psd(:, :), bisp(:, :, :) + + integer(kind = 4) :: ifrj + integer(kind = 4) :: pos = 1 + + ! modal indexed + integer(kind = 4) :: imi, mi + + real(RDP) :: omegas(NFREQS, 1) + real(RDP), allocatable :: r_part(:, :), i_part(:, :), h_tmp(:, :) + real(RDP) :: Mgi, Kgi, Cgi + real(RDP), allocatable :: Hr_w(:), Hi_w(:) + real(RDP), allocatable :: Hr_w1w2(:, :), Hi_w1w2(:, :) + + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getRM_diag_vect_cls_() : computing modal responses spectra...' +#endif + + + ! BUG: check logic if correct + if (settings%i_compute_bisp_ == 1) then + + allocate(r_part(NFREQS, NFREQS)) + allocate(i_part(NFREQS, NFREQS)) + allocate(h_tmp(NFREQS, NFREQS)) + allocate(Hr_w1w2(NFREQS, NFREQS)) + allocate(Hi_w1w2(NFREQS, NFREQS)) + + elseif (settings%i_compute_psd_ == 1) then + + allocate(r_part(NFREQS, 1)) + allocate(i_part(NFREQS, 1)) + allocate(h_tmp(NFREQS, 1)) + + else ! none of them. NOTE: if so, we don't ever get here.. + return + endif + + + ! TRANSFER FUNCTION COMPUTATION + + ! pulsations + omegas(:, 1) = f * CST_PIt2 + + + allocate(Hr_w(NFREQS)) + allocate(Hi_w(NFREQS)) + + + do imi = 1, NMODES_EFF + + mi = MODES(imi) + + ! NOTE: assumes we are storing only kept modes + ! related modal info + Mgi = struct_data%modal_%Mm_(mi) + Kgi = struct_data%modal_%Km_(mi) + Cgi = struct_data%modal_%Cm_(mi, mi) + + ! H1 / H2 + r_part(:, 1) = - (omegas(:, 1)*omegas(:, 1) * Mgi) + Kgi + i_part(:, 1) = omegas(:, 1) * Cgi + h_tmp(:, 1) = r_part(:, 1)*r_part(:, 1) + i_part(:, 1)*i_part(:, 1) + + Hr_w = r_part(:, 1) / h_tmp(:, 1) + Hi_w = - i_part(:, 1) / h_tmp(:, 1) + + + ! PSD + psd(:, pos) = & + psd(:, pos) * & + ( Hr_w * Hr_w + & + Hi_w * Hi_w ) + + + if (settings%i_compute_bisp_ == 1) then + + ! w1+w2^T + do ifrj = 1, NFREQS + h_tmp(:, ifrj) = omegas(:, 1) + omegas(ifrj, 1) + enddo + + r_part = - (h_tmp*h_tmp * Mgi) + Kgi + i_part = h_tmp * Cgi + h_tmp = r_part*r_part + i_part*i_part + + Hr_w1w2 = r_part / h_tmp + Hi_w1w2 = - i_part / h_tmp + + ! BISP + do ifrj = 1, NFREQS + + bisp(:, ifrj, pos) = & + bisp(:, ifrj, pos) * & + ( Hr_w * Hr_w(ifrj) * Hr_w1w2(:, ifrj) + & + Hr_w * Hi_w(ifrj) * Hi_w1w2(:, ifrj) + & + Hi_w * Hr_w(ifrj) * Hi_w1w2(:, ifrj) - & + Hi_w * Hi_w(ifrj) * Hr_w1w2(:, ifrj) ) + enddo + endif + + pos = pos + 1 + enddo ! i mode + + + ! deallocate + if (allocated(r_part)) deallocate(r_part) + if (allocated(i_part)) deallocate(i_part) + if (allocated(Hr_w)) deallocate(Hr_w) + if (allocated(Hi_w)) deallocate(Hi_w) + if (allocated(h_tmp)) deallocate(h_tmp) + + if (settings%i_compute_bisp_ == 1) then + if (allocated(Hr_w1w2)) deallocate(Hr_w1w2) + if (allocated(Hi_w1w2)) deallocate(Hi_w1w2) + endif + + +#ifdef __BSA_DEBUG + write(unit_debug_, '(2a)') & + INFOMSG, '@BsaClassicImpl::getRM_diag_vect_cls_() : computing modal responses spectra -- ok.' +#endif + end subroutine getRM_diag_vect_cls_ + + + + + + + + + + + + + !> BUG: this routine is adapted to the case where we use + !> convention on PULSATION. + !> Please, adapt it to the case of convention over FREQUENCIES. + module pure subroutine getFM_full_tnlm_scalar_cls_(ii, ij, fi, fj, Suvw, Suvw_pad, psd, bisp) + integer, intent(in) :: ii, ij + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), intent(in) :: Suvw_pad(NPSDEL) + real(RDP), intent(inout) :: psd(dimM_psd_), bisp(dimM_bisp_) + + ! turb components related + integer(kind = 4) :: itc, tc_posN, tc_pk, tc_pj, tc_pi + + ! freqs related + real(RDP) :: fiabs, fjabs, fiPfj, fiPfjabs + + ! nodes indexed values + integer(kind = 4) :: i_pos_nk, i_pos_nj, i_pos_ni + integer(kind = 4) :: pos_nk, pos_nj, pos_ni + integer(kind = 4) :: ink, inj, ini + integer(kind = 4) :: ni, nj, nk + + ! libs indexed values + integer(kind = 4) :: ilk !, ilj, ili + + ! modes indexed values + real(RDP), dimension(NLIBSL, NMODES_EFF) :: phik_, phij_, phii_ + real(RDP) :: phik(NMODES_EFF), phikk, phij(1, NLIBSL), phii(NLIBSL, 1) + integer :: posm + integer :: imk, imj, imi + ! integer(kind = 4) :: mi, mj, mk + + ! local nodal correlations + real(RDP) :: corrJK, corrIK, corrIJ + + ! wfc extractions + integer(kind = 4) :: tc, tcP3 + real(RDP), dimension(NLIBSL, 1) :: aiU, ai, akU, ak + real(RDP), dimension(1, NLIBSL) :: ajU, aj + + ! PSDs local + real(RDP) :: S_uvw_i_i, S_uvw_i_j, S_uvw_i_ij + real(RDP) :: S_uvw_j_i, S_uvw_j_j, S_uvw_j_ij + real(RDP) :: S_uvw_k_i, S_uvw_k_j, S_uvw_k_ij + real(RDP) :: S_uvw_JK_i, S_uvw_JK_j + real(RDP) :: S_uvw_IK_j, S_uvw_IK_ij + real(RDP) :: S_uvw_IJ_i, S_uvw_IJ_ij + + ! BF local + real(RDP), dimension(NLIBSL, NLIBSL) :: BF_ijk_IJK_w_w2, PSD_jk_JK_w + real(RDP), dimension(NLIBSL, NLIBSL) :: tmp1, tmp2, tmp3 + !======================================================================== + + psd = 0._RDP + bisp= 0._RDP + + fiabs = abs(fi) + fjabs = abs(fj) + + fiPfj = fi + fj + fiPfjabs = abs(fiPfj) + + + !======================================================================== + ! BUG: for the moment, only considering correlation + ! between same turbulence component (u, v, w). + ! No cross-correlation between turbulent components + ! i.e. E[uv]==E[uw]==E[vw] === 0 + do itc = 1, wd%i_ntc_ + + tc_posN = (itc - 1) * NNODESL + tc = wd%tc_(itc) ! get actual turbulent component + tcP3 = tc + 3 ! quadratic term coeff + + + i_pos_nk = 1 + do ink = 1, NNODESL + + nk = struct_data%n_load_(ink) + pos_nk = (nk - 1) * NLIBS + tc_pk = tc_posN + i_pos_nk + + phik_ = struct_data%modal_%phi_(pos_nk + struct_data%libs_load_, MODES) + + S_uvw_k_i = Suvw(ii, tc_pk) + S_uvw_k_j = Suvw(ij, tc_pk) + S_uvw_k_ij = Suvw_pad(tc_pk) + + + akU(:, 1) = wd%wfc_(struct_data%libs_load_, tc, ink) + ak (:, 1) = wd%wfc_(struct_data%libs_load_, tcP3, ink) + + + i_pos_nj = 1 + do inj = 1, NNODESL + + nj = struct_data%n_load_(inj) + pos_nj = (nj - 1) * NLIBS + tc_pj = tc_posN + i_pos_nj + + phij_ = struct_data%modal_%phi_(pos_nj + struct_data%libs_load_, MODES) + + corrJK = wd%nod_corr_(util_getCorrVectIndex(nj, nk, NNODES), tc) + + S_uvw_j_i = Suvw(ii, tc_pj) + S_uvw_j_j = Suvw(ij, tc_pj) + S_uvw_j_ij = Suvw_pad(tc_pj) + + + S_uvw_JK_i = corrJK**(fiabs) * sqrt(S_uvw_j_i * S_uvw_k_i) + S_uvw_JK_j = corrJK**(fjabs) * sqrt(S_uvw_j_j * S_uvw_k_j) + + + ajU(1, :) = wd%wfc_(struct_data%libs_load_, tc, inj) + aj (1, :) = wd%wfc_(struct_data%libs_load_, tcP3, inj) + + + + !! BISPs + + if (settings%i_compute_bisp_ == 1) then + + i_pos_ni = 1 + do ini = 1, NNODESL + + ni = struct_data%n_load_(ini) + pos_ni = (ni - 1) * NLIBS + tc_pi = tc_posN + i_pos_ni + + phii_ = struct_data%modal_%phi_(pos_ni + struct_data%libs_load_, MODES) + + corrIK = wd%nod_corr_(util_getCorrVectIndex(ni, nk, NNODES), tc) + corrIJ = wd%nod_corr_(util_getCorrVectIndex(ni, nj, NNODES), tc) + + S_uvw_i_i = Suvw(ii, tc_pi) + S_uvw_i_j = Suvw(ij, tc_pi) + S_uvw_i_ij = Suvw_pad(tc_pi) + + + S_uvw_IK_j = corrIK**(fjabs) * sqrt(S_uvw_i_j * S_uvw_k_j ) + S_uvw_IK_ij = corrIK**(fiPfjabs) * sqrt(S_uvw_i_ij * S_uvw_k_ij) + + + S_uvw_IJ_i = corrIJ**(fiabs) * sqrt(S_uvw_i_i * S_uvw_j_i ) + S_uvw_IJ_ij = corrIJ**(fiPfjabs) * sqrt(S_uvw_i_ij * S_uvw_j_ij) + + + aiU(:, 1) = wd%wfc_(struct_data%libs_load_, tc, ini) + ai (:, 1) = wd%wfc_(struct_data%libs_load_, tcP3, ini) + + + tmp1 = matmul(ai, ajU ) * S_uvw_IJ_i * S_uvw_IK_j + tmp2 = matmul(aiU, aj ) * S_uvw_IJ_ij * S_uvw_JK_j + tmp3 = matmul(aiU, ajU) * S_uvw_JK_i * S_uvw_IK_ij + + + do ilk = 1, NLIBSL + + phik = phik_(ilk, :) + + + BF_ijk_IJK_w_w2 = 2 * (& + tmp1 * akU(ilk, 1) + & + tmp2 * akU(ilk, 1) + & + tmp3 * ak (ilk, 1) & + &) + + + ! if (all(BF_ijk_IJK_w_w2 == 0._RDP)) cycle + + + posm = 1 + do imk = 1, NMODES_EFF + + phikk = phik(imk) + + do imj = 1, NMODES_EFF + + phij(1, :) = phij_(:, imj) + + do imi = 1, NMODES_EFF + + phii(:, 1) = phii_(:, imi) + + bisp(posm) = bisp(posm) + & + sum(matmul(phii, phij) * BF_ijk_IJK_w_w2 * phikk) + + posm = posm + 1 + enddo ! i mode + enddo ! j mode + enddo ! k mode + + + enddo ! k lib + + + i_pos_ni = i_pos_ni + 1 + enddo ! i node + + endif ! bisp computation + + + !! PSDs + if (ij == 1) then + + + ! PSD f + PSD_jk_JK_w = matmul(akU, ajU) * S_uvw_JK_i + + + posm = 1 + do imk = 1, NMODES_EFF + + ! NOTE: reusing variable, but naming is wrong!!! + phii = phik_(:, imk:imk) + + do imj = 1, NMODES_EFF + + phij(1, :) = phij_(:, imj) + + psd(posm) = psd(posm) + & + sum(matmul(phii, phij) * PSD_jk_JK_w) +! phik, phij + + posm = posm + 1 + enddo ! j mode + enddo ! k mode + + endif ! PSD computation + + + i_pos_nj = i_pos_nj + 1 + enddo ! j node + + i_pos_nk = i_pos_nk + 1 + enddo ! k node + + enddo ! itc + + end subroutine getFM_full_tnlm_scalar_cls_ + + + + + + + + + + + + !> BUG: this routine is adapted to the case where we use + !> convention on PULSATION. + !> Please, adapt it to the case of convention over FREQUENCIES. + module pure subroutine getFM_full_tnm_scalar_cls_(ii, ij, fi, fj, Suvw, Suvw_pad, psd, bisp) + integer, intent(in) :: ii, ij + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), intent(in) :: Suvw_pad(NPSDEL) + real(RDP), intent(inout) :: psd(dimM_psd_), bisp(dimM_bisp_) + + ! turb components related + integer(kind = 4) :: itc, tc_posN, tc_pk, tc_pj + + ! freqs related + real(RDP) :: fiabs, fjabs, fiPfj, fiPfjabs + + ! nodes indexed values + integer(kind = 4) :: i_pos_nk, i_pos_nj + integer(kind = 4) :: pos_nk, pos_nj + integer(kind = 4) :: ink, inj + integer(kind = 4) :: nj, nk + + ! libs indexed values + integer(kind = 4) :: ilk !, ilj, ili + + ! modes indexed values + real(RDP), dimension(NMODES_EFF, 2) :: phik_, phij_ + real(RDP) :: phij_Ub_, phij_u_, phik_Ub_, phik_u_ + integer :: posm + integer :: imk, imj, imi + + ! local nodal correlations + real(RDP) :: corrJK + + ! wfc extractions + integer(kind = 4) :: tc, tcP3 + + ! PSDs local + real(RDP) :: S_uvw_j_i, S_uvw_j_j, S_uvw_j_ij + real(RDP) :: S_uvw_k_i, S_uvw_k_j, S_uvw_k_ij + real(RDP) :: S_uvw_JK_i, S_uvw_JK_j + !======================================================================== + + psd = 0._RDP + bisp = 0._RDP + + fiabs = abs(fi) + fjabs = abs(fj) + + fiPfj = fi + fj + fiPfjabs = abs(fiPfj) + + + !======================================================================== + ! BUG: for the moment, only considering correlation + ! between same turbulence component (u, v, w). + ! No cross-correlation between turbulent components + ! i.e. E[uv]==E[uw]==E[vw] === 0 + do itc = 1, wd%i_ntc_ + + tc_posN = (itc - 1) * NNODESL + tc = wd%tc_(itc) ! get actual turbulent component + tcP3 = tc + 3 ! quadratic term coeff + + + i_pos_nk = 1 + do ink = 1, NNODESL + + nk = struct_data%n_load_(ink) + pos_nk = (nk - 1) * NLIBS + tc_pk = tc_posN + i_pos_nk + + phik_(:, 1) = wd%phi_times_A_ndegw_(:, ink, tc ) + phik_(:, 2) = wd%phi_times_A_ndegw_(:, ink, tcP3) + + S_uvw_k_i = Suvw(ii, tc_pk) + S_uvw_k_j = Suvw(ij, tc_pk) + S_uvw_k_ij = Suvw_pad(tc_pk) + + + i_pos_nj = 1 + do inj = 1, NNODESL + + nj = struct_data%n_load_(inj) + pos_nj = (nj - 1) * NLIBS + tc_pj = tc_posN + i_pos_nj + + phij_(:, 1) = wd%phi_times_A_ndegw_(:, inj, tc ) + phij_(:, 2) = wd%phi_times_A_ndegw_(:, inj, tcP3) + + corrJK = wd%nod_corr_(util_getCorrVectIndex(nj, nk, NNODES), tc) + + S_uvw_j_i = Suvw(ii, tc_pj) + S_uvw_j_j = Suvw(ij, tc_pj) + S_uvw_j_ij = Suvw_pad(tc_pj) + + + S_uvw_JK_i = corrJK**(fiabs) * sqrt(S_uvw_j_i * S_uvw_k_i) + S_uvw_JK_j = corrJK**(fjabs) * sqrt(S_uvw_j_j * S_uvw_k_j) + + + !! BISPs + + if (settings%i_compute_bisp_ == 1) then + + block + integer(kind = 4) :: i_pos_ni, ini, ni, pos_ni + integer(kind = 4) :: tc_pi + + real(RDP) :: corrIK, corrIJ + real(RDP) :: S_uvw_i_i, S_uvw_i_j, S_uvw_i_ij + real(RDP) :: S_uvw_IK_j, S_uvw_IK_ij + real(RDP) :: S_uvw_IJ_i, S_uvw_IJ_ij + real(RDP) :: tmp1, tmp2, tmp3 + + real(RDP), dimension(NMODES_EFF, 2) :: phii_ + + + i_pos_ni = 1 + do ini = 1, NNODESL + + ni = struct_data%n_load_(ini) + pos_ni = (ni - 1) * NLIBS + tc_pi = tc_posN + i_pos_ni + + phii_(:, 1) = wd%phi_times_A_ndegw_(:, ini, tc ) + phii_(:, 2) = wd%phi_times_A_ndegw_(:, ini, tcP3) + + corrIK = wd%nod_corr_(util_getCorrVectIndex(ni, nk, NNODES), tc) + corrIJ = wd%nod_corr_(util_getCorrVectIndex(ni, nj, NNODES), tc) + + S_uvw_i_i = Suvw(ii, tc_pi) + S_uvw_i_j = Suvw(ij, tc_pi) + S_uvw_i_ij = Suvw_pad(tc_pi) + + + S_uvw_IK_j = corrIK**(fjabs) * sqrt(S_uvw_i_j * S_uvw_k_j ) + S_uvw_IK_ij = corrIK**(fiPfjabs) * sqrt(S_uvw_i_ij * S_uvw_k_ij) + + S_uvw_IJ_i = corrIJ**(fiabs) * sqrt(S_uvw_i_i * S_uvw_j_i ) + S_uvw_IJ_ij = corrIJ**(fiPfjabs) * sqrt(S_uvw_i_ij * S_uvw_j_ij) + + + tmp1 = S_uvw_IJ_i * S_uvw_IK_j + tmp2 = S_uvw_IJ_ij * S_uvw_JK_j + tmp3 = S_uvw_JK_i * S_uvw_IK_ij + + + posm = 1 + do imk = 1, NMODES_EFF + + phik_Ub_ = phik_(imk, 1) + phik_u_ = phik_(imk, 2) + + do imj = 1, NMODES_EFF + + phij_Ub_ = phij_(imj, 1) + phij_u_ = phij_(imj, 2) + + do imi = 1, NMODES_EFF + + bisp(posm) = bisp(posm) + & + 2 * ( & + (phii_(imi, 2) * phij_Ub_ * phik_Ub_ * tmp1) & + + (phii_(imi, 1) * phij_u_ * phik_Ub_ * tmp2) & + + (phii_(imi, 1) * phij_Ub_ * phik_u_ * tmp3) & + ) + + posm = posm + 1 + enddo ! i mode + enddo ! j mode + enddo ! k mode + + + i_pos_ni = i_pos_ni + 1 + enddo ! i node + + end block + + endif ! bisp computation + + + !! PSDs + if (ij == 1) then + + posm = 1 + do imk = 1, NMODES_EFF + + phik_Ub_ = phik_(imk, 1) + + do imj = 1, NMODES_EFF + + psd(posm) = psd(posm) + & + (phik_Ub_ * phij_(imj, 1) * S_uvw_JK_i) + + posm = posm + 1 + enddo ! j mode + enddo ! k mode + + endif ! PSD computation + + + i_pos_nj = i_pos_nj + 1 + enddo ! j node + + i_pos_nk = i_pos_nk + 1 + enddo ! k node + + enddo ! itc + + end subroutine getFM_full_tnm_scalar_cls_ + + + + + + + + + + + module subroutine getRM_full_scalar_cls_(ii, ij, fi, fj, psdin, psdout, bispin, bispout) + integer, intent(in) :: ii, ij + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: psdin(dimM_psd_), bispin(dimM_bisp_) + real(RDP), intent(out) :: psdout(dimM_psd_), bispout(dimM_bisp_) + + real(RDP) :: wi + integer(kind = 4) :: posm, imk, imj + + real(RDP), dimension(NMODES_EFF) :: Cdiag, rpart, ipart, htmp + real(RDP), dimension(NMODES_EFF) :: H1r, H1i + + real(RDP) :: H2j_r, H2j_i + + wi = fi * CST_PIt2 + + + ! pre evaluate TFs (per mode) + + ! H1 + rpart = - (wi*wi * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + do imk = 1, NMODES_EFF + Cdiag(imk) = struct_data%modal_%Cm_(MODES(imk), MODES(imk)) + enddo + ipart = Cdiag * wi + htmp = rpart*rpart + ipart*ipart + H1r = rpart / htmp + H1i = - ipart / htmp + + + if (ij == 1) then ! also PSDr + + posm = 1 + do imk = 1, NMODES_EFF + + H2j_r = H1r(imk) + H2j_i = H1i(imk) + + do imj = 1, NMODES_EFF + + psdout(posm) = psdin(posm) * (& + H1r(imj) * H2j_r + & + H1i(imj) * H2j_i & + ) + + posm = posm + 1 + enddo ! j modes + enddo ! k modes + + if (settings%i_compute_bisp_ == 0) return + endif + + + ! BISPr + + block + real(RDP), dimension(NMODES_EFF) :: H2r, H2i + real(RDP), dimension(NMODES_EFF) :: H12r, H12i + real(RDP) :: H12k_r, H12k_i + real(RDP) :: wj, wiPwj, tmp1, tmp2, tmp3, tmp4 + integer :: imi + + wj = fj * CST_PIt2 + wiPwj = wi + wj + + ! H2 + rpart = - (wj*wj * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + ipart = Cdiag * wj + htmp = rpart*rpart + ipart*ipart + H2r = rpart / htmp + H2i = - ipart / htmp + + + ! H12 + rpart = - (wiPwj*wiPwj * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + ipart = Cdiag * wiPwj + htmp = rpart*rpart + ipart*ipart + H12r = rpart / htmp + H12i = - ipart / htmp + + + posm = 1 + do imk = 1, NMODES_EFF + + H12k_r = H12r(imk) + H12k_i = H12i(imk) + + do imj = 1, NMODES_EFF + + H2j_r = H2r(imj) + H2j_i = H2i(imj) + + tmp1 = H2j_r * H12k_r ! real + tmp2 = H2j_i * H12k_i ! real + tmp3 = H2j_r * H12k_i ! imag + tmp4 = H2j_i * H12k_r ! imag + + do imi = 1, NMODES_EFF + + bispout(posm) = bispin(posm) * (& + H1r(imi) * tmp1 + & + H1r(imi) * tmp2 + & + H1i(imi) * tmp3 - & + H1i(imi) * tmp4 & + ) + + posm = posm + 1 + enddo ! i modes + enddo ! j modes + enddo ! k modes + + end block + + end subroutine getRM_full_scalar_cls_ + + + + + + + + + + + + + + + !> BUG: this routine is adapted to the case where we use + !> convention on PULSATION. + !> Please, adapt it to the case of convention over FREQUENCIES. + module pure subroutine getFM_diag_tnlm_scalar_cls_(ii, ij, fi, fj, Suvw, Suvw_pad, psd, bisp) + integer, intent(in) :: ii, ij + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: Suvw(NFREQS, NPSDEL) + real(RDP), intent(in) :: Suvw_pad(NPSDEL) + real(RDP), intent(inout) :: psd(dimM_psd_), bisp(dimM_bisp_) + + integer(kind = 4) :: itc, tc, tcP3, iposN, inode, n, imode, posNi + + real(RDP) :: Suvw_i + + real(RDP), dimension(NLIBSL, NMODES_EFF) :: phiN_ + real(RDP), dimension(NLIBSL, NLIBSL) :: PSDF_jk_JJ_w, tmp3, phiIJ_ + real(RDP), dimension(NLIBSL) :: aNU, aN + + ! logical :: lflag = .false. + + + psd = 0._RDP + bisp = 0._RDP + + + iposN = 1 + do itc = 1, NTCOMPS + + tc = wd%tc_(itc) + tcP3 = tc + 3 + + + do inode = 1, NNODESL + + n = struct_data%n_load_(inode) + posNi = (n - 1) * NLIBS + + phiN_ = struct_data%modal_%phi_(posNi + struct_data%libs_load_, MODES) + + aNU = wd%wfc_(struct_data%libs_load_, tc, inode) + an = wd%wfc_(struct_data%libs_load_, tcP3, inode) + + Suvw_i = Suvw(ii, iposN) + + ! PSD comp + if (ij == 1) then + + do imode = 1, NLIBSL + tmp3(:, imode) = aNU * aNU(imode) + enddo + PSDF_jk_JJ_w = tmp3 * Suvw_i + + do imode = 1, NMODES_EFF + + phiIJ_ = matmul(phiN_(:, imode:imode), transpose(phiN_(:, imode:imode))) + + psd(imode) = psd(imode) + & + sum(phiIJ_ * PSDF_jk_JJ_w) + + enddo ! n modes + + endif ! ij == 1 + + + + if (settings%i_compute_bisp_ == 1) then + + block + real(RDP) :: Suvw_j, Suvw_ij + integer :: ilk + + real(RDP) :: BF_ijk_III_wiwj(NLIBSL, NLIBSL) + real(RDP), dimension(NLIBSL, NLIBSL) :: tmp2, tmp1 + + Suvw_j = Suvw(ij, iposN) + Suvw_ij = Suvw_pad(iposN) + + tmp1 = matmul(reshape(aN , [NLIBSL, 1]), reshape(aNU, [1, NLIBSL])) + tmp2 = matmul(reshape(aNU, [NLIBSL, 1]), reshape(aN , [1, NLIBSL])) + tmp3 = matmul(reshape(aNU, [NLIBSL, 1]), reshape(aNU, [1, NLIBSL])) + + tmp1 = tmp1 * (Suvw_i * Suvw_j) + tmp2 = tmp2 * (Suvw_ij * Suvw_j) + tmp3 = tmp3 * (Suvw_ij * Suvw_i) + + do ilk = 1, NLIBSL + + BF_ijk_III_wiwj = 2 * (& + tmp1 * aNU(ilk) + & + tmp2 * aNU(ilk) + & + tmp3 * aN (ilk) & + ) + + do imode = 1, NMODES_EFF + + phiIJ_ = matmul(phiN_(:, imode:imode), transpose(phiN_(:, imode:imode))) + + bisp(imode) = bisp(imode) + & + sum(phiIJ_ * BF_ijk_III_wiwj * phiN_(ilk, imode)) + enddo ! n modes + + enddo ! k libs + + end block + + endif ! compute BISP + + iposN = iposN + 1 + enddo ! nodes loaded + + enddo ! turb comps + + end subroutine getFM_diag_tnlm_scalar_cls_ + + + + + + + module subroutine getRM_diag_scalar_cls_(ii, ij, fi, fj, psdin, psdout, bispin, bispout) + integer, intent(in) :: ii, ij ! freqs indexes + real(RDP), intent(in) :: fi, fj + real(RDP), intent(in) :: psdin(dimM_psd_), bispin(dimM_bisp_) + real(RDP), intent(out) :: psdout(dimM_psd_), bispout(dimM_bisp_) + + real(RDP) :: wi + integer(kind = 4) :: imi + + real(RDP), dimension(NMODES_EFF) :: Cdiag, rpart, ipart, htmp + real(RDP), dimension(NMODES_EFF) :: H1r, H1i + + + wi = fi * CST_PIt2 + + + ! pre evaluate TFs (per mode) + + ! H1 + rpart = - (wi*wi * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + do imi = 1, NMODES_EFF + Cdiag(imi) = struct_data%modal_%Cm_(MODES(imi), MODES(imi)) + enddo + ipart = Cdiag * wi + htmp = rpart*rpart + ipart*ipart + H1r = rpart / htmp + H1i = - ipart / htmp + + + if (ij == 1) psdout = psdin * (H1r * H1r + H1i * H1i) + + + block + real(RDP) :: wj, wiPwj + real(RDP), dimension(NMODES_EFF) :: H2r, H2i + real(RDP), dimension(NMODES_EFF) :: H12r, H12i + real(RDP) :: H12k_r, H12k_i, H2j_r, H2j_i + + + wj = fj * CST_PIt2 + wiPwj = wi + wj + + ! H2 + rpart = - (wj*wj * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + ipart = Cdiag * wj + htmp = rpart*rpart + ipart*ipart + H2r = rpart / htmp + H2i = - ipart / htmp + + + ! H12 + rpart = - (wiPwj*wiPwj * struct_data%modal_%Mm_(MODES)) + struct_data%modal_%Km_(MODES) + ipart = Cdiag * wiPwj + htmp = rpart*rpart + ipart*ipart + H12r = rpart / htmp + H12i = - ipart / htmp + + + bispout = bispin * (& + H1r * H2r * H12r + & + H1r * H2i * H12i + & + H1i * H2r * H12i - & + H1i * H2i * H12r & + ) + + end block + + end subroutine getRM_diag_scalar_cls_ + + + + + + + + + + + + + module pure subroutine getBR_SFm_val_(nm, Suvw, fnat, im, m, psd) + !! BUG: very unoptimised.. + !! is basically a small copy of "getFM_full_tnlm_scalar_cls_" + integer, intent(in) :: im, m, nm + real(RDP), intent(in) :: Suvw(nm, NPSDEL), fnat + real(RDP), intent(inout) :: psd + + ! turb components related + integer(kind = 4) :: itc, tc_posN, tc_pk, tc_pj + + ! freqs related + real(RDP) :: fiabs + + ! nodes indexed values + integer(kind = 4) :: i_pos_nk, i_pos_nj + integer(kind = 4) :: pos_nk, pos_nj + integer(kind = 4) :: ink, inj + integer(kind = 4) :: nj, nk, ilk + + ! local nodal correlations + real(RDP) :: corrJK + + integer(kind = 4) :: tc, imk, imj + real(RDP), dimension(NLIBSL, 1) :: akU, phij_ + real(RDP), dimension(1, NLIBSL) :: ajU, phik_ + + ! PSDs local + real(RDP) :: S_uvw_j_i + real(RDP) :: S_uvw_k_i + real(RDP) :: S_uvw_JK_i + + real(RDP), dimension(NLIBSL, NLIBSL) :: PSD_jk_JK_w + !======================================================================== + + psd = 0._RDP + fiabs = abs(fnat) + + + !======================================================================== + ! BUG: for the moment, only considering correlation + ! between same turbulence component (u, v, w). + ! No cross-correlation between turbulent components + ! i.e. E[uv]==E[uw]==E[vw] === 0 + do itc = 1, wd%i_ntc_ + + tc_posN = (itc - 1) * NNODESL + tc = wd%tc_(itc) ! get actual turbulent component + + i_pos_nk = 1 + do ink = 1, NNODESL + + nk = struct_data%n_load_(ink) + pos_nk = (nk - 1) * NLIBS + tc_pk = tc_posN + i_pos_nk + + phik_ = transpose(struct_data%modal_%phi_(pos_nk + struct_data%libs_load_, m:m)) + + akU(:, 1) = wd%wfc_(struct_data%libs_load_, tc, ink) + + S_uvw_k_i = Suvw(im, tc_pk) + + + + i_pos_nj = 1 + do inj = 1, NNODESL + + nj = struct_data%n_load_(inj) + pos_nj = (nj - 1) * NLIBS + tc_pj = tc_posN + i_pos_nj + + phij_ = struct_data%modal_%phi_(pos_nj + struct_data%libs_load_, m:m) + + corrJK = wd%nod_corr_(util_getCorrVectIndex(nj, nk, NNODES), tc) + + S_uvw_j_i = Suvw(im, tc_pj) + S_uvw_JK_i = corrJK**(fiabs) * sqrt(S_uvw_j_i * S_uvw_k_i) + + + ajU(1, :) = wd%wfc_(struct_data%libs_load_, tc, inj) + + + ! PSD f + PSD_jk_JK_w = matmul(akU, ajU) * S_uvw_JK_i + + psd = psd + sum(matmul(phij_, phik_) * PSD_jk_JK_w) + + i_pos_nj = i_pos_nj + 1 + enddo ! j node + + i_pos_nk = i_pos_nk + 1 + enddo ! k node + + enddo ! itc + end subroutine + + + + + + + + + + + + +end submodule BsaLib_FunctionsImpl \ No newline at end of file diff --git a/src/BsaLib/bsa/meshing/BsaMesherImpl.f90 b/src/BsaLib/bsa/meshing/BsaMesherImpl.f90 new file mode 100644 index 0000000..82040e9 --- /dev/null +++ b/src/BsaLib/bsa/meshing/BsaMesherImpl.f90 @@ -0,0 +1,1771 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib) BsaLib_MesherImpl + +#include "../../precisions" + + use BsaLib_Data + use BsaLib_MPoint + use BsaLib_MRectZone + use BsaLib_MTriangZone + use BsaLib_MPolicy + use BsaLib_Functions, only: prefetchSVDWorkDim_ & + , NFREQS, NNODES, NNODESL, NLIBS, NLIBSL & + , NMODES, NMODES_EFF, MODES & + , NPSDEL, NTCOMPS, NDIRS, TCOMPS, DIRS + implicit none + + ! to have a local instance to be referenced + integer :: NM__, NM_EFF__ + character(len = *), parameter :: bfm_dump_file_name_ = 'dumpfile' + + ! BUG: let the user choose how many modes it allows to be covered max. + integer(kind = 4), parameter :: N_RES_PEAK_IN_BKG_ZONE_DIV_FCT_ = 4 + + interface getEquivalentLooperIterator + module procedure getEquivalentLooperIterator_char + module procedure getEquivalentLooperIterator_real + end interface + + +contains + + + + + module subroutine mainMesher_(m3mf_msh, m3mr_msh) + use BsaLib_Functions, only: cleanSVDWorkInfo_ + real(RDP), target, allocatable :: m3mf_msh(:), m3mr_msh(:) + integer :: istat + character(len = 256) :: emsg + logical :: lflag + +#ifdef __BSA_DEBUG + write(unit_debug_, *) ' @BsaMesherImpl::mainMesher_() : Init BSA-Mesher main...' +#endif + + + NM__ = struct_data%modal_%nm_ + NM_EFF__ = struct_data%modal_%nm_eff_ + + msh_bfmpts_pre_ = 0 + msh_bfmpts_post_ = 0 + msh_brmpts_post_ = 0 + + allocate(m3mf_msh(dimM_bisp_), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('m3mf_msh', dimM_bisp_, loc(m3mf_msh), sizeof(m3mf_msh)) +#endif + else + call allocKOMsg('m3mf_msh', istat, emsg) + endif + m3mf_msh = 0._RDP + m3mf_msh_ptr_ => m3mf_msh + + call PreMesh() + lflag = settings%i_only_diag_ == 0 .and. settings%i_use_svd_ == 1 + if (lflag .and. test_no_bfm_mlr_) call cleanSVDWorkInfo_() + + +#ifdef __BSA_CHECK_NOD_COH_SVD + goto 998 +#endif + + + ! ! post-meshing -> BRM + allocate(m3mr_msh(dimM_bisp_), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('m3mr_msh', dimM_bisp_, loc(m3mr_msh), sizeof(m3mr_msh)) +#endif + else + call allocKOMsg('m3mr_msh', istat, emsg) + endif + m3mr_msh = 0._RDP + m3mr_msh_ptr_ => m3mr_msh + call Mesh() + + + ! cleanup + 998 if (lflag .and. .not. test_no_bfm_mlr_) call cleanSVDWorkInfo_() + inquire(unit = unit_dump_bfm_, opened = lflag) + if (lflag) close(unit_dump_bfm_) + + + print * + print '(1x, a, a)', & + INFOMSG, ' Resume of total n. of points in meshing procedure:' + print '(1x, a, a, i0)', MSGCONT, ' PRE-MESH (BFM) : ', msh_bfmpts_pre_ + print '(1x, a, a, i0)', MSGCONT, ' POST-MESH (BFM) : ', msh_bfmpts_post_ + print '(1x, a, a, i0)', MSGCONT, ' POST-MESH (BRM) : ', msh_brmpts_post_ + + +#ifdef __BSA_DEBUG + write(unit_debug_, *) ' @BsaMesherImpl::mainMesher_() : Init BSA-Mesher main -- ok.' +#endif + end subroutine mainMesher_ + + + + + !> Computes Pre-meshing phase for BFM, + !> to be stored (dumped) for bRM meshing actual computation + !> + !> NOTE: here, we have the same meshing technique + !> no matter the triple mode combination i-j-k. + !> + !> TODO: implement also PSDFM computation! + !> + !> IMPLEMENTATION DETAILS: + !> *********************** + !> + !> Regarding the bispectrum computation optimisation, + !> we have since long time already understood it is a complex subject. + !> Why? A priori 5D matrices (which might be reshaped 3D) + !> + !> What we also know is that, from a specific point of view, + !> to obtain the Bispectrum of modal response for a given structure, + !> the most expensive operation is the obtainment of the + !> bispectrum of the relative modal FORCE, from the know input, + !> which we know being the PSDs of the wind turbulent components u,v,w. + !> Why? Because for each triplet (combination) of modes, at each pair of + !> frequencies, the value of the bispectrum of the (triplet of) modal force + !> is given by the 'projection' of the (FULL) bispectrum of nodal forces + !> in the modal base (for that specific triplet of modes). + !> So, if this is the most expensive phase, what could be a solution? + !> Minimising its impact by minimising the count of times it needs to be performed. + !> + !> Could we do it? + !> + !> We could think so, since by looking at the "classic" shape of a + !> bispectrum of a modal response, still referring to the applied load + !> (turbulent wind loading), we see that it shows one main peak centered + !> at the origin (0,0) of the frequency space, plus some little 'crests' + !> on top of the three main axes (w1=0, w2=0, w1=w2). + !> We could prove this also analytically. + !> What about the rest? Almost flat, where one could even suppose constness. + !> Still, in a "classical" approach values (of BFM) are computed exactly, + !> no matter the location in the frequency space w1-w2. It is now clear that, + !> most of these (EXPENSIVE) operations are useless. Because in those regions + !> outside the 4 aforementioned we already know that values are almost identical + !> towards zero (meaning of some orders of magnitude smaller than values at the + !> central peak for example). + !> So, the idea here is computing, for what concerns the bispectra computation + !> at the modal forces stage (for all possible triplets of modes), only what we know + !> A PRIORI being useful, playing an important role in the estimation of correspondent + !> value of the bispectra of the relative modal response. + !> + !> What is it? Well, what we said before. The centered main peak, plus + !> those crests along the three main lines in the Cartesian plane. + !> + !> But how can this be more effective? + !> + subroutine PreMesh() +#ifdef __BSA_CHECK_NOD_COH_SVD + use BsaLib_Functions, only: MSHR_SVD_INFO, MSHR_SVD_LWORK, MSHR_SVD_WORK +#endif + real(RDP), parameter :: cst_sqrt2d2 = sqrt(2.d0) / 2._RDP + integer(kind = 4) :: NLims, iost + + real(RDP) :: base_i, base_j, max_ext + real(RDP) :: deltaI_S2_2, deltaI_2_S2_2 + real(RDP) :: df_I_ref, df_J_ref + logical :: iun_open + real(RDP), allocatable :: limits(:) + type(MPolicy_t), allocatable, target :: policies(:) + + type(MRectZone_t) :: bkgz + character(len = :), allocatable :: zone_title + + +#ifdef __BSA_DEBUG + write(unit_debug_, *) ' @BsaMesherImpl::PreMesh() : Init BSA-Mesher pre meshing phase...' +#endif + + ! check that unit dedicated to dump is not in use already, then, open it + inquire(unit=unit_dump_bfm_, opened=iun_open) + do while (iun_open) + unit_dump_bfm_ = unit_dump_bfm_ + 1 + inquire(unit=unit_dump_bfm_, opened=iun_open) + enddo + open(& + unit=unit_dump_bfm_, & + file=bfm_dump_file_name_, & + form=IO_FORM_UNFORMATTED, & + access=IO_ACCESS_STREAM, & + iostat=iost) + if (iost /= 0) call bsa_Abort('Cannot open dump file'//bfm_dump_file_name_) + rewind(unit_dump_bfm_) ! make sure its at init byte + + ! NOTE: iost = 0. + ! Write it twice to make space for info that + ! will be OVERRIDEN once we have it + ! namely "dimM_bisp_" and "MAX ZONE n. of points" + write(unit_dump_bfm_) iost + write(unit_dump_bfm_) iost + write(unit_dump_bfm_) iost + write(unit_dump_bfm_) iost + + + + write(*, '(1x, a)') '-----------------------------------------------------------' + write(*, '(1x, a)') '-------------------- PRE - MESH --------------------' + write(*, '(1x, a)') '-----------------------------------------------------------' + + + ! NOTE: bkg_peak_width_ is already given in [Hz] + ! BUG: is really a 3x3 matrix ?? + if (do_restrict_bkgpeak_) then + bkg_peakw_ = maxval(struct_data%bkg_peak_width_(:, 1)) + else + bkg_peakw_ = maxval(struct_data%bkg_peak_width_(:, :)) + endif + base_i = bkg_peakw_ * settings%bkg_area_extension_ + base_j = base_i + + deltaI_S2_2 = base_i * cst_sqrt2d2 + deltaI_2_S2_2 = deltaI_S2_2 / 2. + + max_ext = getMaxSpaceExtension_() ! Get max point in space to reach + + + ! NOTE: use static module variable msh_ZoneLimsInterestModes + ! so that we can reuse in post-meshing phase. + call prefetchZoneLimits_(base_i / 2, limits, policies, NLims, msh_ZoneLimsInterestModes) + + if (settings%i_only_diag_ == 0 .and. settings%i_use_svd_ == 1) call prefetchSVDWorkDim_() + + +#ifdef __BSA_CHECK_NOD_COH_SVD + block + double precision :: tmpv(1, NNODESL) + + call wd%getFull2DNodCorrMat(NNODES, nod_corr_full_) + if (allocated(nod_corr_full_)) then + allocate(nod_corr_EVLs_(NNODESL)) + allocate(nod_corr_EVTs_(NNODESL, NNODESL)) + + nod_corr_full_ = nod_corr_full_(struct_data%n_load_, struct_data%n_load_) + nod_corr_EVTs_ = nod_corr_full_ + + call dgesvd(& + 'O' & ! min(M,N) columns of U are overwritten on array A (saves memory) + , 'N' & ! no rows of V are computed + , NNODESL & ! n. of rows M + , NNODESL & ! n. of cols N + , nod_corr_EVTs_ &! A matrix (overwritten with left-singular vectors) + , NNODESL & + , nod_corr_EVLs_ &! singular values + , tmpv & ! U + , 1 & + , tmpv & ! VT + , 1 & + , MSHR_SVD_WORK & + , MSHR_SVD_LWORK & + , MSHR_SVD_INFO & + ) + if (MSHR_SVD_INFO /= 0) call bsa_Abort("Error while computing SVD of nodal correlation") + + write(4397, *) NNODESL + do iost = 1, NNODESL + write(4397, *) nod_corr_full_(:, iost) + enddo + + write(4398, *) NNODESL + write(4398, *) nod_corr_EVLs_ + do iost = 1, NNODESL + write(4398, *) nod_corr_EVTs_(:, iost) + enddo + endif + end block +#endif + + + !=================================================================================== + ! BKG peak + ! + ! NOTE: we keep it in memory, since it will serve as reference + ! point for other nearby zones correct identification. + call timer%init() + zone_title = 'BKG center peak' + bkgz = MRectZone(0._RDP, zone_title) + if (settings%i_bisp_sym_ == BSA_SPATIAL_SYM_HALF) then + base_i = base_i / 2._RDP + call bkgz%define(MPoint(0._RDP, - base_i), 'i', base_i, base_j) + else + call bkgz%define(MPoint_t(), 'c', base_i, base_j) + endif + call bkgz%setPolicy(MPolicy_PEAK) + + + ! NOTE: 0 denotes that interest modes are to be inferenced from index 1. + ! In fact, there are 3 scenarios. + ! 1. next zone is pre-peak, and next peak interest modes' start from 1. + ! BKG does not include any resonant peak. + ! 2. next zone is pre-peak, and next peak interest modes' DO NOT start from 1. + ! BKG does include some resonant peaks (from 1-less-index or next peak zone) + ! 3. next zone is peak. + ! BKG does include this, plus all previous resonant peaks. + call bkgz%setInterestModeIndexPtr(0) + + + iost = settings%bkg_base_rfmnt_ + ! if (.not. test_no_bfm_mlr_) then + ! iost = iost - 1 ! get n. of segments + ! iost = iost / min(bkgz%policy_%interp_bfm_I_fct_, bkgz%policy_%interp_bfm_J_fct_) + ! iost = iost + 1 ! get back actualised n. of points + ! endif + if (settings%i_bisp_sym_ == BSA_SPATIAL_SYM_HALF) then + call bkgz%setRefinements(((iost-1)/2) + 1, iost) + else + call bkgz%setRefinements(iost, iost) + endif + + ! NOTE: if HALF symmetry, we need to check for the correct n. of ref. points. + if (settings%i_bisp_sym_ == BSA_SPATIAL_SYM_HALF) then + iost = (bkgz%nj_ - 1) / 2 + 1 + if (bkgz%ni_ /= iost) call bkgz%setRefinements(iost, bkgz%nj_, .true.) + endif + + ! backup reference deltas + df_I_ref = bkgz%deltaf_I_ + df_J_ref = bkgz%deltaf_J_ + if (.not. abs(df_I_ref - df_J_ref) < MACHINE_PRECISION) & + call bsa_Abort("Freq deltas of BKG peak zone differ. Should be the same.") + + + call bkgz%compute() + call logger_debug%logZonePremeshingTotTime(& + zone_title, timer%time(), msh_bfmpts_pre_, .true.) + + + if (.not. allocated(limits)) goto 998 ! NOTE: BKG zone covers them all, bad.. + + +#ifdef __BSA_CHECK_NOD_COH_SVD + goto 998 +#endif + + + ! ALL OTHER ZONES (IF NOT BKG COVERS EVERYTHING) + + write(*, '(1x, a, a, /, 10(" ", f10.4))') & + INFOMSG, ' Limits frontiers:', limits + + block + + !> Number of main directions ['NORTH', 'EAST ', 'SOUTH', 'WEST '] + integer(kind = 4), parameter :: N_DIRS_FULL = 4 + integer(kind = 4), parameter :: N_DIRS_HALF = 3 + integer(kind = 4) :: n_dirs_ + + !> Main directions labels + !> ['NORTH', 'EAST ', 'SOUTH', 'WEST '] + character(len = 5), parameter :: DIRS_LABELS(4) = ['NORTH', 'EAST ', 'SOUTH', 'WEST '] + + !> Main diag-crests directions labels + !> ['NORTH-EAST', 'SOUTH-EAST', 'SOUTH-WEST', 'NORTH-WEST'] + character(len = 10), parameter :: DIRS_DIAG_LABELS(4) = & + ['NORTH-EAST', 'SOUTH-EAST', 'SOUTH-WEST', 'NORTH-WEST'] + + !> Set of pair rotations, per main direction + real(RDP), parameter :: ROTATIONS(6) = & + [CST_PIt3d2, 0._RDP, CST_PId2, CST_PIGREC, CST_PIt3d2, 0._RDP] + + !> Which base is actually passed, depending on N-E-S-W direction + character(len = 1), parameter :: COORDS_DIR_CH(4) = ['j', 'i', 'j', 'i'] + + !> Signs to apply at limits, depending on N-E-S-W direction + integer(kind = 4), parameter :: LIM_SIGN_DIRS(4) = [1, 1, -1, -1] + + integer(kind = 4), parameter :: LEFT_RZ_SIGNS(4) = [1, -1, -1, 1] + + real(RDP), parameter :: DF_FCT_CST = 0.5_RDP + + integer(kind = 4) :: i, NLimsP1, idir, iim, ilim, nim, idir_t2 + integer(kind = 4) :: id_im_last, ilim_init_ = 0, n_bfm_pts_pre_ + real(RDP) :: lim, rtmp + real(RDP) :: df_I, df_J + real(RDP) :: sign_dir + real(RDP) :: maxF, base_i_ + real(RDP), allocatable :: maxext_sym_(:), bases_i_(:) + + logical :: warn_zone_over_limits = .false. + + type(MPolicy_t), pointer :: policy_ptr => null() + type(MPolicy_t) :: pol + + character(len = 1) :: coord_dir + + ! allocatables depending on Nlim +1 + real(RDP), allocatable :: rots(:) + real(RDP), allocatable :: deltas(:, :) + integer(kind = 4), allocatable :: refmts(:, :), inter_modes_(:) + integer(kind = 4), allocatable :: int_modes_(:) + real(RDP) :: rval + + !> general rectangular zone + type(MRectZone_t) :: rz + type(MPoint_t) :: basePts(4), ptI, ptE + + integer(kind = 4) :: N_THREADS_MIN_ + + + ! + NLimsP1 = NLims + 1 + allocate(rots(NLimsP1)) + rots = 0._RDP + allocate(deltas(2, NLimsP1)) + deltas = 0._RDP + allocate(refmts(2, NLimsP1)) + refmts = 0 + allocate(inter_modes_(NLimsP1)) + inter_modes_ = 0 + + + maxF = limits(NLims) + deltaI_2_S2_2 + id_im_last = size(msh_ZoneLimsInterestModes) - 1 + + pol = MPolicy_PRE_PEAK_2 + + ! extend limits and policies to covering after last peak + limits(NLimsP1) = maxF + policies(NLimsP1) = pol + +#ifdef __BSA_DEBUG + write(*, *) ' Interest modes : ' + write(*, *) msh_ZoneLimsInterestModes +#endif + + ! array of base points from BKG peak reference + basePts = [& + bkgz%getAPoint(), & + bkgz%Ept_, & + bkgz%getBPoint(), & + bkgz%Ipt_ & + ] + + allocate(bases_i_(4)) + if (settings%i_bisp_sym_ == BSA_SPATIAL_SYM_HALF) then + n_dirs_ = N_DIRS_HALF + bases_i_(1) = base_i + bases_i_(2) = base_j + bases_i_(3) = base_i + + N_THREADS_MIN_ = 1 + else + n_dirs_ = N_DIRS_FULL + bases_i_(:) = base_i + + N_THREADS_MIN_ = 2 + endif + + + !$ if (allocated(zone_title)) deallocate(zone_title) + + + !$omp parallel do & + !$omp default(firstprivate), & + !$omp private(idir, zone_title), & + !$omp shared(DIRS_LABELS, ROTATIONS, NLimsP1, COORDS_DIR_CH, LIM_SIGN_DIRS & + !$omp , policies, limits, df_I_ref, df_J_ref, msh_ZoneLimsInterestModes & + !$omp , refmts, deltas, inter_modes_, basePts, base_i, bases_i_ & + !$omp , struct_data, wd, settings, logger_debug & + !$omp , id_im_last, maxF, NLims, getBFM_msh, pol & + !$omp , NFREQS, NNODES, NNODESL, NLIBS, NLIBSL & + !$omp , NMODES, NMODES_EFF, MODES & + !$omp , NPSDEL, NTCOMPS, NDIRS, TCOMPS, DIRS & + !$omp , msh_NZones, msh_bfmpts_pre_, msh_max_zone_NPts, m3mf_msh_ptr_), & + !$omp num_threads(n_dirs_) + do idir = 1, n_dirs_ + + n_bfm_pts_pre_ = 0 + + call timer%init() + zone_title = 'Crest zone at '//DIRS_LABELS(idir) + + ! init rect zone + call rz%zoneName(zone_title) + call rz%setRotation(ROTATIONS(idir + 1)) + + ! get base init point + ptI = basePts(idir) + + coord_dir = COORDS_DIR_CH(idir) + sign_dir = LIM_SIGN_DIRS(idir) + + base_i_ = bases_i_(idir) + + iim = 1 + do ilim = 1, NLims + + lim = limits(ilim) + policy_ptr => policies(ilim) + + ! BUG: fix this frequencies definition! + df_I = df_I_ref * policy_ptr%delta_fI_fct_ + df_J = df_J_ref * policy_ptr%delta_fJ_fct_ + + call rz%setPolicy(policy_ptr) + + ! get this zone interest modes + if (idir == 2) inter_modes_(ilim) = iim + if (ilim == 1 .or. policies(ilim+1) == MPolicy_PEAK) then + nim = msh_ZoneLimsInterestModes(iim) + if (nim < 0) then ! pre-peak + iim = iim + 1 + nim = msh_ZoneLimsInterestModes(iim) + endif + int_modes_ = msh_ZoneLimsInterestModes(iim + 1 : iim + nim) + +#ifdef __BSA_DEBUG + !$omp critical + if (idir == 1) print *, int_modes_ + !$omp end critical +#endif + + ! set current zone interest modes pointer (before update) + call rz%setInterestModeIndexPtr(iim) + iim = iim + nim + 1 + endif + + call rz%defineFromEndPtCoordAndBase(& + ptI, sign_dir * lim, coord_dir, base_i_, 'i', df_I, df_J) + + ! BUG: optimise this!! + select case (idir) + case (1, 3) + call ptI%move(0._RDP, sign_dir * lim - ptI%freqJ()) + case (2, 4) + call ptI%move(sign_dir * lim - ptI%freqI(), 0._RDP) + end select + +#ifdef __BSA_DEBUG + if (idir == 1) then + write(*, '( 1x, a, i5, l, g16.5, " -> ", *(" ", i0) )', advance='yes') & + ' ilim, isPeak, rval, int_modes_, policies = ', & + ilim, policy_ptr == MPolicy_PEAK, rval, int_modes_ & + , policy_ptr%delta_fI_fct_, policy_ptr%delta_fJ_fct_ + endif +#endif + + ! NOTE: store refinements for later use + if (idir == 2) then + refmts(1:2, ilim) = rz%refinements() + deltas(1, ilim) = rz%deltaf_I_ + deltas(2, ilim) = rz%deltaf_J_ + endif + + call rz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + rz%zoneTotNPts() + + enddo ! limits + + df_I = df_I_ref * pol%delta_fI_fct_ + df_J = df_J_ref * pol%delta_fJ_fct_ + + call rz%setPolicy(pol) + call rz%setInterestModeIndexPtr(id_im_last) ! this zone has only Last mode of intrest + call rz%defineFromEndPtCoordAndBase(& + ptI, sign_dir * maxF, coord_dir, base_i_, 'i', df_I, df_J) + +#ifdef __BSA_OMP + if (idir == 2) then + refmts(1:2, NLimsP1) = rz%refinements() + deltas(1, NLimsP1) = rz%deltaf_I_ + deltas(2, NLimsP1) = rz%deltaf_J_ + endif +#endif + + call rz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + rz%zoneTotNPts() + + !$omp critical + call logger_debug%logZonePremeshingTotTime(& + zone_title, timer%time(), n_bfm_pts_pre_, .true.) + !$omp end critical + + enddo ! n dirs + !$omp end parallel do + + deallocate(bases_i_) + + ! BUG: might be removed, code duplication for little CPU improvement.. +#ifndef __BSA_OMP + refmts(1:2, NLimsP1) = rz%refinements() + deltas(1, NLimsP1) = rz%deltaf_I_ + deltas(2, NLimsP1) = rz%deltaf_J_ +#endif + inter_modes_(NLimsP1) = id_im_last + + print '(1x, a, a, i0, a/)', & + INFOMSG, 'Done with ', msh_NZones, ' pre meshing zones.' + + + + ! goto 998 + + + + if (ipre_mesh_type == BSA_PREMESH_TYPE_DIAG_CREST_NO) then + + + block + character(len = 1), allocatable :: bases_ch(:) + real(RDP) :: init_freq_, rbase_ + real(RDP) :: main_rz_rot_, left_rz_rot_, right_rz_rot_ + real(RDP) :: delta_main_rz_, rlimit_ + character(len = 40) :: z_name_ + character(len = 1) :: left_known_coord_, right_known_coord_ + integer(kind = 4) :: left_sign_, right_sign_, main_refs_ + integer(kind = 4) :: idirP1_ + + if (allocated(zone_title)) deallocate(zone_title) + if (allocated(rots)) deallocate(rots) + allocate(bases_ch(N_DIRS_FULL)) + bases_ch = ' ' + + ! reset correct base points (per direction) + ptI = basePts(1) ! backup 4th quadrant pt + basePts(1:3) = basePts(2:4) + basePts(4) = ptI + + ! computing base of first opening rect zone + init_freq_ = basePts(1)%freqI() + + main_refs_ = maxval(refmts(:, 1)) + bases_ch = getEquivalentLooperIterator(N_DIRS_FULL, 'ij') + + if (settings%i_bisp_sym_ == BSA_SPATIAL_SYM_HALF) n_dirs_ = n_dirs_ - 1 ! ==2 + + !$omp parallel do & + !$omp default(firstprivate), & + !$omp shared(ROTATIONS, LIM_SIGN_DIRS, main_refs_, bases_ch, inter_modes_ & + !$omp , basePts, policies, deltas, LEFT_RZ_SIGNS, DIRS_DIAG_LABELS & + !$omp , struct_data, wd, settings, logger_debug, limits & + !$omp , NFREQS, NNODES, NNODESL, NLIBS, NLIBSL & + !$omp , NMODES, NMODES_EFF, MODES & + !$omp , NPSDEL, NTCOMPS, NDIRS, TCOMPS, DIRS & + !$omp , msh_NZones, msh_bfmpts_pre_, msh_max_zone_NPts, m3mf_msh_ptr_), & + !$omp num_threads(n_dirs_) + do idir = 1, n_dirs_ + + call timer%init() + idirP1_ = idir + 1 + + ! treat initial opening rect zone + ! NOTE: treat it singularly, since its complete definition + ! will serve as base for definition of later rect zones. + write(unit=z_name_, fmt='(a, i0, 3a)') & + 'Zones in quadrant n. ', idir, ' (', DIRS_DIAG_LABELS(idir), ')' + call rz%zoneName(z_name_) + + left_rz_rot_ = ROTATIONS(idir) + main_rz_rot_ = ROTATIONS(idirP1_) + right_rz_rot_ = ROTATIONS(idirP1_ + 1) ! idir + 2 + call rz%setRotation(main_rz_rot_) + + pol = policies(1) + call rz%setPolicy(pol) + + ptI = basePts(idir) + rbase_ = limits(1) - init_freq_ + if (rbase_ <= 0._RDP) call bsa_Abort("Negative base.") + + ! BUG: better understand how to correctly define these zones.. + call rz%define(ptI, 'i', rbase_, rbase_) + call rz%setRefinements(main_refs_, main_refs_) + iim = 1 + call rz%setInterestModeIndexPtr(iim) +#ifdef __BSA_DEBUG + print '(1x, a, 2i5, 4g12.5)', ' @idir, ilim, ptI, ptE = ', & + idir, 1, rz%Ipt_%freqI(), rz%Ipt_%freqJ(), rz%Ept_%freqI(), rz%Ept_%freqJ() +#endif + call rz%compute() + n_bfm_pts_pre_ = rz%zoneTotNPts() + + ptE = rz%Ept_ ! saving end point + left_sign_ = LEFT_RZ_SIGNS(idir) + right_sign_ = LIM_SIGN_DIRS(idir) + + left_known_coord_ = bases_ch(idir) + right_known_coord_ = bases_ch(5 - idir) + + + do ilim = 2, NLimsP1 + + call rz%setInterestModeIndexPtr(inter_modes_(ilim)) + + rlimit_ = limits(ilim) + rbase_ = rlimit_ - limits(ilim - 1) + ptI = ptE + + ! + ! main rect zone + ! + + ! NOTE: this policy is shared by the other zones as well + call rz%setPolicy(policies(ilim)) + + delta_main_rz_ = minval(deltas(:, ilim)) + call rz%setRotation(main_rz_rot_) + call rz%defineFromEndPtCoordAndBase(& + ptI, left_sign_ * rlimit_, 'j', & + rbase_, left_known_coord_, delta_main_rz_, delta_main_rz_) +#ifdef __BSA_DEBUG + print '(1x, a, 2i5, 4g12.5)', ' @idir, ilim, ptI, ptE = ', & + idir, ilim, rz%Ipt_%freqI(), rz%Ipt_%freqJ(), rz%Ept_%freqI(), rz%Ept_%freqJ() +#endif + call rz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + rz%zoneTotNPts() + + ptE = rz%Ept_ ! saving end point (becomes init point at next iter) + + delta_main_rz_ = deltas(2, ilim) + + ! + ! side (left) rect zone (blue) + ! + call rz%setRotation(left_rz_rot_) + call rz%defineFromEndPtCoordAndBase(& + ptI, left_sign_ * init_freq_, left_known_coord_, & + rbase_, 'i', delta_main_rz_, delta_main_rz_) +#ifdef __BSA_DEBUG + print '(1x, a, 2i5, 4g12.5)', ' @idir, ilim, ptI, ptE = ', & + idir, ilim, rz%Ipt_%freqI(), rz%Ipt_%freqJ(), rz%Ept_%freqI(), rz%Ept_%freqJ() +#endif + call rz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + rz%zoneTotNPts() + + + ! + ! side (right) rect zone (pink) + ! + call rz%setRotation(right_rz_rot_) + call rz%defineFromEndPtCoordAndBase(& + ptI, right_sign_ * init_freq_, right_known_coord_, & + rbase_, 'j', delta_main_rz_, delta_main_rz_) +#ifdef __BSA_DEBUG + print '(1x, a, 2i5, 4g12.5)', ' @idir, ilim, ptI, ptE = ', & + idir, ilim, rz%Ipt_%freqI(), rz%Ipt_%freqJ(), rz%Ept_%freqI(), rz%Ept_%freqJ() +#endif + call rz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + rz%zoneTotNPts() + + enddo ! ilim = 2, NLimsP1 + + !$omp critical + call logger_debug%logZonePremeshingTotTime(& + z_name_, timer%time(), n_bfm_pts_pre_, .true.) + !$omp end critical + + enddo ! idir + !$omp end parallel do + + print '(1x, a, a, i0, a/)', & + INFOMSG, 'Done with ', msh_NZones, ' pre meshing zones.' + end block + + + + + + elseif (ipre_mesh_type == BSA_PREMESH_TYPE_DIAG_CREST_YES) then + + + + !=================================================== + ! RECT PADDING ZONE 1 (NE & SW) + ! + pol = MPolicy_PAD_ZONE_INTERN + df_I = df_I_ref * pol%delta_fI_fct_ + df_J = df_J_ref * pol%delta_fJ_fct_ + + ! BUG: "0" == all modes, not optimal at all + call rz%setInterestModeIndexPtr(0) + +#ifdef __BSA_OMP + if (allocated(zone_title)) deallocate(zone_title) +#endif + + !$omp parallel do & + !$omp default(firstprivate), & + !$omp private(zone_title), & + !$omp shared(ROTATIONS, LIM_SIGN_DIRS & + !$omp , maxF, basePts, df_I, df_J, pol & + !$omp , struct_data, wd, settings, logger_debug & + !$omp , NFREQS, NNODES, NNODESL, NLIBS, NLIBSL & + !$omp , NMODES, NMODES_EFF, MODES & + !$omp , NPSDEL, NTCOMPS, NDIRS, TCOMPS, DIRS & + !$omp , msh_NZones, msh_bfmpts_pre_, msh_max_zone_NPts, m3mf_msh_ptr_), & + !$omp num_threads(N_THREADS_MIN_) + do idir = 1, N_THREADS_MIN_ + + call timer%init() + + idir_t2 = idir * 2 + + if (idir == 1) then + zone_title = 'Internal rect Padding (NORTH-EAST)' + else + zone_title = 'Internal rect Padding (SOUTH-WEST)' + endif + call rz%zoneName(zone_title) + call rz%setRotation(ROTATIONS(idir_t2)) + call rz%setPolicy(pol) + + sign_dir = LIM_SIGN_DIRS(idir_t2) + rtmp = sign_dir * maxF + call rz%defineFromDeltas(& + basePts(idir_t2), 'i', df_I, df_J, rtmp, rtmp, force=.true.) + + call rz%compute() + + !$omp critical + call logger_debug%logZonePremeshingTotTime(& + zone_title, timer%time(), rz%zoneTotNPts(), .true.) + !$omp end critical + + enddo ! idir + !$omp end parallel do + + print '(1x, a, a, i0, a/)', & + INFOMSG, 'Done with ', msh_NZones, ' pre meshing zones.' + + + !=================================================== + ! SE & NW diagonal crests + ! + + ! reset base points (use old variable) + basePts(2) = basePts(1) + basePts(1) = basePts(3) + + block + type(MTriangZone_t) :: tz + type(MPoint_t) :: ptA, ptB + real(RDP) :: lim_I, lim_J, tmprot, tmprots(2), tmpdelta + + integer :: rftmp(2), ni, nj, idrot + + ! reset rotations for inclined crests + tmprots(1) = CST_PId2 + CST_PId4 + tmprots(2) = CST_PIt3d2 + CST_PId4 + + +#ifdef __BSA_OMP + if (allocated(zone_title)) deallocate(zone_title) + if (allocated(rots)) deallocate(rots) + allocate(rots(NLimsP1 * 2)) +#endif + + + !$omp parallel do & + !$omp default(firstprivate), & + !$omp private(zone_title), & + !$omp shared(ROTATIONS, LIM_SIGN_DIRS, DIRS_DIAG_LABELS & + !$omp , msh_ZoneLimsInterestModes, bkgz, deltaI_S2_2 & + !$omp , maxF, basePts, tmprots, ipre_mesh_mode & + !$omp , NLimsP1, limits, refmts, policies, deltas & + !$omp , base_i, id_im_last, NLims & + !$omp , struct_data, wd, settings, logger_debug & + !$omp , NFREQS, NNODES, NNODESL, NLIBS, NLIBSL & + !$omp , NMODES, NMODES_EFF, MODES & + !$omp , NPSDEL, NTCOMPS, NDIRS, TCOMPS, DIRS & + !$omp , msh_NZones, msh_bfmpts_pre_, msh_max_zone_NPts, m3mf_msh_ptr_), & + !$omp num_threads(N_THREADS_MIN_) + do idir = 1, N_THREADS_MIN_ + + n_bfm_pts_pre_ = 0 + idir_t2 = idir * 2 + + !DIR$ FORCEINLINE + call timer%init() + zone_title = 'Diagonal crest - '//DIRS_DIAG_LABELS(idir_t2) + + iim = 1 ! reset pointer for interest modes + + ! caching + sign_dir = LIM_SIGN_DIRS(idir_t2) ! BUG: remove, just for check + tmpdelta = deltaI_S2_2 * sign_dir + + ! opening triang zone + pol = MPolicy_PEAK + tz = MTriangZone(zone_title) + + lim_I = basePts(idir)%freqI() + lim_J = basePts(idir)%freqJ() + ptI = MPoint(lim_I + tmpdelta, lim_J) + ptA = MPoint(lim_I, lim_J - tmpdelta) + + ! TODO: check these lines + rftmp = bkgz%refinements() + + ! NOTE: take same interest modes as first zone limit + call tz%setInterestModeIndexPtr(1) + + call tz%setRefinements(rftmp(1), rftmp(2)) + call tz%setPolicy(pol) + call tz%define(basePts(idir), ptI, ptA) + call tz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + tz%zoneTotNPts() + + tmprot = tmprots(idir) ! main rotation for current direction + + + if (ipre_mesh_mode == BSA_PREMESH_MODE_BASE) then + + + ! IMPLEMENT & VERIFY + print '(1x, a, a)', & + ERRMSG, '"BASE" pre mesh mode not yet implemented.' + call bsa_Abort() + + + elseif (ipre_mesh_mode == BSA_PREMESH_MODE_ZONE_REFINED) then + + + ! Find all covered limits by initial triang-zone + if (ilim_init_ == 0) then + ilim_init_ = 1 + do while(abs(ptI%freqI()) > limits(ilim_init_) .and. ilim_init_ <= NLims) + ilim_init_ = ilim_init_ + 1 + enddo + !$omp critical + print '(/ 1x, a, a, i0, a)', & + WARNMSG, 'Init triang zone at diag-crest covers ', & + ilim_init_ - 1, ' limit(s).' + !$omp end critical + warn_zone_over_limits = ilim_init_ == NLims + 1 + endif + + + !DIR$ FORCEINLINE + call rz%zoneName(zone_title) + + + ! Renew rotations Looper Iterator (since now inclined zones) + ! NOTE: *2 because we index it twice in the same loop! + ! BUG: adapt to actual n. of limits done. + ! BUG: aviod creation of temporary + rots = getEquivalentLooperIterator(NLimsP1 * 2, & + [tmprot - tmprots(1), tmprot + tmprots(1)]) + idrot = 1 + + + ! Loop over n of (remained) limits + ! NOTE: +1 for that little padding after last peak + do ilim = ilim_init_, NLimsP1 + + + lim = limits(ilim) + + ! ================================= + ! Main rect zone + + ! NOTE: same refinements as previous crests + call rz%setRefinements(bkgz%ni_, refmts(2, ilim)) + + ! set pointer to interest modes + call rz%setInterestModeIndexPtr(iim) + call rz%setRotation(tmprot) + call rz%setPolicy(policies(ilim)) + call rz%defineFromEndPtCoordAndBase(& + ptI, - lim * LIM_SIGN_DIRS(idir_t2), 'j', base_i, 'i', called=.false.) + call rz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + rz%zoneTotNPts() + + ! NOTE: save since RZ will be overridden + ptA = rz%getAPoint() + ptB = rz%getBPoint() + ptE = rz%Ept_ + if (policies(ilim) == MPolicy_PEAK) then + pol = MPolicy_CREST + else + pol = MPolicy_BASIN + endif + + + + ! ================================= + ! north-east (south-west) + + ! 1. triang leveling zone + + call tz%setInterestModeIndexPtr(iim) + + ! update interest modes pointer for next iteration + nim = msh_ZoneLimsInterestModes(iim) + if (nim < 0) then ! pre-peak + iim = iim + 1 + else! peak + iim = iim + nim + 1 + endif + + ptI = MPoint(lim * LIM_SIGN_DIRS(idir_t2), rz%Ipt_%freqJ()) + call tz%setRefinements(rz%nj_, rz%nj_) + call tz%setPolicy(pol) + call tz%define(ptI, ptA, rz%Ipt_) + call tz%compute() + rtmp = tz%baseI() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + tz%zoneTotNPts() + + ! 2. rect closing zone + call rz%setRotation(rots(idrot)) + idrot = idrot + 1 + call rz%setPolicy(pol) + call rz%defineFromEndPtCoordAndBase(& + rz%Ipt_, lim_J, 'j', rtmp, 'i', & + deltas(2, ilim) * pol%delta_fI_fct_, deltas(2, ilim) * pol%delta_fJ_fct_) + call rz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + rz%zoneTotNPts() + + + + ! ================================= + ! south-west (north-east) + + ! 1. triang leveling zone + ptI = MPoint(ptB%freqI(), - lim * LIM_SIGN_DIRS(idir_t2)) + call tz%define(ptI, ptB, ptE) + call tz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + tz%zoneTotNPts() + + ! 2. rect closing zone + ! + ! NOTE: the +1 should reproduce the next() method + ! called recursively inside the ilim loop.. + call rz%setRotation(rots(idrot)) + idrot = idrot + 1 + call rz%defineFromEndPtCoordAndBase(& + tz%Cpt_, lim_I, 'i', rtmp, 'i', & + deltas(2, ilim) * pol%delta_fI_fct_, deltas(2, ilim) * pol%delta_fJ_fct_) + + call rz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + rz%zoneTotNPts() + + + ! save for starting next iteration + ptI = ptA + + enddo ! N limits + 1 + + + ! closing triangle + if (.not. warn_zone_over_limits) then + + ! BUG: improve + pol = MPolicy_PEAK + + call tz%setInterestModeIndexPtr(id_im_last) + + call tz%setPolicy(pol) + + ni = settings%bkg_base_rfmnt_ * pol%delta_fI_fct_ + nj = settings%bkg_base_rfmnt_ * pol%delta_fJ_fct_ + call tz%setRefinements(ni, nj) + + ptI = MPoint(maxF * LIM_SIGN_DIRS(idir_t2), - maxF * LIM_SIGN_DIRS(idir_t2)) + + ptA = MPoint(ptI%freqI() - (deltaI_S2_2 * LIM_SIGN_DIRS(idir_t2)), ptI%freqJ()) + ptB = MPoint(ptI%freqI(), ptI%freqJ() + (deltaI_S2_2 * LIM_SIGN_DIRS(idir_t2))) + + call tz%define(ptI, ptA, ptB) + call tz%compute() + n_bfm_pts_pre_ = n_bfm_pts_pre_ + tz%zoneTotNPts() + + endif ! closing triangle, if not warn_zone_over_limits + + !$omp critical + call logger_debug%logZonePremeshingTotTime(& + zone_title, timer%time(), n_bfm_pts_pre_, .true.) + !$omp end critical + + endif ! pre mesh mode + + enddo ! idir + !$omp end parallel do + + print '(1x, a, a, i0, a/)', & + INFOMSG, 'Done with ', msh_NZones, ' pre meshing zones.' + + end block + + + endif ! ipre_mesh_type + + + + + !=============================== + ! EXTERNAL PADDING + ! + if (.not. warn_zone_over_limits .and. (settings%i_full_coverage_ == 1)) then + +#ifdef __BSA_OMP + if (allocated(zone_title)) deallocate(zone_title) +#endif + + ! BUG: check if it is ok setting this interest modes' pointer. + call rz%setInterestModeIndexPtr(id_im_last) + + pol = MPolicy_PAD_ZONE_EXTERN + call rz%setPolicy(pol) + + df_I = df_I_ref * pol%delta_fI_fct_ + df_J = df_J_ref * pol%delta_fJ_fct_ + + allocate(maxext_sym_(4)) ! BUG: default allocate with max (4) elements + + if (settings%i_bisp_sym_ == BSA_SPATIAL_SYM_HALF) then + basePts(1) = MPoint(0._RDP, maxF) + basePts(2) = MPoint( maxF, maxF) + basePts(3) = MPoint( maxF,-maxF) + + maxext_sym_(1) = max_ext + maxext_sym_(2) = max_ext + maxext_sym_(3) = 0._RDP + + n_dirs_ = N_DIRS_HALF + else + basePts(1) = MPoint(-maxF, maxF) + basePts(2) = MPoint( maxF, maxF) + basePts(3) = MPoint( maxF,-maxF) + basePts(4) = MPoint(-maxF,-maxF) + + maxext_sym_(:) = max_ext + endif + + !$omp parallel do & + !$omp default(firstprivate), & + !$omp private(zone_title), & + !$omp shared(DIRS_LABELS, df_I, df_J, basePts, ROTATIONS & + !$omp , struct_data, wd, settings, logger_debug & + !$omp , LIM_SIGN_DIRS, LEFT_RZ_SIGNS, max_ext, maxext_sym_ & + !$omp , NFREQS, NNODES, NNODESL, NLIBS, NLIBSL, NMODES, DIRS & + !$omp , NMODES_EFF, MODES, NPSDEL, NTCOMPS, NDIRS, TCOMPS & + !$omp , msh_NZones, msh_bfmpts_pre_, msh_max_zone_NPts, m3mf_msh_ptr_), & + !$omp num_threads(n_dirs_) + do idir = 1, n_dirs_ + + call timer%init() + zone_title = 'External rect Padding '//DIRS_LABELS(idir) + call rz%zoneName(zone_title) + + call rz%setRotation(ROTATIONS(idir + 1)) + + call rz%defineFromDeltas(basePts(idir), 'i', & + df_I, df_J, & + LIM_SIGN_DIRS(idir) * maxext_sym_(idir), & + LEFT_RZ_SIGNS(idir) * max_ext, force=.true.) + + call rz%compute() + + !$omp critical + call logger_debug%logZonePremeshingTotTime(& + zone_title, timer%time(), rz%zoneTotNPts(), .true.) + !$omp end critical + + enddo ! ndirs + !$omp end parallel do + + deallocate(maxext_sym_) + + endif ! (.not. warn_zone_over_limits .and. (settings%i_full_coverage_)) + + print '(1x, a, a, i0, a/)', & + INFOMSG, 'Done with ', msh_NZones, ' pre meshing zones.' + + endblock + + + + 998 continue + + + ! NOTE: Dump modal info if needed, before rewinding.. + write(unit_dump_bfm_) settings%i_dump_modal_ + if (settings%i_dump_modal_ == 1) then + + print '(1x, a, a /)', & + WARNMSG, 'Including modal info in dump file. Check if this can be avoided.' + + ! write kept modes, might serve after as well. + ! NOTE: in fact, nm_eff_ is the VERY FIRST thing which is dumped! + ! But, at the very beginning, we don't yet how many modes will be kept, + ! this is why it is done now here. + write(unit_dump_bfm_) struct_data%modal_%modes_ + + write(unit_dump_bfm_) & + struct_data%modal_%Mm_(struct_data%modal_%modes_) + write(unit_dump_bfm_) & + struct_data%modal_%Cm_(struct_data%modal_%modes_, struct_data%modal_%modes_) + write(unit_dump_bfm_) & + struct_data%modal_%Km_(struct_data%modal_%modes_) + +#ifdef __BSA_DEBUG + print '(1x, a, a)', INFOMSG, 'Modal info dumped -- ok.' +#endif + endif + + + ! NOTE: Ok, now that premesh has finished, before going + ! to actual meshing, rewind dump file and rewrite actual + ! needed head information. + ! This goes with previous note. At the very beginning, where we write 0, + ! we do it because WE DO NOT YET KNOW ACTUAL INFORMATION to dump. + rewind(unit_dump_bfm_) + write (unit_dump_bfm_) struct_data%modal_%nm_eff_ + write (unit_dump_bfm_) dimM_bisp_ + write (unit_dump_bfm_) msh_NZones + write (unit_dump_bfm_) msh_max_zone_NPts + + +#ifdef __BSA_DEBUG + write(unit_debug_, *) ' @BsaMesherImpl::PreMesh() : Init BSA-Mesher pre meshing phase -- ok.' +#endif + end subroutine PreMesh + + + + + + + + + + + + + + + + + + + !> Post meshing phase. + !> Once data has been dumped from PreMeshing phase, + !> retrieve and process it. + !> BFM data is interpolated based on interpolation method. + !> Supported methods: + !> - HTPC : Head-Tail-Previous-Current + subroutine Mesh() + use BsaLib_MZone, only: MZone_t + integer :: izone_id, izone, ival2 +#ifdef __BSA_OMP +# define __BFM_DATA_ ,bfmdata +# define __bfmdata_in_ bfmdata, +# define __BRM_EXPORT_DATA brm_export_data_ + real(RDP), allocatable :: bfmdata(:, :) +#else +# define __BFM_DATA_ +# define __bfmdata_in_ +# define __BRM_EXPORT_DATA + character(len = 256) :: emsg +#endif + + class(MZone_t), pointer :: z => null() + type(MRectZone_t), target :: rz + type(MTriangZone_t), target :: tz + + class(*), pointer :: brm_export_data_ => null() + type(BrmExportBaseData_t), allocatable, target :: brm_export_base_data_ + + + ! skip them, we already have them stored in module variables + ! However, there since they might serve outside this scope + ! (i.e. if undumping file from another program) + rewind(unit_dump_bfm_) ! make sure to rewind unit before starting reading it + read(unit_dump_bfm_) izone ! n modes effective + read(unit_dump_bfm_) izone ! dimM_bisp + read(unit_dump_bfm_) ival2 ! n. of meshing zones + read(unit_dump_bfm_) ival2 ! msh_max_zone_PTS + +#ifdef __BSA_DEBUG + if (.not. izone == dimM_bisp_) & + call bsa_Abort('First undumped value does not match BISP dimension.') + if (.not. ival2 == msh_max_zone_NPts) & + call bsa_Abort('Second undumped value has a wrong value.') +#endif + + + +#ifndef __BSA_OMP + ! BUG: this might be removed in place of a local (thread) allocation! + ! allocate BFM tmp variable to hold data + ! for at most the zone with max n. of points. + allocate(bfm_undump(dimM_bisp_, msh_max_zone_NPts), stat=izone_id, errmsg=emsg) + if (izone_id == 0) then +# ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('bfm_undump', & + [dimM_bisp_, msh_max_zone_NPts], loc(bfm_undump), sizeof(bfm_undump)) +# endif + else + call allocKOMsg('bfm_undump', izone_id, emsg) + endif +#endif + + + print '(1x, a)', '-----------------------------------------------------------' + print '(1x, a)', '-------------------- POST - MESH --------------------' + print '(1x, a)', '-----------------------------------------------------------' + + if (do_export_brm_ .and. i_brmexport_mode_ == BSA_EXPORT_BRM_MODE_BASE) then + allocate(brm_export_base_data_) + brm_export_base_data_%nm_ = struct_data%modal_%nm_eff_ + brm_export_base_data_%ncomb_ = dimM_bisp_ + brm_export_base_data_%ispsym_ = settings%i_bisp_sym_ + brm_export_base_data_%nzones_ = msh_NZones + brm_export_base_data_%modes_ => struct_data%modal_%modes_ + + brm_export_data_ => brm_export_base_data_ + endif + + ! NOTE: Undump main Rect BKG Peak zone separately + ! + read(unit_dump_bfm_) izone_id + print '(1x, a, a, i6, a, i0 )', & + INFOMSG, 'Interpolating zone n. ', 1, ', with ID= ', izone_id + if (do_export_brm_) brm_export_base_data_%idZone_ = izone_id + call UndumpZone( rz __BFM_DATA_) + call rz%interpolate(__bfmdata_in_ __BRM_EXPORT_DATA) + if (do_export_brm_) brm_export_base_data_%i_doNotPrintGenHeader_ = 1 ! now we can disable gen header print + +#ifdef __BSA_OMP + deallocate(bfmdata) !<-- better to copy a null pointer than a whole bunch of memory. + if (associated(brm_export_data_)) brm_export_data_ => null() +#endif + + ! NOTE: no need to check for EOF. We know how many zones we have dumped. + ! + !$omp parallel do & + !$omp firstprivate(brm_export_base_data_, brm_export_data_), & + !$omp private(z, rz, tz, izone_id, bfmdata), & + !$omp shared(struct_data, wd, settings, logger_debug & + !$omp , NFREQS, NNODES, NNODESL, NLIBS, NLIBSL & + !$omp , NMODES, NMODES_EFF, MODES & + !$omp , NPSDEL, NTCOMPS, NDIRS, TCOMPS, DIRS & + !$omp , MZone_ID, msh_NZones, m3mr_msh_ptr_ & + !$omp , msh_ZoneLimsInterestModes, do_validate_deltas_ & + !$omp , msh_bfmpts_post_, msh_brmpts_post_, unit_dump_bfm_ & + !$omp , bkg_peakw_ & + !$omp , dimM_bisp_, getBFM_msh, getBRM_msh, write_brm_fptr_), & + !$omp num_threads(8) + do izone = 2, msh_NZones + + !$omp critical + read(unit_dump_bfm_) izone_id ! fetch zone type ID + + print '(1x, a, a, i6, a, i0 )', & + INFOMSG, 'Interpolating zone n. ', izone, ', with ID= ', izone_id + + if (izone_id == MZone_ID%RECTANGLE) then + call UndumpZone( rz __BFM_DATA_) + z => rz + elseif (izone_id == MZone_ID%TRIANGLE) then + call UndumpZone( tz __BFM_DATA_) + z => tz + endif + !$omp end critical + + ! brm_export_base_data_%i_doNotPrintZonHeader_ = 0 + if (do_export_brm_) then + brm_export_base_data_%idZone_ = izone_id + if (.not. associated(brm_export_data_)) brm_export_data_ => brm_export_base_data_ + endif + call z%interpolate(__bfmdata_in_ __BRM_EXPORT_DATA) + + enddo ! nZones + !$omp end parallel do + +#ifndef __BSA_OMP + if (allocated(bfm_undump)) deallocate(bfm_undump) +#endif + end subroutine Mesh + + + + + + + + + + + + + + + + + + + + + + function getEquivalentLooperIterator_char(dim, pattern) result(LoopIter) + integer, intent(in) :: dim + character(len = *), intent(in) :: pattern + character(len = 1) :: LoopIter(dim) + + integer :: lpat, npat, ipat, id, i + + lpat = len(pattern) + if (lpat > dim) call bsa_Abort('String length is greater than required Iterator length.') + + ! compute how many (integer) times pattern length stays inside dim + npat = dim / lpat + + id = 1 + do ipat = 1, npat + do i = 1, lpat + LoopIter(id) = pattern(i:i) + id = id + 1 + enddo + enddo + ! trailing + do i = 1, dim - (lpat * npat) + LoopIter(id) = pattern(i:i) + id = id + 1 + enddo + end function getEquivalentLooperIterator_char + + + function getEquivalentLooperIterator_real(dim, vals) result(LoopIter) + integer, intent(in) :: dim + real(RDP), intent(in) :: vals(:) + real(RDP) :: LoopIter(dim) + + integer :: nvals, nint, i, j, id + + nvals = size(vals) + if (nvals > dim) call bsa_Abort('Num of values greater than required Iterator length.') + + nint = dim / nvals + + id = 1 + do j = 1, nint + do i = 1, nvals + LoopIter(id) = vals(i) + id = id + 1 + enddo + enddo + ! trailing + do i = 1, dim - (nvals*nint) + LoopIter(id) = vals(i) + id = id + 1 + enddo + end function getEquivalentLooperIterator_real + + + + + + + pure elemental function getMaxSpaceExtension_() result(max_ext) + real(RDP) :: max_ext + + max_ext = maxval(struct_data%modal_%nat_freqs_) + max_ext = max_ext * settings%max_area_extension_ + end function getMaxSpaceExtension_ + + + + + + + subroutine prefetchZoneLimits_(bpw_ext_2, limits, policies, NLims, inter_modes) + real(RDP), intent(in) :: bpw_ext_2 + real(RDP), allocatable, intent(out) :: limits(:) + type(MPolicy_t), allocatable, intent(out) :: policies(:) + integer(kind = 4), intent(out) :: NLims + integer(kind = 4), allocatable, intent(out) :: inter_modes(:) + + integer :: skip, imodesout + + real(RDP) :: peak_ext_lims_(2, NM_EFF__) + + + ! get actual peak extensions, for each mode + ! (BACK and FORTH limits) + !DIR$ FORCEINLINE + peak_ext_lims_ = getActualPeakZoneExtensionLimits_() + + ! search for modes that FALL (entirely) IN BKG PEAK AREA + skip = 1 + do while (peak_ext_lims_(2, skip) <= bpw_ext_2) + skip = skip + 1 + if (skip .gt. NM_EFF__) exit + enddo + ! skip = findloc(peak_ext_lims_(2, 1:NM_EFF__) > bpw_ext_2, .true.) + ! if (skip == 0) then + ! skip = NM_EFF__ + ! else + ! skip = skip - 1 + ! endif + skip = skip - 1 !<-- how many modes actually FULLY included + + ! NOTE: at worst, there will be 2*NM limits (clean case) + imodesout = NM_EFF__ - skip + + if (imodesout == 0) then + print '(1x, a, a)', WARNMSG, 'All resonant peak fall within BKG peak !' + NLims = 0 + return + endif + + print '(1x, a, i0, a, i0, a)', & + INFOMSG, skip, ' res peak (out of ', NM_EFF__, ') fall(s) in BKG peak area.' + + + ! warn if too many modes fall in BKG PEAK ZONE + if (skip >= ceiling(real(NM_EFF__) / N_RES_PEAK_IN_BKG_ZONE_DIV_FCT_)) & + print '(1x, 2a, i0, a/)', & + WARNMSG, 'More than 1/', N_RES_PEAK_IN_BKG_ZONE_DIV_FCT_, & + ' of resonant peaks fall entirely within BKG peak area.' + + + block + ! local instances, to move using move_alloc() + real(RDP), allocatable :: limits_(:) + type(MPolicy_t), allocatable :: policies_(:) + integer :: NLims_ + integer, allocatable :: inter_modes_(:) + + integer :: itmp, iim, jim, im, istat, nmode + character(len = 256) :: emsg + + ! peak zone's BACK and FORTH Frontiers + real(RDP) :: pzBF, pzFF + + + ! allocate results + itmp = imodesout * 2 + 1 + allocate(limits_(itmp), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('limits_', itmp, loc(limits_), sizeof(limits_)) +#endif + else + call allocKOMsg('limits_', istat, emsg) + endif + limits_ = 0._RDP + + allocate(policies_(itmp), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('policies_', itmp, loc(policies_), sizeof(policies_)) +#endif + else + call allocKOMsg('policies_', istat, emsg) + endif + policies_(:) = MPolicy_DEF + + ! BUG: do not hard code dimension !!?? + ! Instead try to relate to NM and itmp + ! Might throw run time error if we try to access + ! out of bound!! + allocate(inter_modes_(200), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('inter_modes_', 200, loc(inter_modes_), sizeof(inter_modes_)) +#endif + else + call allocKOMsg('inter_modes_', istat, emsg) + endif + inter_modes_ = 0 + + + ! START + + skip = skip + 1 !<-- start from next (completely/partially out) resonant peak zone. + if (bpw_ext_2 < peak_ext_lims_(1, skip)) then ! two separate peak zones -> PRE_PEAK in between + + ! we set first limits by DEFAULT. + ! NOTE: they might be overridden from following res peak limit zones. + limits_(1:2) = peak_ext_lims_(:, skip) + NLims_ = 2 + policies_(1) = MPolicy_PRE_PEAK_1 + policies_(2) = MPolicy_PEAK + + ! Setting interest modes + if (skip == 1) then + inter_modes_(1) = CODE_PRE_PEAK_OK + else + inter_modes_(1) = CODE_PRE_PEAK_KO + endif + + iim = 2 + inter_modes_(iim) = 1 ! this tells us how many interest modes to be read + + ! this are instead the real interest modes. + jim = 3 + inter_modes_(jim) = struct_data%modal_%modes_(skip) + + else ! BKG extension falls in the MIDDLE of the PEAK ZONE (or also maybe after it!) + + limits_(1) = peak_ext_lims_(2, skip) + policies_(1) = MPolicy_PEAK + NLims_ = 1 + + ! setting interest modes, only PEAK zone + inter_modes_(1) = 1 + inter_modes_(2) = struct_data%modal_%modes_(skip) + iim = 1 + jim = 2 + endif + + ! now, continue starting from next mode's peak zone. + skip = skip + 1 + do im = skip, NM_EFF__ + + nmode = struct_data%modal_%modes_(im) + + pzBF = peak_ext_lims_(1, im) ! peak zone's BACK FRONTIER + pzFF = peak_ext_lims_(2, im) ! peak zone's FORTH FRONTIER + + if (pzBF < limits_(NLims_)) then ! there is OVERLAP! + ! this mode's BACK frontier, falls BEHIND + ! previous mode's FORTH frontier + + ! BUG: check this branch + if (NLims_ == 2 .and. pzBF <= limits_(NLims_ - 1)) then + + ! it is actually a FULL COVERAGE meaning that this mode's BACK frontier + ! entirely covers previously defined zone (i.e. resonance peak very very close) + + itmp = NLims_ - 1 + limits_(itmp) = pzBF + + policies_(itmp) = MPolicy_PRE_PEAK_2 + + limits_(NLims_) = pzFF + policies_(NLims_) = MPolicy_PEAK + + else ! PARTIAL overlap + ! i.e. update only FORTH frontier, keeping BACK unchanged. + + limits_(NLims_) = pzFF + policies_(NLims_) = MPolicy_PEAK + endif + + + ! NOTE: since now, for PRE_PEAK zones we use "references" + ! to interest modes of ADJACENT PEAK ZONES, + ! no need to update its list, but only for current peak zone. + + ! add an interest mode (NOTE: do not update its index) + inter_modes_(iim) = inter_modes_(iim) + 1 + + ! append current interest mode + jim = jim + 1 + inter_modes_(jim) = nmode + + else ! NO COVERAGE at all, normal flow + + NLims_ = NLims_ + 1 + limits_(NLims_) = pzBF + policies_(NLims_) = MPolicy_PRE_PEAK_2 + + NLims_ = NLims_ + 1 + limits_(NLims_) = pzFF + policies_(NLims_) = MPolicy_PEAK + + + ! NOTE: in such case, a NEW INTEREST MODES COUNTING + ! is initialised, since mode "im" and "im-1" + ! are well distant and separated, so not to have + ! any interaction + iim = jim + 1 + inter_modes_(iim) = CODE_PRE_PEAK_OK + + iim = iim + 1 ! this is for the new peak zone + + ! initialise counting to 1, might be incremented if overlapping to the right + inter_modes_(iim) = 1 + + jim = iim + 1 + inter_modes_(jim) = nmode + endif + enddo ! modes + + + ! NOTE: appending interest mode (only last) for + ! that little padding zone added after last peak zone, for better shaping + ! (and for not losing important info) + ! BUG: can be removed ?? + iim = jim + 1 + inter_modes_(iim) = 1 + jim = iim + 1 + inter_modes_(jim) = struct_data%modal_%modes_(NM_EFF__) ! only last mode is of interest + + + ! move memory before leaving block + NLims = NLims_ + + ! NOTE: this is needed because of covering after last peak. + NLims_ = NLims_ + 1 + limits_ = limits_(1 : NLims_) + call move_alloc(limits_, limits) + + + inter_modes_ = inter_modes_(1 : jim) ! TODO: maybe do it here as well +1 ?? + call move_alloc(inter_modes_, inter_modes) + + + allocate(policies(NLims_), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('policies', NLims_, loc(policies), sizeof(policies)) +#endif + else + call allocKOMsg('policies', istat, emsg) + endif + policies = policies_(1 : NLims_) + end block + end subroutine ! prefetch zone limits + + + + + function getActualPeakZoneExtensionLimits_() result(peak_exts_lims) + real(RDP) :: peak_exts_lims(2, NM_EFF__) + real(RDP) :: cst, modf, ext + integer :: im, nmode + integer(kind = 4), parameter :: I_PEAK_EXT_DIV_ = 1 + + cst = real(settings%gen_peak_area_extension_ / I_PEAK_EXT_DIV_, kind = RDP) + + allocate(peak_exts_(NM__)) + peak_exts_ = -1. + do im = 1, NM_EFF__ ! TODO: implement do concurrent + + nmode = struct_data%modal_%modes_(im) + + modf = struct_data%modal_%nat_freqs_(nmode) + ext = struct_data%modal_%xsi_(nmode) * modf + ext = ext * cst + + peak_exts_lims(1, im) = modf - ext + peak_exts_lims(2, im) = modf + ext + + peak_exts_(nmode) = ext + ext + enddo + end function + + +end submodule \ No newline at end of file diff --git a/src/BsaLib/bsa/meshing/point/MPoint.f90 b/src/BsaLib/bsa/meshing/point/MPoint.f90 new file mode 100644 index 0000000..a6b2ed4 --- /dev/null +++ b/src/BsaLib/bsa/meshing/point/MPoint.f90 @@ -0,0 +1,354 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_MPoint + +#include "../../../precisions" + + use BsaLib_CONSTANTS + implicit none + private + public :: getPointsDistance, MPoint + + + type, public :: MPoint_t + + real(RDP), private :: fi_ = 0._RDP + real(RDP), private :: fj_ = 0._RDP + + contains + + procedure, pass :: setFreqs + procedure, pass :: move + procedure, pass :: freqI + procedure, pass :: freqJ + procedure, pass :: getDistanceI => getDistanceIfromCoord, getDistanceIfromPt + procedure, pass :: getDistanceJ => getDistanceJfromCoord, getDistanceJfromPt + procedure, pass :: getNewPointFromDistAndRot + procedure, pass :: scale => scaleInt, scaleReal + end type MPoint_t + + ! class constructors + interface MPoint + module procedure MPoint_as_compiler + module procedure MPoint_from_ints + module procedure MPoint_from_MPoint + end interface + + + interface operator(==) + module procedure PointsAreEqual + end interface + public :: operator(==) + + interface operator(/=) + module procedure PointsAreNotEqual + end interface + public :: operator(/=) + + + interface operator(*) + module procedure ScaleByInt + module procedure ScaleByReal + end interface + public :: operator(*) + + + interface assignment(=) + module procedure assignFromPt + module procedure assignFromInt + module procedure assignFromReal + end interface + public :: assignment(=) + + + +contains + + + + pure function MPoint_as_compiler(fi, fj) result(this) + real(RDP), intent(in) :: fi, fj + type(MPoint_t) :: this + + ! BUG: maybe here needed to use rounding precision + this%fi_ = fi + this%fj_ = fj + end function + + + pure function MPoint_from_ints(fi, fj) result(this) + integer, intent(in) :: fi, fj + type(MPoint_t) :: this + + this = MPoint_as_compiler(real(fi, RDP), real(fj, RDP)) + end function + + + pure function MPoint_from_MPoint(p) result(this) + class(MPoint_t), intent(in) :: p + type(MPoint_t) :: this + + ! make a copy of instance member variables. + this%fi_ = p%fi_ + this%fj_ = p%fj_ + end function + + + + + + + + elemental function freqI(this) result(val) + class(MPoint_t), intent(in) :: this + real(RDP) :: val + + val = this%fi_ + end function + + + elemental function freqJ(this) result(val) + class(MPoint_t), intent(in) :: this + real(RDP) :: val + + val = this%fj_ + end function + + + + subroutine setFreqs(this, fi, fj) + class(MPoint_t), intent(inout) :: this + real(RDP), intent(in) :: fi, fj + + this%fi_ = fi + this%fj_ = fj + end subroutine + + + + + elemental function getPointsDistance(p1, p2) result(dist) + class(MPoint_t), intent(in) :: p1, p2 + real(RDP) :: dist + + real(RDP) :: dx, dy + + dx = abs(p1%fi_ - p2%fi_) + dy = abs(p1%fj_ - p2%fj_) + + dist = sqrt(dx*dx + dy*dy) + end function getPointsDistance + + + + + + !> Moves a point by specified x-y deltas. + subroutine move(this, di, dj) + class(MPoint_t), intent(inout) :: this + real(RDP), intent(in) :: di, dj + + this%fi_ = this%fi_ + di + this%fj_ = this%fj_ + dj + end subroutine move + + + + elemental function getDistanceIfromCoord(this, i_coord) result(dist) + class(MPoint_t), intent(in) :: this + real(RDP), intent(in) :: i_coord + real(RDP) :: dist + + dist = abs(this%fi_ - i_coord) + end function getDistanceIfromCoord + + elemental function getDistanceIfromPt(this, p) result(dist) + class(MPoint_t), intent(in) :: this + class(MPoint_t), intent(in) :: p + real(RDP) :: dist + + dist = abs(this%fi_ - p%fi_) + end function getDistanceIfromPt + + + elemental function getDistanceJfromCoord(this, j_coord) result(dist) + class(MPoint_t), intent(in) :: this + real(RDP), intent(in) :: j_coord + real(RDP) :: dist + + dist = abs(this%fj_ - j_coord) + end function getDistanceJfromCoord + + elemental function getDistanceJfromPt(this, p) result(dist) + class(MPoint_t), intent(in) :: this + class(MPoint_t), intent(in) :: p + real(RDP) :: dist + + dist = abs(this%fj_ - p%fj_) + end function getDistanceJfromPt + + + + pure recursive function getNewPointFromDistAndRot(this, dist, rot) result(P) + !! Returns a new Point located by distance and rotation + !! from current Point. + class(MPoint_t), intent(in) :: this + real(RDP), intent(in) :: dist, rot + type(MPoint_t) :: P + + ! BUG: change?? + real(kind = 8) :: ang, dI, dJ + + if (rot < CST_PId2) then + + ang = rot + dI = sin(ang) + dJ = cos(ang) + + elseif (rot < CST_PIGREC) then + + ang = real(rot, 8) - CST_PId2 + dI = cos(ang) + dJ = - sin(ang) + + elseif (rot < CST_PIt3d2) then + + ang = rot - CST_PIGREC + dI = - sin(ang) + dJ = - cos(ang) + + elseif (rot <= CST_PIt2) then + + ang = rot - CST_PIt3d2 + dI = - cos(ang) + dJ = sin(ang) + + else + + ! NOTE: call this function recursively, + ! after having subtracted 2*PI. + ang = rot - CST_PIt2 + P = this%getNewPointFromDistAndRot(dist, ang) + endif + + ! scale unitary deltas (given by rotation) + dI = dI * dist + dJ = dJ * dist + + ! apply deltas to current point coords + dI = dI + this%fi_ + dJ = dJ + this%fj_ + + ! get new point location + P = MPoint_t(dI, dJ) + end function getNewPointFromDistAndRot + + + + + subroutine scaleInt(this, i) + class(MPoint_t), intent(inout) :: this + integer, intent(in) :: i + + this%fi_ = this%fi_ * i + this%fj_ = this%fj_ * i + end subroutine scaleInt + + subroutine scaleReal(this, i) + class(MPoint_t), intent(inout) :: this + real(RDP), intent(in) :: i + + this%fi_ = this%fi_ * i + this%fj_ = this%fj_ * i + end subroutine scaleReal + + + + + + + elemental function PointsAreEqual(p1, p2) result(eq) + class(MPoint_t), intent(in) :: p1, p2 + logical :: eq + + real(RDP) :: dfi, dfj + + dfi = abs(p1%fi_ - p2%fi_) + dfj = abs(p1%fj_ - p2%fj_) + eq = (dfi <= MACHINE_PRECISION .and. dfj <= MACHINE_PRECISION) + end function PointsAreEqual + + + elemental function PointsAreNotEqual(p1, p2) result(neq) + class(MPoint_t), intent(in) :: p1, p2 + logical :: neq + + neq = .not. PointsAreEqual(p1, p2) + end function PointsAreNotEqual + + + + + + pure function ScaleByInt(p, i) result(res) + class(MPoint_t), intent(in) :: p + integer, intent(in) :: i + type(MPoint_t) :: res + + res = MPoint_t(p%fi_ * i, p%fj_ * i) + end function ScaleByInt + + pure function ScaleByReal(p, i) result(res) + class(MPoint_t), intent(in) :: p + real(RDP), intent(in) :: i + type(MPoint_t) :: res + + res = MPoint_t(p%fi_ * i, p%fj_ * i) + end function ScaleByReal + + + + + + + pure subroutine assignFromPt(lhs, rhs) + type(MPoint_t), intent(out) :: lhs + class(MPoint_t), intent(in) :: rhs + + lhs%fi_ = rhs%fi_ + lhs%fj_ = rhs%fj_ + end subroutine + + + pure subroutine assignFromInt(lhs, rhs) + type(MPoint_t), intent(out) :: lhs + integer, intent(in) :: rhs + real(RDP) :: rval + + rval = real(rhs, RDP) + lhs = MPoint_t(rval, rval) + end subroutine + + + pure subroutine assignFromReal(lhs, rhs) + type(MPoint_t), intent(out) :: lhs + real(RDP), intent(in) :: rhs + + lhs = MPoint_t(rhs, rhs) +end subroutine + + +end module BsaLib_MPoint \ No newline at end of file diff --git a/src/BsaLib/bsa/meshing/policy/MPolicy.f90 b/src/BsaLib/bsa/meshing/policy/MPolicy.f90 new file mode 100644 index 0000000..f1ea6cf --- /dev/null +++ b/src/BsaLib/bsa/meshing/policy/MPolicy.f90 @@ -0,0 +1,214 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_MPolicy + + implicit none + private + + ! enum, bind(C) + ! enumerator :: MPolicy_NULL = 0 + ! enumerator :: MPolicy_DEF = 1 + ! enumerator :: MPolicy_CONST = 2 + ! enumerator :: MPolicy_PRE_PEAK_1 = 3 + ! enumerator :: MPolicy_PRE_PEAK_2 = 4 + ! enumerator :: MPolicy_PEAK = 5 + ! enumerator :: MPolicy_CREST = 6 + ! enumerator :: MPolicy_BASIN = 7 + ! enumerator :: MPolicy_PAD_ZONE_INTERN = 8 + ! enumerator :: MPolicy_PAD_ZONE_EXTERN = 9 + ! end enum + integer, public, parameter :: MPolicy_NULL = 0 + integer, public, parameter :: MPolicy_DEF = 1 + integer, public, parameter :: MPolicy_CONST = 2 + integer, public, parameter :: MPolicy_PRE_PEAK_1 = 3 + integer, public, parameter :: MPolicy_PRE_PEAK_2 = 4 + integer, public, parameter :: MPolicy_PEAK = 5 + integer, public, parameter :: MPolicy_CREST = 6 + integer, public, parameter :: MPolicy_BASIN = 7 + integer, public, parameter :: MPolicy_PAD_ZONE_INTERN = 8 + integer, public, parameter :: MPolicy_PAD_ZONE_EXTERN = 9 + + + type, public :: MPolicy_t + + integer(kind = 4) :: delta_fI_fct_ = 0 + integer(kind = 4) :: delta_fJ_fct_ = 0 + integer(kind = 4) :: interp_bfm_I_fct_ = 0 + integer(kind = 4) :: interp_bfm_J_fct_ = 0 + integer(kind = 4) :: interp_I_fct_ = 0 + integer(kind = 4) :: interp_J_fct_ = 0 + + integer(kind = 4) :: n_interp_bfm_lvs_ = 0 + + integer(kind = 4), private :: id_pol_ = 0 + + contains + + procedure :: getID + + ! generic :: assignment(=) => MPolicy_fromPol_sub, MPolicy_fromID_sub + ! procedure, private, pass :: MPolicy_fromID_sub, MPolicy_fromPol_sub + ! generic :: operator(==) => MPolicy_isID_order1, MPolicy_isID_order2 + ! procedure, pass(pol), private :: MPolicy_isID_order1, MPolicy_isID_order2 + end type MPolicy_t + + + interface MPolicy_t + module procedure MPolicy_constructor_integer + module procedure MPolicy_fromID + end interface + + + ! NOTE: COMMENT THESE INTERFACES OUT IF USING + ! TYPE-BOUND PROCEDURES. + interface assignment(=) + module procedure MPolicy_fromPol_sub + module procedure MPolicy_fromID_sub + end interface assignment(=) + public :: assignment(=) + + interface operator(==) + module procedure MPolicy_isID_order1 + module procedure MPolicy_isID_order2 + end interface operator(==) + public :: operator(==) + + +contains + + + elemental pure function MPolicy_constructor_integer(& + dfi, dfj, interp_bfm_i, interp_bfm_j, interpi, interpj, nlevs, id) result(pol) + integer, intent(in) :: dfi, dfj, interp_bfm_i, interp_bfm_j, interpi, interpj, nlevs, id + type(MPolicy_t) :: pol + + ! pol = MPolicy_t(& + ! int(dfi, kind = 4), & + ! int(dfj, kind = 4), & + ! int(interp_bfm_i, kind = 4), & + ! int(interp_bfm_j, kind = 4), & + ! int(interpi, kind = 4), & + ! int(interpj, kind = 4), & + ! id) + pol%delta_fI_fct_ = int(dfi, kind = 4) + pol%delta_fJ_fct_ = int(dfj, kind = 4) + pol%interp_bfm_I_fct_ = int(interp_bfm_i, kind = 4) + pol%interp_bfm_J_fct_ = int(interp_bfm_j, kind = 4) + pol%interp_I_fct_ = int(interpi, kind = 4) + pol%interp_J_fct_ = int(interpj, kind = 4) + pol%n_interp_bfm_lvs_ = int(nlevs, kind = 4) + pol%id_pol_ = int(id, kind = 4) + end function + + + + elemental pure function MPolicy_fromID(mpol) result(pol) + integer, intent(in) :: mpol + type(MPolicy_t) :: pol + + select case (mpol) + case (MPolicy_NULL) + pol = MPolicy_t(0, 0, 0, 0, 0, 0, 0, MPolicy_NULL) + + case (MPolicy_DEF) + pol = MPolicy_t(2, 2, 2, 2, 2, 2, 1, MPolicy_DEF) + + case (MPolicy_CONST) + pol = MPolicy_t(1, 1, 1, 1, 1, 1, 1, MPolicy_CONST) + + case (MPolicy_PRE_PEAK_1) + pol = MPolicy_t(1, 4, 4, 4, 4, 2, 1, MPolicy_PRE_PEAK_1) + + case (MPolicy_PRE_PEAK_2) + pol = MPolicy_t(1, 8, 2, 2, 4, 2, 1, MPolicy_PRE_PEAK_2) + + case (MPolicy_PEAK) + pol = MPolicy_t(1, 1, 4, 4, 4, 4, 1, MPolicy_PEAK) + + case (MPolicy_CREST) + pol = MPolicy_t(1, 4, 4, 4, 4, 2, 1, MPolicy_CREST) + + case (MPolicy_BASIN) + pol = MPolicy_t(1, 4, 2, 2, 2, 2, 1, MPolicy_BASIN) + + case (MPolicy_PAD_ZONE_INTERN) + pol = MPolicy_t(4, 4, 1, 1, 2, 2, 1, MPolicy_PAD_ZONE_INTERN) + + case (MPolicy_PAD_ZONE_EXTERN) + pol = MPolicy_t(8, 8, 1, 1, 2, 2, 1, MPolicy_PAD_ZONE_EXTERN) + + case default + pol = MPolicy_t(2, 2, 2, 2, 2, 2, 1, MPolicy_DEF) + end select + end function MPolicy_fromID + + + + elemental pure subroutine MPolicy_fromPol_sub(lhs, rhs_pol) + type(MPolicy_t), intent(out) :: lhs + class(MPolicy_t), intent(in) :: rhs_pol + + lhs%delta_fI_fct_ = rhs_pol%delta_fI_fct_ + lhs%delta_fJ_fct_ = rhs_pol%delta_fJ_fct_ + lhs%interp_bfm_I_fct_ = rhs_pol%interp_bfm_I_fct_ + lhs%interp_bfm_J_fct_ = rhs_pol%interp_bfm_J_fct_ + lhs%interp_I_fct_ = rhs_pol%interp_I_fct_ + lhs%interp_J_fct_ = rhs_pol%interp_J_fct_ + lhs%n_interp_bfm_lvs_ = rhs_pol%n_interp_bfm_lvs_ + lhs%id_pol_ = rhs_pol%id_pol_ + end subroutine MPolicy_fromPol_sub + + + + elemental pure subroutine MPolicy_fromID_sub(lhs, rhs_id) + type(MPolicy_t), intent(out) :: lhs + integer, intent(in) :: rhs_id + + lhs = MPolicy_t(rhs_id) + end subroutine MPolicy_fromID_sub + + + + elemental pure function getID(this) result(id) + class(MPolicy_t), intent(in) :: this + integer(kind = 4) :: id + + id = this%id_pol_ + end function getID + + + + + + elemental pure function MPolicy_isID_order1(pol, id) result(isID) + class(MPolicy_t), intent(in) :: pol + integer, intent(in) :: id + logical :: isID + + isID = pol%id_pol_ == id + end function MPolicy_isID_order1 + + + elemental pure function MPolicy_isID_order2(id, pol) result(isID) + integer, intent(in) :: id + class(MPolicy_t), intent(in) :: pol + logical :: isID + + isID = pol%id_pol_ == id + end function MPolicy_isID_order2 + + +end module \ No newline at end of file diff --git a/src/BsaLib/bsa/meshing/zones/M2DPolygZone.f90 b/src/BsaLib/bsa/meshing/zones/M2DPolygZone.f90 new file mode 100644 index 0000000..3b259ea --- /dev/null +++ b/src/BsaLib/bsa/meshing/zones/M2DPolygZone.f90 @@ -0,0 +1,165 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_M2DPolygZone + +#include "../../../precisions" + + use BsaLib_MPoint + use BsaLib_MZone + implicit none + public + + type, public, abstract, extends(MZone_t) :: M2DPolygZone_t + + !> Refinement (n meshing pts) along I-dir + integer(kind = 4) :: ni_ = 0 + + !> Refinement (n meshing pts) along J-dir + integer(kind = 4) :: nj_ = 0 + + !> Rotation angle w.r.t to XY plane axes + !> CLOCKWISE + real(RDP) :: rot_ = 0._RDP + + contains + + ! By default rect case. Others -> specialise + procedure, pass :: zoneTotNPts => zoneTotNPts_pol2D_ + + procedure, pass :: refinements + procedure, pass :: setRotation + procedure, pass :: isGRSAligned + procedure, pass :: setRefinements + + procedure(VoidSub), pass, deferred :: deduceDeltas + procedure(RealVoidFct), pass, deferred :: baseI + procedure(RealVoidFct), pass, deferred :: baseJ + end type + + + + abstract interface + elemental function RealVoidFct(this) result(res) + import M2DPolygZone_t, RDP + class(M2DPolygZone_t), intent(in) :: this + real(RDP) :: res + end function + + subroutine VoidSub(this) + import M2DPolygZone_t + class(M2DPolygZone_t), intent(inout) :: this + end subroutine + end interface + + + + +contains + + + !> Gets total number of zone's meshing points + pure function zoneTotNPts_pol2D_(this) result(np) + class(M2DPolygZone_t), intent(in) :: this + integer :: np + + np = this%ni_ * this%nj_ + end function + + + + !> Get this zone's refinements + pure function refinements(this) result(refmts) + class(M2DPolygZone_t), intent(in) :: this + integer :: refmts(2) + + refmts(1) = this%ni_ + refmts(2) = this%nj_ + end function + + + + subroutine setRotation(this, rot, deg) + class(M2DPolygZone_t), intent(inout) :: this + real(RDP), value :: rot +!DIR$ ATTRIBUTES VALUE :: rot + logical, intent(in), optional :: deg + logical :: is_deg = .false. + integer :: n2pirot = 0 + + if (present(deg) .and. deg) is_deg = .true. + + if (is_deg) rot = rot / 180 * CST_PIGREC + + ! we want rot € [0, 2*pi) + ! 2*pi -> 0. (this why ==) + if (rot >= CST_PIt2) then + n2pirot = floor(rot / CST_PIt2) + rot = rot - n2pirot * CST_PIt2 + endif + + this%rot_ = rot + end subroutine + + + + + + !> Verifies if zone is not diagonal w.r.t. + !> to the orientation of the GRS (Global Reference System) + !> BUG: might need usage of rounding precision. + elemental function isGRSAligned(this) result(bool) + class(M2DPolygZone_t), intent(in) :: this + logical :: bool + + bool = .false. + + if (this%rot_ == 0._RDP .or. & + this%rot_ == CST_PId2 .or. & + this%rot_ == CST_PIGREC .or. & + this%rot_ == CST_PIt3d2) bool = .true. + end function + + + + + !> Sets zone refinements. + subroutine setRefinements(this, ni, nj, force) + class(M2DPolygZone_t), intent(inout) :: this + integer, intent(in) :: ni, nj + logical, intent(in), optional :: force + logical :: do_force = .false. + + if (present(force) .and. force) do_force = .true. + + if (do_force) then ! usually, when reconstructing + + this%ni_ = ni + this%nj_ = nj + + else ! check for oddness. + + this%ni_ = ni + if (mod(ni, 2) == 0) this%ni_ = this%ni_ + 1 + + this%nj_ = nj + if (mod(nj, 2) == 0) this%nj_ = this%nj_ + 1 + + endif + call this%deduceDeltas() + end subroutine + + +end module BsaLib_M2DPolygZone \ No newline at end of file diff --git a/src/BsaLib/bsa/meshing/zones/MRectZone.f90 b/src/BsaLib/bsa/meshing/zones/MRectZone.f90 new file mode 100644 index 0000000..e583de2 --- /dev/null +++ b/src/BsaLib/bsa/meshing/zones/MRectZone.f90 @@ -0,0 +1,368 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_MRectZone + +#include "../../../precisions" + + use BsaLib_MPoint + use BsaLib_M2DPolygZone + implicit none + private + + ! imported from <- BsaLib_M2DPolygZone <- BsaLib_MZone + public :: msh_max_zone_NPts, MZone_ID + + ! Make it visible without needing to import Base class module + public :: UndumpZone + + type, public, extends(M2DPolygZone_t) :: MRectZone_t + + !> Init point (from where everything else is made reference) + type(MPoint_t) :: Ipt_ + + !> End point + type(MPoint_t) :: Ept_ + + !> Rect base along I-dir (x axis) + real(RDP) :: base_I_ = 0._RDP + + !> Rect base along J-dir (y axis) + real(RDP) :: base_J_ = 0._RDP + + !> Delta freq [Hz] along I-dir (x axis) + real(RDP) :: deltaf_I_ = 0._RDP + + !> Delta freq [Hz] along J-dir (y axis) + real(RDP) :: deltaf_J_ = 0._RDP + + + logical, private :: refmts_set_ = .false. + logical, private :: deltas_set_ = .false. + + contains + + procedure, pass :: baseI => baseI_rct + procedure, pass :: baseJ => baseJ_rct + procedure, pass :: deduceDeltas => deduceDeltas_rect + + procedure, pass :: getAPoint + procedure, pass :: getBPoint + procedure, pass :: setDeltas + procedure, pass :: deduceRefinements + generic, public :: defineFromDeltas => defineFromDeltas_refinements, defineFromDeltas_maxvalues + procedure, pass, private :: defineFromDeltas_refinements, defineFromDeltas_maxvalues + generic :: defineFromEndPtCoordAndBase => defineFromEndPtCoordAndBase_norm, defineFromEndPtCoordAndBase_forceDeltas + procedure, pass, private :: defineFromEndPtCoordAndBase_norm, defineFromEndPtCoordAndBase_forceDeltas + procedure, pass :: define + procedure, pass, private :: setIEpts + procedure, pass :: validateDeltas + procedure, pass :: getOtherBase + procedure, pass :: getIJfsteps + procedure, pass :: reconstructZoneBaseMesh + procedure, pass :: compute => compute_s + procedure, pass, private :: compute_s + procedure, pass :: getNthQuadVtx + procedure, pass :: dump => dumpRZ + procedure, pass :: undump => undumpRZ + procedure, pass :: interpolate => interpolateRZ + end type MRectZone_t + + + + interface MRectZone + module procedure MRectZone_t_custom_constructor + end interface + public :: MRectZone + + + + ! main interface to module procedures + interface + + module function MRectZone_t_custom_constructor(rot, name) result(this) + real(RDP), intent(in), optional :: rot + character(len=*), intent(in), optional :: name + ! NOTE: compiler uses default initialisation here (built-in) + type(MRectZone_t) :: this + end function + + + !> Gets rect base along I-dir + module elemental function baseI_rct(this) result(res) + class(MRectZone_t), intent(in) :: this + real(RDP) :: res + end function + + + !> Gets rect base along J-dir + module elemental function baseJ_rct(this) result(res) + class(MRectZone_t), intent(in) :: this + real(RDP) :: res + end function + + + + !> Get A point. + !> A point is the point defined, starting from I point, + !> along the J-dir (Y-axis) parallel side. + module pure function getAPoint(this) result(pt) + class(MRectZone_t), intent(in) :: this + type(MPoint_t) :: pt + end function + + + !> Get B point. + !> B point is the point defined, starting from I point, + !> along the I-dir (X-axis) parallel side. + module pure function getBPoint(this) result(pt) + class(MRectZone_t), intent(in) :: this + type(MPoint_t) :: pt + end function + + + !> If refinements are set, deltas are deduced + module subroutine deduceDeltas_rect(this) + class(MRectZone_t), intent(inout) :: this + end subroutine + + + !> Set frequency deltas + module subroutine setDeltas(this, dfi, dfj, adapt) + class(MRectZone_t), intent(inout) :: this + real(RDP), intent(in) :: dfi, dfj + logical, intent(in), optional :: adapt + end subroutine + + + !> If deltas are set, deduces refinements + module subroutine deduceRefinements(this, adapt) + class(MRectZone_t), intent(inout) :: this + logical, intent(in) :: adapt + end subroutine + + + + !> Defines zone bases (sides) from given Deltas, specifying refinement. + !> NOTE: Init and End zone points MUST be known. + module subroutine defineFromDeltas_refinements(this, pt, loc, dfi, dfj, ni, nj) + class(MRectZone_t), intent(inout) :: this + + !> Point specification at location 'loc' + class(MPoint_t), intent(in) :: pt + + !> Location of the specified point. + !> Can be: + !> 'i' -> init point + !> 'c' -> centre point + !> 'e' -> end point + character(len=1) :: loc + + !> Delta values + real(RDP), intent(in) :: dfi, dfj + + !> Refinements + integer, value :: ni, nj +!DIR$ ATTRIBUTES VALUE :: ni, nj + end subroutine + + + + + + !> Defines zone bases (sides) from given Deltas, specifying max deltas values. + !> NOTE: Init and End zone points MUST be known. + !> If force is present and true, forces deltas to reach max values specified + !> by 'valI' and 'valJ'. In this case, deltas are then slightly adjusted to fit. + module subroutine defineFromDeltas_maxvalues(this, pt, loc, dfi, dfj, maxF_i, maxF_j, force, exceed) + class(MRectZone_t), intent(inout) :: this + + !> Point specification, which location is specified by 'loc' + class(MPoint_t), intent(in) :: pt + + !> Point location: + !> 'i' -> Init location + !> 'c' -> centre (NOT YET IMPLEMENTED) + !> 'e' -> end (NOT YET IMPLEMENTED) + character(len=1), intent(in) :: loc + + !> Delta values + real(RDP), value :: dfi, dfj +!DIR$ ATTRIBUTES VALUE :: dfi, dfj + + !> Max deltas values + real(RDP) :: maxF_i, maxF_j + + !> adjusts deltas to max values specified. + logical, intent(in), optional :: force + + + logical, intent(in), optional :: exceed + end subroutine + + + + + + module subroutine define(this, pt, loc, base_i, base_j) + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: pt + character(len=1), optional, intent(in) :: loc + real(RDP), intent(in), optional :: base_i, base_j + end subroutine + + + + + + + module subroutine defineFromEndPtCoordAndBase_norm(& + this, Pi, coord_val, coord_ty_ch, baseval, base_dir, called) + + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: Pi + real(RDP), intent(in) :: coord_val + character(len = 1), intent(in) :: coord_ty_ch + real(RDP), intent(in) :: baseval + character(len = 1), intent(in) :: base_dir + logical, intent(in) :: called + end subroutine + + + + module subroutine defineFromEndPtCoordAndBase_forceDeltas(& + this, Pi, coord_val, coord_ty_ch, baseval, base_dir, dfi, dfj) + + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: Pi + real(RDP), intent(in) :: coord_val + character(len = 1), intent(in) :: coord_ty_ch + real(RDP), intent(in) :: baseval + character(len = 1), intent(in) :: base_dir + real(RDP), intent(in) :: dfi, dfj + end subroutine + + + + + + + + !> Sets, based on passed point location + !> Init and End zone points. + module subroutine setIEpts(this, pt, loc) + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: pt + character(len=1), intent(in) :: loc + end subroutine + + + + !> Avoid setting a delta smaller than given limit + module elemental impure subroutine validateDeltas(this, lval) + class(MRectZone_t), intent(inout) :: this + real(RDP), intent(in) :: lval + end subroutine + + + !> Automatically computes the second remaining (unknown) rect base + !> based on the point's coordinates and the base that we already defined. + !> BUG: cannot see when a base is negative (i.e. when END pt is "behind" INIT one). + module subroutine getOtherBase(this, pt, base_dir, known_coord, coord_val) + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: pt + character(len=1), intent(in) :: base_dir, known_coord + real(RDP), intent(in) :: coord_val + end subroutine + + + + !> Gets actualised frequency deltas along two main + !> sides directions (I, J), actualised based on *this + !> zone rotation w.r.t. GRS. + module subroutine getIJfsteps(this, dfIx, dfIy, dfJx, dfJy) + class(MRectZone_t), intent(in) :: this + real(RDP), intent(out) :: dfIx, dfIy, dfJx, dfJy + end subroutine + + + + !> Returns the whole zone reconstructed mesh + !> Maybe used for visualising. + module function reconstructZoneBaseMesh(this) result(msh) + class(MRectZone_t), intent(in) :: this + !> BUG: might be 2-rank array instead of 3! + real(RDP) :: msh(2, this%nj_, this%ni_) + end function + + + !> Actual zone comutation (pre phase). + module subroutine compute_s(this) + class(MRectZone_t), intent(inout) :: this + end subroutine + + + + !> Gets vertex point pt coordinates in Nth quadrant + !> w.r.t. Center point, in zone's LRS. + module pure function getNthQuadVtx(this, iquad) result(pt) + class(MRectZone_t), intent(in) :: this + integer, intent(in) :: iquad + type(MPoint_t) :: pt + end function + + + + + + !> Dumps a RECTANGULAR zone. + !> + !> NOTE: Each specific zone dumping method is called + !> from the STATIC MZone_t procedure DumpZone(). + module subroutine dumpRZ(this) + class(MRectZone_t), intent(in) :: this + end subroutine + + + + !> Undumps a RECTANGULAR zone. + !> + !> NOTE: Each specific zone dumping method is called + !> from the STATIC MZone_t procedure UndumpZone(). + !> NOTE: This is the equivalent as reconstruct() of MATLAB. + module subroutine undumpRZ(this) + class(MRectZone_t), intent(inout) :: this + end subroutine + + + + !> Implementation of rect zone interpolation methods + module subroutine interpolateRZ( this & +#ifdef __BSA_OMP + , bfm, pdata & +#endif + & ) + class(MRectZone_t), intent(inout) :: this +#ifdef __BSA_OMP + real(RDP), intent(in) :: bfm(:, :) + class(*), pointer, intent(in) :: pdata +#endif + end subroutine + + + end interface + + +end module BsaLib_MRectZone \ No newline at end of file diff --git a/src/BsaLib/bsa/meshing/zones/MRectZoneImpl.f90 b/src/BsaLib/bsa/meshing/zones/MRectZoneImpl.f90 new file mode 100644 index 0000000..23027e5 --- /dev/null +++ b/src/BsaLib/bsa/meshing/zones/MRectZoneImpl.f90 @@ -0,0 +1,2879 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib_MRectZone) BsaLib_MRectZoneImpl + +#include "../../../precisions" + +! #ifndef BSA_M3MF_ONLY_PREMESH_ +! # define BSA_M3MF_ONLY_PREMESH_ 0 +! #else +! # if (BSA_M3MF_ONLY_PREMESH_ != 0 && BSA_M3MF_ONLY_PREMESH_ != 1) +! # undef BSA_M3MF_ONLY_PREMESH_ +! # define BSA_M3MF_ONLY_PREMESH_ 0 +! # endif +! #endif + + use BsaLib_CONSTANTS + use BsaLib_Data, only: bsa_Abort + use BsaLib_IO, only: INFOMSG, WARNMSG, ERRMSG, MSGCONT, DBGMSG, NOTEMSG + implicit none + + +contains + + + module function MRectZone_t_custom_constructor(rot, name) result(this) + real(RDP), intent(in), optional :: rot + character(len=*), intent(in), optional :: name + ! NOTE: compiler uses default initialisation here (built-in) + type(MRectZone_t) :: this + + ! From Base type + call DefaultInitBaseZone(this) + + if (present(rot)) this%rot_ = rot + + ! NOTE: here no need to call setName() method. + if (present(name)) call this%zoneName(name) + end function + + + + + !> Gets rect base along I-dir + module elemental function baseI_rct(this) result(res) + class(MRectZone_t), intent(in) :: this + real(RDP) :: res + + res = this%base_I_ + end function + + + !> Gets rect base along J-dir + module elemental function baseJ_rct(this) result(res) + class(MRectZone_t), intent(in) :: this + real(RDP) :: res + + res = this%base_J_ + end function + + + + + + + !> Get A point. + !> A point is the point defined, starting from I point, + !> along the J-dir (Y-axis) parallel side. + module pure function getAPoint(this) result(pt) + class(MRectZone_t), intent(in) :: this + type(MPoint_t) :: pt + + pt = this%Ipt_%getNewPointFromDistAndRot(this%base_J_, this%rot_) + end function + + + + !> Get B point. + !> B point is the point defined, starting from I point, + !> along the I-dir (X-axis) parallel side. + module pure function getBPoint(this) result(pt) + class(MRectZone_t), intent(in) :: this + type(MPoint_t) :: pt + real(RDP) :: ang + + ! in 4-th quadrant, decrement by 3/2*pi -> first quadrant + if (this%rot_ > CST_PIt3d2) then + + ang = this%rot_ - CST_PIt3d2 + + else ! otherwise, increment by 1/2*pi + + ang = this%rot_ + CST_PId2 + endif + pt = this%Ipt_%getNewPointFromDistAndRot(this%base_I_, ang) + end function + + + + module subroutine deduceDeltas_rect(this) + class(MRectZone_t), intent(inout) :: this + integer :: nsegi, nsegj + + ! + this%refmts_set_ = .true. + + ! n. of segments along I-dir + nsegi = this%ni_ - 1 + + ! n. of segments along J-dir + nsegj = this%nj_ - 1 + + this%deltaf_I_ = this%base_I_ / nsegi + this%deltaf_J_ = this%base_J_ / nsegj + end subroutine + + + + + + + module subroutine setDeltas(this, dfi, dfj, adapt) + class(MRectZone_t), intent(inout) :: this + real(RDP), intent(in) :: dfi, dfj + logical, intent(in), optional :: adapt + logical :: do_adapt = .false. + + if (present(adapt) .and. adapt) do_adapt = .true. + + this%deltaf_I_ = dfi + this%deltaf_J_ = dfj + this%deltas_set_ = .true. + call this%deduceRefinements(do_adapt) + end subroutine + + + + module subroutine deduceRefinements(this, adapt) + class(MRectZone_t), intent(inout) :: this + logical, intent(in) :: adapt + integer :: ni, nj + + ! NOTE: as such, they mean N. OF SEGMENTS + ni = floor(this%base_I_ / this%deltaf_I_) + nj = floor(this%base_J_ / this%deltaf_J_) + + ! NOTE: we want even N. of segments -> odd N. of points + if (.not. mod(ni, 2) == 0) ni = ni + 1 + if (.not. mod(nj, 2) == 0) nj = nj + 1 + + + ! BUG: if we imposed deltas greater than bases -> at least 1 segment! + if (ni == 0) ni = 1 + if (nj == 0) nj = 1 + + + if (adapt) then ! we readapt deltas, to fit in base + + this%deltaf_I_ = this%base_I_ / ni + this%deltaf_J_ = this%base_J_ / nj + + else ! recompute bases, such to preserve desired deltas. + + this%base_I_ = this%deltaf_I_ * ni + this%base_J_ = this%deltaf_J_ * nj + endif + + ! Now, get actual number of points along sides (odd) + this%ni_ = ni + 1 + this%nj_ = nj + 1 + end subroutine + + + + + + + + !> Defines zone bases (sides) from given Deltas, specifying refinement. + !> NOTE: Init and End zone points MUST be known. + module subroutine defineFromDeltas_refinements(this, pt, loc, dfi, dfj, ni, nj) + class(MRectZone_t), intent(inout) :: this + + !> Point specification at location 'loc' + class(MPoint_t), intent(in) :: pt + + !> Location of the specified point. + !> Can be: + !> 'i' -> init point + !> 'c' -> centre point + !> 'e' -> end point + character(len=1) :: loc + + !> Delta values + real(RDP), intent(in) :: dfi, dfj + + !> Refinements + integer, value :: ni, nj +!DIR$ ATTRIBUTES VALUE :: ni, nj + + + if (.not. this%isGRSAligned()) call bsa_Abort('Rect zone is not GRS aligned.') + + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MRectZoneImpl::defineFromDeltas_refinements() : init...' +! #endif + + + ! force them odd + if (mod(ni, 2) == 0) ni = ni + 1 + if (mod(nj, 2) == 0) nj = nj + 1 + + this%ni_ = ni + this%nj_ = nj + + ! here we refer to number of segments (even) + ni = ni - 1 + nj = nj - 1 + + ! deduce bases + this%base_I_ = ni * dfi + this%base_J_ = nj * dfj + + + this%refmts_set_ = .true. + this%deltaf_I_ = dfi + this%deltaf_J_ = dfj + + + ! NOTE: loc(x) returns the integer address of variable x !! + ! + call this%define(pt, loc=loc) + + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MRectZoneImpl::defineFromDeltas_refinements() : init -- ok.' +! #endif + end subroutine + + + + + + + !> Defines zone bases (sides) from given Deltas, specifying max deltas values. + !> NOTE: Init and End zone points MUST be known. + !> If force is present and true, forces deltas to reach max values specified + !> by 'valI' and 'valJ'. In this case, deltas are then slightly adjusted to fit. + module subroutine defineFromDeltas_maxvalues(this, pt, loc, dfi, dfj, maxF_i, maxF_j, force, exceed) + class(MRectZone_t), intent(inout) :: this + + !> Point specification, which location is specified by 'loc' + class(MPoint_t), intent(in) :: pt + + !> Point location: + !> 'i' -> Init location + !> 'c' -> centre (NOT YET IMPLEMENTED) + !> 'e' -> end (NOT YET IMPLEMENTED) + character(len=1), intent(in) :: loc + + !> Delta values + real(RDP), value :: dfi, dfj +!DIR$ ATTRIBUTES VALUE :: dfi, dfj + + !> Max deltas values + real(RDP) :: maxF_i, maxF_j + + !> adjusts deltas to max values specified. + logical, intent(in), optional :: force + + + logical, intent(in), optional :: exceed + + + if (.not. this%isGRSAligned()) & + call bsa_Abort('Zone is not aligned with GRS.') + + if (.not. loc == 'i') & + call bsa_Abort(& + 'Cannot define deltas from max values if given point location is not "i" (Init).') + + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MRectZoneImpl::defineFromDeltas_maxvalues() : init...' +! #endif + + + block + ! local + character(len = *), parameter :: invalid_max_vals = & + ERRMSG//'Invalid max values (out of allowed bounds).' + logical :: do_force + real(RDP) :: fi, fj, bi, bj + integer :: ni, nj + + + if (present(force) .and. force) then + do_force = .true. + else + do_force = .false. + endif + + ! initialise + bi = 0._RDP + bj = 0._RDP + fi = 0._RDP + fj = 0._RDP + ni = 0 + nj = 0 + + if (do_force) then + + fi = pt%freqI() + fj = pt%freqJ() + + if (this%rot_ == 0._RDP) then + if (maxF_i <= fi .or. maxF_j <= fj) call bsa_Abort(invalid_max_vals) + + bi = maxF_i - fi + bj = maxF_j - fj + + elseif (this%rot_ == CST_PId2) then ! 1/2 * pi + if (maxF_i <= fi .or. maxF_j >= fj) call bsa_Abort(invalid_max_vals) + + bj = maxF_i - fi + bi = fj - maxF_j + + elseif (this%rot_ == CST_PIGREC) then + if (maxF_i >= fi .or. maxF_j >= fj) call bsa_Abort(invalid_max_vals) + + bi = fi - maxF_i + bj = fj - maxF_j + + elseif (this%rot_ == CST_PIt3d2) then ! 3/2 * pi + if (maxF_i >= fi .or. maxF_j <= fj) call bsa_Abort(invalid_max_vals) + + bj = fi - maxF_i + bi = maxF_j - fj + + end if + + + ! invert deltas if needed + if (.not. (this%rot_ == 0 .or. this%rot_ == CST_PIGREC)) then + block + real(RDP) :: tmp + + tmp = dfi + dfi = dfj + dfj = tmp + end block + endif + + ! get approx n. of segments + ni = ceiling(bi / dfi) + nj = ceiling(bj / dfj) + + ! get refactored deltas + dfi = bi / ni + dfj = bj / nj + + ! actual n. of points (odd) + ni = ni + 1 + nj = nj + 1 + + + + else ! DO NOT force (keep those deltas) + + + block + real(RDP) :: di, dj + logical :: do_exceed = .false. + + + ! defaults + if (present(exceed) .and. exceed) do_exceed= .true. + di = dfi + dj = dfj + ni = 1 + nj = 1 + + + if (this%rot_ == 0._RDP) then + + fi = pt%freqI() + di + fj = pt%freqJ() + dj + + if (maxF_i < fi .or. maxF_j < fj) call bsa_Abort(invalid_max_vals) + + do while (fi <= maxF_i) + ni = ni + 1 + fi = fi + di + enddo + do while (fj <= maxF_j) + nj = nj + 1 + fj = fj + dj + enddo + + + elseif (this%rot_ == CST_PId2) then ! 1/2 * pi + fi = pt%freqI() + dj + fj = pt%freqJ() - di + + if (maxF_i < fi .or. maxF_j > fj) call bsa_Abort(invalid_max_vals) + + do while (fi <= maxF_i) + nj = nj + 1 + fi = fi + dj + enddo + do while (fj >= maxF_j) + ni = ni + 1 + fj = fj - di + enddo + + + elseif (this%rot_ == CST_PIGREC) then + di = - di + dj = - dj + fi = pt%freqI() + di + fj = pt%freqJ() + dj + + if (maxF_i > fi .or. maxF_j > fj) call bsa_Abort(invalid_max_vals) + + do while (fi >= maxF_i) + ni = ni + 1 + fi = fi + di + enddo + do while (fj >= maxF_j) + nj = nj + 1 + fj = fj + dj + enddo + + di = abs(di) + dj = abs(dj) + + + ! TODO: check this + elseif (this%rot_ == CST_PIt3d2) then ! 3/2 * pi + fi = pt%freqI() - dj + fj = pt%freqJ() + di + + if (maxF_i > fi .or. maxF_j < fj) call bsa_Abort(invalid_max_vals) + + do while (fi >= maxF_i) + nj = nj + 1 + fi = fi + dj + enddo + do while (fj <= maxF_j) + ni = ni + 1 + fj = fj - di + enddo + + end if ! rot + + + if (ni == 1 .or. nj == 1) call bsa_Abort('At least one max value is too small.') + + + if (this%rot_ == 0._RDP) then + bi = (ni - 1) * di + bj = (nj - 1) * dj + + if (do_exceed) then + if (pt%freqI() + bi < maxF_i) then + bi = ni + di + ni = ni + 1 + endif + if (pt%freqJ() + bj < maxF_j) then + bj = nj * dj + nj = nj + 1 + endif + endif + + + elseif (this%rot_ == CST_PId2) then + bi = (ni - 1) * dj + bj = (nj - 1) * di + + if (do_exceed) then + if (pt%freqI() + bj < maxF_i) then + bj = nj * di + nj = nj + 1 + endif + if (pt%freqJ() - bi > maxF_j) then + bi = ni * dj + ni = ni + 1 + endif + endif + + + elseif (this%rot_ == CST_PIGREC) then + bi = (ni - 1) * di + bj = (nj - 1) * dj + + if (do_exceed) then + if (pt%freqI() - bi > maxF_i) then + bi = ni * di + ni = ni + 1 + endif + if (pt%freqJ() - bj > maxF_j) then + bj = nj * dj + nj = nj + 1 + endif + endif + + + elseif (this%rot_ == CST_PIt3d2) then + bi = (ni - 1) * dj + bj = (nj - 1) * di + + if (do_exceed) then + if (pt%freqI() - bj > maxF_i) then + bj = nj * di + nj = nj + 1 + endif + if (pt%freqJ() + bi < maxF_j) then + bi = ni * dj + ni = ni + 1 + endif + endif + + end if ! rot + + end block + + + endif ! force + + + ! backup actual n. of points + this%ni_ = ni + this%nj_ = nj + + + ! BUG: this is a code copy + this%refmts_set_ = .true. + this%deltaf_I_ = dfi + this%deltaf_J_ = dfj + + + call this%define(pt, loc, bi, bj) + + end block + + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MRectZoneImpl::defineFromDeltas_maxvalues() : init -- ok.' +! #endif + end subroutine + + + + + + + module subroutine defineFromEndPtCoordAndBase_norm(& + this, Pi, coord_val, coord_ty_ch, baseval, base_dir, called) + + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: Pi + real(RDP), intent(in) :: coord_val + character(len = 1), intent(in) :: coord_ty_ch + real(RDP), intent(in) :: baseval + character(len = 1), intent(in) :: base_dir + logical, intent(in) :: called + + real(RDP) :: ang + type(MPoint_t) :: pt + + if (.not. (coord_ty_ch == 'i' .or. coord_ty_ch == 'j')) & + call bsa_Abort('Unvalid coordinate type identifier. Must be one of "i"/"j".') + + if (.not. (base_dir == 'i' .or. base_dir == 'j')) & + call bsa_Abort('Unvalid base direction identifier. Must be one of "i"/"j".') + + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MRectZoneImpl::defineFromEndPtCoordAndBase_norm() : init...' +! #endif + + ! backup init point + this%Ipt_ = MPoint(Pi) + + + ! get A or B point + if (base_dir == 'i') then ! B point + + this%base_I_ = baseval + + ! if 4th quadrant, go back to 1st one + if (this%rot_ >= CST_PIt3d2) then + ang = this%rot_ - CST_PIt3d2 + else + ang = this%rot_ + CST_PId2 + endif + + else ! A pt + + this%base_J_ = baseval + ang = this%rot_ + endif + + + ! NOTE: here pt is either A or B, depending on base passed + pt = this%Ipt_%getNewPointFromDistAndRot(baseval, ang) + + ! deduce missing end point coordinate + ! From it, compute missing rect base for complete definition + call this%getOtherBase(pt, base_dir, coord_ty_ch, coord_val) + + if (called) return + + ! once we have both bases, redefine deltas + ! NOTE: this assumes refinements have been already set + call this%deduceDeltas() + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MRectZoneImpl::defineFromEndPtCoordAndBase_norm() : init -- ok.' +! #endif + end subroutine defineFromEndPtCoordAndBase_norm + + + + + module subroutine defineFromEndPtCoordAndBase_forceDeltas(& + this, Pi, coord_val, coord_ty_ch, baseval, base_dir, dfi, dfj) + + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: Pi + real(RDP), intent(in) :: coord_val + character(len = 1), intent(in) :: coord_ty_ch + real(RDP), intent(in) :: baseval + character(len = 1), intent(in) :: base_dir + real(RDP), intent(in) :: dfi, dfj + + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MRectZoneImpl::defineFromEndPtCoordAndBase_forceDeltas() : init...' +! #endif + + call this%defineFromEndPtCoordAndBase_norm(& + Pi, coord_val, coord_ty_ch, baseval, base_dir, .true.) + + ! forcing deltas + call this%setDeltas(dfi, dfj, .true.) + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MRectZoneImpl::defineFromEndPtCoordAndBase_forceDeltas() : init -- ok.' +! #endif + end subroutine defineFromEndPtCoordAndBase_forceDeltas + + + + + + + + + + + module subroutine define(this, pt, loc, base_i, base_j) + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: pt + character(len=1), optional, intent(in) :: loc + real(RDP), intent(in), optional :: base_i, base_j + + character(len=1) :: location = 'i' + + if (present(loc)) location = loc + + if (location == 'c') then + + block + real(RDP) :: bid2, bjd2 + + if (present(base_i)) then + this%base_I_ = base_i + bid2 = base_i / 2 + else + bid2 = this%base_I_ / 2 + endif + + if (present(base_j)) then + this%base_J_ = base_j + bjd2 = base_j / 2 + else + bjd2 = this%base_J_ / 2 + endif + + this%Ipt_ = MPoint(pt%freqI() - bid2, pt%freqJ() - bjd2) + this%Ept_ = MPoint(pt%freqI() + bid2, pt%freqJ() + bjd2) + end block + + else ! loc == 'i' or 'e' + + ! NOTE: don't forget to update bases if passed! + if (present(base_i)) this%base_I_ = base_i + if (present(base_j)) this%base_J_ = base_j + + call this%setIEpts(pt, loc) + endif + end subroutine define + + + + + + + module subroutine setIEpts(this, pt, loc) + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: pt + character(len=1), intent(in) :: loc + + real(RDP) :: c, s, ang, di, dj + + if (.not. (loc == 'i' .or. loc == 'e')) & + call bsa_Abort('Invalid point location.') + + + if (this%rot_ < CST_PId2) then ! FIRST quadrant + + c = cos(this%rot_) + s = sin(this%rot_) + + di = this%base_I_ * c + this%base_J_ * s + dj = this%base_J_ * c - this%base_I_ * s + + elseif (this%rot_ < CST_PIGREC) then ! SECOND quadrant + + ang = this%rot_ - CST_PId2 + c = cos(ang) + s = sin(ang) + + di = this%base_J_ * c - this%base_I_ * s + dj = - (this%base_J_ * s + this%base_I_ * c) + + elseif (this%rot_ < CST_PIt3d2) then ! THIRD quadrant + + ang = this%rot_ - CST_PIGREC + c = cos(ang) + s = sin(ang) + + di = - (this%base_J_ * s + this%base_I_ * c) + dj = - this%base_J_ * c + this%base_I_ * s + + + elseif (this%rot_ < CST_PIt2) then ! FOURTH quadrant + + ang = this%rot_ - CST_PIt3d2 + c = cos(ang) + s = sin(ang) + + di = - this%base_J_ * c + this%base_I_ * s + dj = this%base_J_ * s + this%base_I_ * c + endif + + + + select case (loc) + + case ('i') + this%Ipt_ = MPoint(pt) + + this%Ept_ = MPoint(pt%freqI() + di, pt%freqJ() + dj) + + case ('e') + this%Ept_ = MPoint(pt) + + this%Ipt_ = MPoint(pt%freqI() - di, pt%freqJ() - dj) + end select + end subroutine + + + + + + !> Avoid setting a delta smaller than given limit + module elemental impure subroutine validateDeltas(this, lval) + class(MRectZone_t), intent(inout) :: this + real(RDP), intent(in) :: lval + + real(RDP) :: dfi, dfj + logical :: coarsen = .false. + + dfi = this%deltaf_I_ + dfj = this%deltaf_J_ + if (dfi < lval .or. dfi > lval) then + dfi = lval + coarsen = .true. + endif + if (dfj < lval .or. dfj > lval) then + dfj = lval + coarsen = .true. + endif + if (coarsen) then + print '( 1x, 2a, g10.5, " [Hz])." )', & + WARNMSG, 'Detected at least one zone deltas too small/big. Setting to optimal value (', & + lval + call this%setDeltas(dfi, dfj, .true.) + endif + end subroutine + + + + + ! !> Returns euqivalent rotation in the FIRST quadrant. + ! elemental function getFirstQuadEquivRot(rot) result(rot1) + ! real(RDP), intent(in) :: rot + ! real(RDP) :: rot1 + + ! if (rot < CST_PId2) then ! FIRST quad, keep it + ! rot1 = rot + ! elseif (rot < CST_PIGREC) then ! SECOND quad + ! rot1 = rot - CST_PId2 + ! elseif (rot < CST_3d2) then ! THIRD quad + ! rot1 = rot - CST_PIGREC + ! elseif (rot < CST_PIt2) then ! FOURTH quad + ! rot1 = rot - CST_3d2 + ! endif + ! end function + + + + + + !> Automatically computes the second remaining (unknown) rect base + !> based on the point's coordinates and the base that we already defined. + !> BUG: cannot see when a base is negative (i.e. when END pt is "behind" INIT one). + module subroutine getOtherBase(this, pt, base_dir, known_coord, coord_val) + class(MRectZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: pt + character(len=1), intent(in) :: base_dir, known_coord + real(RDP), intent(in) :: coord_val + + real(RDP) :: kd, rot, cd, fi, fj + type(MPoint_t) :: Pe + + + ! NOTE: preinitialise to avoid errors !!!!!!!!!!!! + cd = 0._RDP + + + if (base_dir == 'i') then ! we passed B point, we know side along I-dir + + if (known_coord == 'i') then ! we search DJ + + ! BUG: not always 0 when it should be + kd = abs(coord_val - pt%freqI()) + + ! BUG: forcing it to zero if below some precision + if (kd < MACHINE_PRECISION) then + +#ifdef __BSA_DEBUG + write(unit_debug_, '(a, a)') & + WARNMSG, '(1) kd < machine precision. Assuming kd == 0.' +#endif + else + + if (this%rot_ < CST_PId2) then + rot = this%rot_ + cd = kd / tan(rot) + elseif (this%rot_ < CST_PIGREC) then + rot = this%rot_ - CST_PId2 + cd = - kd * tan(rot) + elseif (this%rot_ < CST_PIt3d2) then + rot = this%rot_ - CST_PIGREC + cd = - kd / tan(rot) + elseif (this%rot_ < CST_PIt2) then + rot = this%rot_ - CST_PIt3d2 + cd = kd * tan(rot) + endif + endif + + fj = pt%freqJ() + cd + Pe = MPoint(coord_val, fj) + + + elseif (known_coord == 'j') then ! we search DI + + kd = abs(coord_val - pt%freqJ()) + + ! BUG: forcing it to zero if below some precision + if (kd < MACHINE_PRECISION) then + +#ifdef __BSA_DEBUG + write(unit_debug_, '(a, a)') & + WARNMSG, '(2) kd < machine precision. Assuming kd == 0.' +#endif + else + + if (this%rot_ < CST_PId2) then + rot = this%rot_ + cd = kd * tan(rot) + elseif (this%rot_ < CST_PIGREC) then + rot = this%rot_ - CST_PId2 + cd = kd / tan(rot) + elseif (this%rot_ < CST_PIt3d2) then + rot = this%rot_ - CST_PIGREC + cd = - kd * tan(rot) + elseif (this%rot_ < CST_PIt2) then + rot = this%rot_ - CST_PIt3d2 + cd = - kd / tan(rot) + endif + endif + + fi = pt%freqI() + cd + Pe = MPoint(fi, coord_val) + + endif ! known_coord + + this%base_J_ = getPointsDistance(pt, Pe) + + + + elseif (base_dir == 'j') then ! we pass A pt, we know base along J-dir + + + if (known_coord == 'i') then + + kd = abs(coord_val - pt%freqI()) + + ! BUG: forcing it to zero if below some precision + if (kd < MACHINE_PRECISION) then + +#ifdef __BSA_DEBUG + write(unit_debug_, '(a, a)') & + WARNMSG, '(3) kd < machine precision. Assuming kd == 0.' +#endif + else + + if (this%rot_ < CST_PId2) then + rot = this%rot_ + cd = kd * tan(rot) + elseif (this%rot_ < CST_PIGREC) then + rot = this%rot_ - CST_PId2 + cd = - kd / tan(rot) + elseif (this%rot_ < CST_PIt3d2) then + rot = this%rot_ - CST_PIGREC + cd = - kd * tan(rot) + elseif (this%rot_ < CST_PIt2) then + rot = this%rot_ - CST_PIt3d2 + cd = kd / tan(rot) + endif + endif + + fj = pt%freqJ() + cd + Pe = MPoint(coord_val, fj) + + + elseif (known_coord == 'j') then + + + kd = abs(coord_val - pt%freqJ()) + + ! BUG: forcing it to zero if below some precision + if (kd < MACHINE_PRECISION) then + +#ifdef __BSA_DEBUG + write(unit_debug_, '(a, a)') & + WARNMSG, '(4) kd < machine precision. Assuming kd == 0.' +#endif + else + + if (this%rot_ < CST_PId2) then + rot = this%rot_ + cd = kd / tan(rot) + elseif (this%rot_ < CST_PIGREC) then + rot = this%rot_ - CST_PId2 + cd = - kd * tan(rot) + elseif (this%rot_ < CST_PIt3d2) then + rot = this%rot_ - CST_PIGREC + cd = - kd / tan(rot) + elseif (this%rot_ < CST_PIt2) then + rot = this%rot_ - CST_PIt3d2 + cd = kd * tan(rot) + endif + endif + + fi = pt%freqI() + cd + Pe = MPoint(fi, coord_val) + + endif ! known_coord + + + this%base_I_ = getPointsDistance(pt, Pe) + + + endif ! base_dir + + ! Now once defined save End point + this%Ept_ = Pe + end subroutine getOtherBase + + + + + + !> Gets actualised frequency deltas along two main + !> sides directions (I, J), actualised based on *this + !> zone rotation w.r.t. GRS. + module subroutine getIJfsteps(this, dfIx, dfIy, dfJx, dfJy) + class(MRectZone_t), intent(in) :: this + real(RDP), intent(out) :: dfIx, dfIy, dfJx, dfJy + + real(RDP) :: c, s, ang + + if (this%rot_ < CST_PId2) then ! FIRST quadrant + + c = cos(this%rot_) + s = sin(this%rot_) + + dfIx = this%deltaf_I_ * c + dfIy = - this%deltaf_I_ * s + + dfJx = this%deltaf_J_ * s + dfJy = this%deltaf_J_ * c + + elseif (this%rot_ < CST_PIGREC) then ! SECOND quadrant + + ang = this%rot_ - CST_PId2 + c = cos(ang) + s = sin(ang) + + dfIx = - this%deltaf_I_ * s + dfIy = - this%deltaf_I_ * c + + dfJx = this%deltaf_J_ * c + dfJy = - this%deltaf_J_ * s + + elseif (this%rot_ < CST_PIt3d2) then ! THIRD quadrant + + ang = this%rot_ - CST_PIGREC + c = cos(ang) + s = sin(ang) + + dfIx = - this%deltaf_I_ * c + dfIy = this%deltaf_I_ * s + + dfJx = - this%deltaf_J_ * s + dfJy = - this%deltaf_J_ * c + + elseif (this%rot_ < CST_PIt2) then ! FOURTH quadrant + + ang = this%rot_ - CST_PIt3d2 + c = cos(ang) + s = sin(ang) + + dfIx = this%deltaf_I_ * s + dfIy = this%deltaf_I_ * c + + dfJx = - this%deltaf_J_ * c + dfJy = this%deltaf_J_ * s + + endif + end subroutine + + + + + + + + module function reconstructZoneBaseMesh(this) result(msh) + class(MRectZone_t), intent(in) :: this + !> BUG: might be 2-rank array instead of 3! + real(RDP) :: msh(2, this%nj_, this%ni_) + + real(RDP) :: dfIi, dfIj, dfJi, dfJj + real(RDP) :: base_fi, base_fj, fi, fj + integer :: i, j + + call this%getIJfsteps(dfIi, dfIj, dfJi, dfJj) + + fi = this%Ipt_%freqI() + fj = this%Ipt_%freqJ() + base_fi = fi + base_fj = fj + + msh(:, 1, 1) = [fj, fi] + + ! internal lines + do j = 2, this%nj_ + fi = fi + dfJi + fj = fj + dfJj + msh(:, j, 1) = [fj, fi] + enddo ! pj_head + + + ! internal columns + do i = 2, this%ni_ + + base_fi = base_fi + dfIi + base_fj = base_fj + dfIj + + fi = base_fi + fj = base_fj + + msh(:, 1, i) = [fj, fi] + + do j = 2, this%nj_ + fi = fi + dfJi + fj = fj + dfJj + msh(:, j, i) = [fj, fi] + enddo ! pj_head + enddo ! pi_head + end function + + + + + + + !> Actual zone comutation (pre phase). + module subroutine compute_s(this) + use BsaLib_Data, only: & + dimM_bisp_, getBFM_msh, settings & + , m3mf_msh_ptr_, msh_NZones, msh_bfmpts_pre_ + class(MRectZone_t), intent(inout) :: this + + + if (.not. (this%refmts_set_ .or. this%deltas_set_)) & + call bsa_Abort('Either deltas or refinements must be set before computing a zone.') + + + if (this%base_I_ <= MACHINE_PRECISION .or. this%base_J_ <= MACHINE_PRECISION) then + print '(1x, 4a)', & + WARNMSG, 'One sub-zone at ', & + this%name_(1 : len_trim(this%name_)), ' is empty.' + goto 998 + endif + + if (this%deltaf_I_ <= MACHINE_PRECISION .or. this%deltaf_J_ <= MACHINE_PRECISION) & + call bsa_Abort("At least one delta freq is zero.") + + + block + real(RDP) :: dfIi, dfIj, dfJi, dfJj + real(RDP) :: base_fi, base_fj, fi, fj + + integer :: niM1, njM1 + integer :: i, j, idbfm, zNp + + real(RDP), allocatable :: bfm(:, :) + +#ifdef BSA_M3MF_ONLY_PREMESH_ + real(RDP) :: dwI, dwJ + real(RDP) :: ctr_infl, brd_infl, vtx_infl + real(RDP), allocatable :: intg(:) +#endif + + call this%getIJfsteps(dfIi, dfIj, dfJi, dfJj) + + +#ifdef BSA_M3MF_ONLY_PREMESH_ + ! deltas in [rad/s] (to compute influence areas) + dwI = this%deltaf_I_ * CST_PIt2 + dwJ = this%deltaf_J_ * CST_PIt2 + ctr_infl = dwI * dwJ + brd_infl = ctr_infl / 2 + vtx_infl = brd_infl / 2 + + allocate(intg(dimM_bisp_)) +#endif + + + ! get before last refmts indexes (along I and J dirs) + niM1 = this%ni_ - 1 + njM1 = this%nj_ - 1 + + + ! allocate memory + ! NOTE: but dimBISP as 1st dimensions, since + ! we are gonna calling getBFM for each + ! couple of nodal indexes, returning a + ! dimBISP 1D vector, so better memory access. + ! However, later maybe better invert. + zNp = this%nj_ * this%ni_ + allocate(bfm(dimM_bisp_, zNp)) + + + !========================================================= + ! FIRST COLUMN (along J-dir, from I to A) + ! + base_fi = this%Ipt_%freqI() + base_fj = this%Ipt_%freqJ() + + fi = base_fi + fj = base_fj + + bfm(:, 1) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg(:) = bfm(:, 1) * vtx_infl +#endif + +#ifdef __BSA_CHECK_NOD_COH_SVD + return +#endif + + ! internal lines + do j = 2, njM1 + + fi = fi + dfJi + fj = fj + dfJj + bfm(:, j) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg(:) = intg(:) + bfm(:, j) * brd_infl +#endif + enddo + + ! BUG: handle in case 2 > njM1 ??? + if (njM1 == 1 .and. (.not. j==2)) j = 2 + + fi = fi + dfJi + fj = fj + dfJj + bfm(:, j) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg(:) = intg(:) + bfm(:, j) * vtx_infl +#endif + idbfm = j + 1 + + + + !========================================================= + ! INTERNAL COLUMNS + ! + do i = 2, niM1 + + ! update base freqs moving along I local direction (X) + base_fi = base_fi + dfIi + base_fj = base_fj + dfIj + fi = base_fi + fj = base_fj + + bfm(:, idbfm) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg(:) = intg(:) + bfm(:, idbfm) * brd_infl +#endif + idbfm = idbfm + 1 + + ! internal lines + do j = 2, njM1 + + fi = fi + dfJi + fj = fj + dfJj + bfm(:, idbfm) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg(:) = intg(:) + bfm(:, idbfm) * ctr_infl +#endif + idbfm = idbfm + 1 + enddo + + ! last line + ! BUG: handle in case 2 > njM1 ??? + if (njM1 == 1 .and. (.not. j==2)) j = 2 + + fi = fi + dfJi + fj = fj + dfJj + bfm(:, idbfm) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg(:) = intg(:) + bfm(:, idbfm) * brd_infl +#endif + idbfm = idbfm + 1 + enddo + + + !========================================================= + ! LAST COLUMN (from B to E) + ! + ! BUG: handle in case 2 > niM1 ??? + if (niM1 == 1 .and. (.not. i==2)) i = 2 + + base_fi = base_fi + dfIi + base_fj = base_fj + dfIj + fi = base_fi + fj = base_fj + ! first line + bfm(:, idbfm) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg(:) = intg(:) + bfm(:, idbfm) * vtx_infl +#endif + idbfm = idbfm + 1 + + ! internal lines + do j = 2, njM1 + fi = fi + dfJi + fj = fj + dfJj + bfm(:, idbfm) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg(:) = intg(:) + bfm(:, idbfm) * brd_infl +#endif + idbfm = idbfm + 1 + enddo + + ! last line + ! BUG: handle in case 2 > njM1 ??? + if (njM1 == 1 .and. (.not. j==2)) j = 2 + + fi = fi + dfJi + fj = fj + dfJj + bfm(:, idbfm) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg(:) = intg(:) + bfm(:, idbfm) * vtx_infl +#endif + +! #ifdef __BSA_DEBUG + if (idbfm /= zNp) then + print *, 'idbfm , zNp = ', idbfm, zNp + call bsa_Abort('"idbfm" does not equally tot N of Rect zone''s points.') + endif +! #endif + + !$omp critical +#ifdef BSA_M3MF_ONLY_PREMESH_ + m3mf_msh_ptr_ = m3mf_msh_ptr_ + (intg * settings%i_bisp_sym_) ! update main integral +#endif + msh_NZones = msh_NZones + 1 ! update n. of zones count + msh_bfmpts_pre_ = msh_bfmpts_pre_ + zNp ! update tot num of meshing points + + ! eventually, update zone with max N of points + if (zNp > msh_max_zone_NPts) msh_max_zone_NPts = zNp + + call DumpZone(this, bfm) ! dump zone info + !$omp end critical + + end block + + ! NOTE: reset them to 0 for ensuring next zone correct setup + 998 continue + this%refmts_set_ = .false. + this%deltas_set_ = .false. + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MRectZoneImpl::compute_s() : init -- ok.' +! #endif + end subroutine compute_s + + + + + + + !> Gets vertex point pt coordinates in Nth quadrant + !> w.r.t. Center point, in zone's LRS. + module pure function getNthQuadVtx(this, iquad) result(pt) + class(MRectZone_t), intent(in) :: this + integer, intent(in) :: iquad + type(MPoint_t) :: pt + real(RDP) :: c, s, rot, di, dj + + if (iquad < 1 .or. iquad > 4) return + + if (this%rot_ < CST_PId2) then + + c = cos(this%rot_) + s = sin(this%rot_) + + select case (iquad) + case (1) + di = this%base_I_ * c + this%base_J_ * s + dj = this%base_J_ * c - this%base_I_ * s + + case (2) + di = this%base_I_ * c + dj = - this%base_I_ * s + + case (3) + pt = this%Ipt_ + return + + case (4) + di = this%base_J_ * s + dj = this%base_J_ * c + + end select + + + elseif (this%rot_ < CST_PIGREC) then + + rot = this%rot_ - CST_PId2 + c = cos(rot) + s = sin(rot) + + select case (iquad) + case (1) + di = this%base_J_ * c + dj = - this%base_J_ * s + + case (2) + di = this%base_J_ * c - this%base_I_ * s + dj = - (this%base_J_ * s + this%base_I_ * c) + + case (3) + di = - this%base_I_ * s + dj = - this%base_I_ * c + + case (4) + pt = this%Ipt_ + return + + end select + + elseif (this%rot_ < CST_PIt3d2) then + + rot = this%rot_ - CST_PIGREC + c = cos(rot) + s = sin(rot) + + select case (iquad) + case (1) + pt = this%Ipt_ + return + + case (2) + di = - this%base_J_ * s + dj = - this%base_J_ * c + + case (3) + di = - (this%base_J_ * s + this%base_I_ * c) + dj = - this%base_J_ * c + this%base_I_ * s + + case (4) + di = - this%base_I_ * c + dj = this%base_I_ * s + end select + + elseif (this%rot_ < CST_PIt2) then + + rot = this%rot_ - CST_PIt3d2 + c = cos(rot) + s = sin(rot) + + select case (iquad) + case (1) + di = this%base_I_ * s + dj = this%base_I_ * c + + case (2) + pt = this%Ipt_ + return + + case (3) + di = - this%base_J_ * c + dj = this%base_J_ * s + + case (4) + di = - this%base_J_ * c + this%base_I_ * s + dj = this%base_J_ * s + this%base_I_ * c + end select + + endif + + pt = MPoint(this%Ipt_%freqI() + di, this%Ipt_%freqJ() + dj) + end function + + + + + + + + + !> Dumps a RECTANGULAR zone. + !> + !> NOTE: Each specific zone dumping method is called + !> from the STATIC MSaver_t procedure dump(). + !> This makes no need for specific saver to have + !> their own dump() implementation, since this + !> current imlementation is what we are looking for. + module subroutine dumpRZ(this) + class(MRectZone_t), intent(in) :: this + + write(unit_dump_bfm_) MZone_ID%RECTANGLE + + ! init pt + write(unit_dump_bfm_) this%Ipt_%freqI(), this%Ipt_%freqJ() + + write(unit_dump_bfm_) this%rot_ + write(unit_dump_bfm_) this%base_I_, this%base_J_ + + ! NOTE: maybe useless ? + write(unit_dump_bfm_) this%ni_, this%nj_ + +#ifdef __BSA_ZONE_DEBUG + write(unit=4533, fmt=*) & + 'Refms at RZ=', trim(this%name_), this%ni_, this%nj_, & + 'thread id= ', omp_get_thread_num() +#endif + end subroutine dumpRZ + + + + + + !> Undumps a RECTANGULAR zone. + !> + !> NOTE: Each specific zone dumping method is called + !> from the STATIC procedure UndumpZone() in MZone Module. + module subroutine undumpRZ(this) + class(MRectZone_t), intent(inout) :: this + + real(RDP) :: rval1, rval2 + integer :: ival1, ival2 + + ! init point + read(unit_dump_bfm_) rval1, rval2 + call this%Ipt_%setfreqs(rval1, rval2) + + ! rotation + read(unit_dump_bfm_) rval1 + this%rot_ = rval1 + + ! sides + read(unit_dump_bfm_) rval1, rval2 + this%base_I_ = rval1 + this%base_J_ = rval2 + + ! refinements + read(unit_dump_bfm_) ival1, ival2 + call this%setRefinements(ival1, ival2, .true.) + end subroutine undumpRZ + + + + + + + + !> Implementation of rect zone interpolation methods + module subroutine interpolateRZ( this & +#ifdef __BSA_OMP + , bfm, pdata & +#endif + & ) + class(MRectZone_t), intent(inout) :: this +#ifdef __BSA_OMP + real(RDP), intent(in) :: bfm(:, :) + class(*), pointer, intent(in) :: pdata + + ! NOTE: for the moment only supporting HTPC method + call interpolateRZ_HTPC_v3(this, bfm, pdata) +#else + call interpolateRZ_HTPC_v3(this) +#endif + end subroutine interpolateRZ + + + + + + + + + + !> Implementation of HTPC interpolation method for a rectangle zone, + !> including MultiLevel-Refinement for BFM data. + subroutine interpolateRZ_HTPC_v3( this & +#ifdef __BSA_OMP + , bfm_undump, pdata & +#endif + & ) + use BsaLib_Data, only: & +#ifndef __BSA_OMP + bfm_undump, & +#endif + dimM_bisp_, getBFM_msh, getBRM_msh, m3mf_msh_ptr_, m3mr_msh_ptr_, settings & + , msh_bfmpts_post_, msh_brmpts_post_, do_validate_deltas_ & + , msh_ZoneLimsInterestModes, peak_exts_ & + , write_brm_fptr_, do_export_brm_, BrmExportBaseData_t & + , I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_, I_RES_PEAK_DELTAF_BFM_REFMT_FCT_ & + , CODE_PRE_PEAK_OK, CODE_PRE_PEAK_KO & + , bkg_peakw_ + + use BsaLib_MPolicy, only: MPolicy_t + ! + class(MRectZone_t), intent(inout) :: this +#ifdef __BSA_OMP + real(RDP), intent(in) :: bfm_undump(:, :) + class(*), pointer, intent(in) :: pdata +#endif + + type(MPolicy_t) :: pol + integer :: ni, nj, ni_bfm_ref_, nj_bfm_ref_ + integer :: nipI, nipJ, nPtsPost, n_im_, im_idx_ + integer :: i, ist, n_segs_bfm_ref_i_, n_segs_bfm_ref_j_ + integer :: n_pts_bfm_ref_i_, n_pts_bfm_ref_j_ + real(RDP) :: dfIi_bfm_lv0_, dfIj_bfm_lv0_, dfJi_bfm_lv0_, dfJj_bfm_lv0_ + real(RDP) :: dfIi_bfm_ref_, dfIj_bfm_ref_, dfJi_bfm_ref_, dfJj_bfm_ref_ + real(RDP) :: dfI_bfm_lv0_, dfJ_bfm_lv0_, dfI_bfm_ref_, dfJ_bfm_ref_ + real(RDP) :: dfIi_brm_interp, dfIj_brm_interp, dfJi_brm_interp, dfJj_brm_interp + real(RDP) :: dfI_brm_interp_, dfJ_brm_interp_, dwI, dwJ + real(RDP) :: vtx_infl, brd_infl, ctr_infl + integer(kind = 4), allocatable :: inter_modes_(:) + + ! HTPC indexes + integer :: pIcurr, pIprev, pJhead, pJtail + + ! Pos in general BFM undumped data + integer :: i_bfm_old, i_bfm_ref_i, i_bfm_ref_j + integer :: i_brm, i_brm_shift, i_brm_write_, i_brm_offsetJ + integer :: i_bfm_interpJ, i_ftc + + ! freqs + real(RDP) :: fi_baseptI, fj_baseptI, fi_baseptJ, fj_baseptJ + real(RDP) :: fi, fj +#ifdef __BSA_OMP + real(RDP), allocatable, dimension(:) :: fi_v_, fj_v_ +#endif + + + real(RDP), allocatable :: bfm_new_left(:, :), bfm_new_right(:, :) + real(RDP), allocatable :: bfm_interp(:, :) + + real(RDP) :: dfJtail, dfJhead, dfIcurr, dfIprev + real(RDP) :: bfmtail(dimM_bisp_), bfmhead(dimM_bisp_) + + real(RDP), allocatable :: brm(:, :) + real(RDP) :: intg(dimM_bisp_) + +#ifndef BSA_M3MF_ONLY_PREMESH_ + real(RDP) :: vtx_infl_bfm, brd_infl_bfm, ctr_infl_bfm + real(RDP) :: intg_bfm(dimM_bisp_) +#endif + + + pol = this%policy() ! get zone's policy + + ! get original (pre-meshing) deltas (LEVEL 0) + ! NOTE: keep them in memory unchanged since they might serve later on. + call this%getIJfsteps(dfIi_bfm_lv0_, dfIj_bfm_lv0_, dfJi_bfm_lv0_, dfJj_bfm_lv0_) + + + ! get n. of BFM refinement segments (between two old ones) + n_segs_bfm_ref_i_ = 1 ! original + n_segs_bfm_ref_j_ = 1 + do i = 1, pol%n_interp_bfm_lvs_ + n_segs_bfm_ref_i_ = n_segs_bfm_ref_i_ * pol%interp_bfm_I_fct_ + n_segs_bfm_ref_j_ = n_segs_bfm_ref_j_ * pol%interp_bfm_J_fct_ + enddo + dfI_bfm_lv0_ = this%deltaf_I_ + dfI_bfm_ref_ = dfI_bfm_lv0_ / n_segs_bfm_ref_i_ + dfJ_bfm_lv0_ = this%deltaf_J_ + dfJ_bfm_ref_ = dfJ_bfm_lv0_ / n_segs_bfm_ref_j_ + + + ! Validate BFM_ref deltas + ! NOTE: for the moment, check only if too coarse. + ! Later on, check also if too fine! + if (do_validate_deltas_) then + + ! NOTE: 0 denotes that interest modes are to be inferenced from index 1. + ! In fact, there are 3 scenarios. + ! 1. next zone is pre-peak, and next peak interest modes' start from 1. + ! BKG does not include any resonant peak. + ! 2. next zone is pre-peak, and next peak interest modes' DO NOT start from 1. + ! BKG does include some resonant peaks (from 1-less-index or next peak zone) + ! 3. next zone is peak. + ! BKG does include this, plus all previous resonant peaks. + + im_idx_ = this%id_im_ + if (im_idx_ == 0) im_idx_ = 1 + n_im_ = msh_ZoneLimsInterestModes(im_idx_) + + ! NOTE: this is allowed since in Pre-Mesh we have already +1 incremented pointer index + ! for all pre-peak zones. So, only negative index is possible for very first + ! pre-peak zone right after BKG, for which we had set pointer index to 0! + if (n_im_ == CODE_PRE_PEAK_OK) then + i_ftc = I_BKG_PEAK_DELTAF_BFM_REFMT_FCT_ + dwI = bkg_peakw_ + else + if (n_im_ < 0) then + im_idx_ = im_idx_ + 1 + n_im_ = msh_ZoneLimsInterestModes(im_idx_) + endif + + i_ftc = I_RES_PEAK_DELTAF_BFM_REFMT_FCT_ + inter_modes_ = msh_ZoneLimsInterestModes(im_idx_ + 1 : im_idx_ + n_im_) + + ! BUG: introduce I and J peak widths! + dwI = minval(peak_exts_(inter_modes_)) ! base MIN deltaf + endif + + if (dfI_bfm_ref_ > dwI / i_ftc) then + do while (dfI_bfm_ref_ > dwI / i_ftc) + n_segs_bfm_ref_i_ = n_segs_bfm_ref_i_ + 1 + dfI_bfm_ref_ = dfI_bfm_lv0_ / n_segs_bfm_ref_i_ + enddo + else + do while (dfI_bfm_ref_ < dwI / i_ftc .and. n_segs_bfm_ref_i_ > 1) + n_segs_bfm_ref_i_ = n_segs_bfm_ref_i_ - 1 + dfI_bfm_ref_ = dfI_bfm_lv0_ / n_segs_bfm_ref_i_ + enddo + endif + + if (dfJ_bfm_ref_ > dwI / i_ftc) then + do while (dfJ_bfm_ref_ > dwI / i_ftc) + n_segs_bfm_ref_j_ = n_segs_bfm_ref_j_ + 1 + dfJ_bfm_ref_ = dfJ_bfm_lv0_ / n_segs_bfm_ref_j_ + enddo + else + do while (dfJ_bfm_ref_ < dwI / i_ftc .and. n_segs_bfm_ref_j_ > 1) + n_segs_bfm_ref_j_ = n_segs_bfm_ref_j_ - 1 + dfJ_bfm_ref_ = dfJ_bfm_lv0_ / n_segs_bfm_ref_j_ + enddo + endif + endif + n_pts_bfm_ref_i_ = n_segs_bfm_ref_i_ - 1 + n_pts_bfm_ref_j_ = n_segs_bfm_ref_j_ - 1 + + + ! get refined (BFM) deltas (GRS) + dfIi_bfm_ref_ = dfIi_bfm_lv0_ / n_segs_bfm_ref_i_ + dfIj_bfm_ref_ = dfIj_bfm_lv0_ / n_segs_bfm_ref_i_ + dfJi_bfm_ref_ = dfJi_bfm_lv0_ / n_segs_bfm_ref_j_ + dfJj_bfm_ref_ = dfJj_bfm_lv0_ / n_segs_bfm_ref_j_ + + ! get BRM interpolated deltas (GRS) (taken from refined BFM deltas this time) + dfIi_brm_interp = dfIi_bfm_ref_ / pol%interp_I_fct_ + dfIj_brm_interp = dfIj_bfm_ref_ / pol%interp_I_fct_ + dfJi_brm_interp = dfJi_bfm_ref_ / pol%interp_J_fct_ + dfJj_brm_interp = dfJj_bfm_ref_ / pol%interp_J_fct_ + + ! get absolute deltas (in LRS), along I and J directions + dfI_brm_interp_ = dfI_bfm_ref_ / pol%interp_I_fct_ + dfJ_brm_interp_ = dfJ_bfm_ref_ / pol%interp_J_fct_ + + +#ifndef BSA_M3MF_ONLY_PREMESH_ + ! compute BFM (refined) influence areas for integration + dwI = dfI_bfm_ref_ * CST_PIt2 + dwJ = dfJ_bfm_ref_ * CST_PIt2 + ctr_infl_bfm = dwI * dwJ + brd_infl_bfm = ctr_infl / 2._RDP + vtx_infl_bfm = brd_infl / 2._RDP +#endif + + ! compute BRM influence areas for integration + dwI = dfI_brm_interp_ * CST_PIt2 + dwJ = dfJ_brm_interp_ * CST_PIt2 + ctr_infl = dwI * dwJ + brd_infl = ctr_infl / 2._RDP + vtx_infl = brd_infl / 2._RDP + + ! get actualised BFM-refined and BRM-interp refinements (along borders) + ni_bfm_ref_ = (this%ni_ - 1) + nj_bfm_ref_ = (this%nj_ - 1) + ni = ni_bfm_ref_ * (n_segs_bfm_ref_i_ * pol%interp_I_fct_) + 1 + nj = nj_bfm_ref_ * (n_segs_bfm_ref_j_ * pol%interp_J_fct_) + 1 + ni_bfm_ref_ = ni_bfm_ref_ * n_segs_bfm_ref_i_ + 1 + nj_bfm_ref_ = nj_bfm_ref_ * n_segs_bfm_ref_j_ + 1 + + ! number of BRM points to interpolate (insert) + ! between two know BFM (refined) points' direction lines. + nipI = pol%interp_I_fct_ - 1 + nipJ = pol%interp_J_fct_ - 1 + i_brm_offsetJ = nipI * nj + + ! allocate data + nPtsPost = ni * nj + allocate(brm(dimM_bisp_, nPtsPost), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""brm"" in interpolating RZ.") + brm = 0._RDP + + allocate(bfm_new_left(dimM_bisp_, nj), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""bfm_new_left"" in interpolating RZ.") + bfm_new_left = 0._RDP + + allocate(bfm_new_right(dimM_bisp_, nj), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""bfm_new_right"" in interpolating RZ.") + bfm_new_right = 0._RDP + + allocate(bfm_interp(dimM_bisp_, nj), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""bfm_interp"" in interpolating RZ.") + bfm_interp = 0._RDP + + +#ifdef __BSA_OMP + allocate(fi_v_(nPtsPost), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""fi"" in interpolating RZ.") + fi = 0._RDP + + allocate(fj_v_(nPtsPost), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""fj"" in interpolating RZ.") + fj = 0._RDP + +# define __FREQ_I_ fi_v_(i_brm) = fi +# define __FREQ_J_ fj_v_(i_brm) = fj +# define __FREQ_I_shift_ fi_v_(i_brm_shift) = fi +# define __FREQ_J_shift_ fj_v_(i_brm_shift) = fj +# define __PDATA ,pdata + + if (do_export_brm_ .and. associated(pdata)) then + select type (pdata) + class is (BrmExportBaseData_t) + pdata%nI_ = ni + pdata%nJ_ = nj + ! class default + ! brm_export_data_ => null() ! NOTE: produces "error #8201: Associate name cannot be a pointer." + end select + endif + +#else + +! # define __FREQ_I_ +! # define __FREQ_J_ +# define __FREQ_I_shift_ +# define __FREQ_J_shift_ +# define __PDATA ,null() + +#endif + + +! #ifdef __BSA_DEBUG +! print *, nPtsPost, ni_bfm_ref_ * nj_bfm_ref_, this%ni_ * this%nj_ +! #endif + + + ! before starting, interpolate very first column + ! along J dir, to get new mesh from old + ! Then for all the others, it will be done inside + ! the loop over the NI (old) points of the old mesh. + ! NOTE: integrate as well. + + + ! init point vertex + i_brm = 1 + fi_baseptI = this%Ipt_%freqI() + fj_baseptI = this%Ipt_%freqJ() + fi = fi_baseptI + fj = fj_baseptI + fi_baseptJ = fi + fj_baseptJ = fj + + bfmtail = bfm_undump(:, 1) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = bfmtail * vtx_infl_bfm +#endif + bfm_new_left(:, 1) = bfmtail + + brm(:, 1) = getBRM_msh(bfmtail, fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, 1) __PDATA) +#endif + intg = brm(:, 1) * vtx_infl + + do pJhead = 2, this%nj_ ! loop on all OLD BFM saved points (J-dir) + + do i_bfm_ref_j = 1, n_pts_bfm_ref_j_ ! loop on all REF BFM pts between 2 old. + + ! compute head + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + bfmhead = getBFM_msh(fi_baseptJ, fj_baseptJ) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * brd_infl_bfm +#endif + + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ ! interp (J-dir) between tail-head + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + ! NOTE: save BFM for later use. + i_brm = i_brm + 1 + bfm_new_left(:, i_brm) = (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * brd_infl ! NOTE: it is a border point + enddo + + ! treat head (new BFM refined point) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + +#ifdef __BSA_DEBUG + ! DEBUG: they should equate fi/fj_baseptI!! + if (abs(fi - fi_baseptJ) > MACHINE_PRECISION .or. & + abs(fj - fj_baseptJ) > MACHINE_PRECISION) & + call bsa_Abort(& + 'BAD (1): fi or fj at the end of a BFM ref segment does not coincide..') +#endif + + i_brm = i_brm + 1 + bfm_new_left(:, i_brm) = bfmhead + brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + ! NOTE: it is a border point, except for the very last one (VERTEX) + intg = intg + brm(:, i_brm) * brd_infl + + bfmtail = bfmhead + enddo ! n. of (exact) ref points for BFM + + ! + ! NOTE: now new head is OLD BFM (next) point! + ! + bfmhead = bfm_undump(:, pJhead) ! OK because we stored it NJ majour. +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * brd_infl_bfm +#endif + + +#ifdef __BSA_DEBUG + if (n_pts_bfm_ref_j_ > 0) then + if (abs((fi_baseptI + (dfJi_bfm_lv0_*(pJhead-1))) - (fi_baseptJ + dfJi_bfm_ref_)) > MACHINE_PRECISION .or. & + abs((fj_baseptI + (dfJj_bfm_lv0_*(pJhead-1))) - (fj_baseptJ + dfJj_bfm_ref_)) > MACHINE_PRECISION) & + call bsa_Abort(& + 'BAD (2): fi or fj at the end of a BFM ref segment does not coincide..') + endif +#endif + + + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ ! interp (J-dir) between tail-head + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + ! NOTE: save it for later use. + i_brm = i_brm + 1 + bfm_new_left(:, i_brm) = (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * brd_infl ! NOTE: it is a border point + enddo ! pJtail = 1, nipJ + + ! here, treat head, TAIL==HEAD (head - old mesh) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_brm = i_brm + 1 + bfm_new_left(:, i_brm) = bfmhead + brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + ! NOTE: it is a border point, except for the very last one (VERTEX) + intg = intg + brm(:, i_brm) * brd_infl + + ! old head (old mesh) becomes new tail + ! TODO: we could change bfmhead here, so that + ! it might be already ready for next loop. + bfmtail = bfmhead + + ! NOTE: set new bfm ref base freqs as (current) head (old-mesh) point + fi_baseptJ = fi + fj_baseptJ = fj + enddo + + ! NOTE: removing excess contribution for last HEAD (VERTEX) + intg = intg - brm(:, i_brm) * vtx_infl +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm - bfmtail * vtx_infl_bfm +#endif + + + ! + i_bfm_old = this%nj_ + do pIcurr = 2, this%ni_ ! loop on all OLD BFM infl lines (I-dir) + + ! before doing any computation, + ! we need to interpolate BFM along J + ! at new CURRENT (I) infl line (including ref infl lines) + ! NOTE: once we go through, integrate as well. + + do i_bfm_ref_i = 1, n_pts_bfm_ref_i_ ! loop on all REF BFM pts between 2 old (I-dir) + + ! computing BRM offset from pi_prev and pi_curr J infl lines. + i_brm_shift = i_brm + i_brm_offsetJ + i_brm_write_ = i_brm_shift + + ! reset base freqs to point to new base -> prev base moved by ref BFM deltas (I-dir) + ! NOTE: still keep prev base in memory here since they might serve later. + fi_baseptJ = fi_baseptI + dfIi_bfm_ref_ ! reset J bases to match next I + fj_baseptJ = fj_baseptI + dfIj_bfm_ref_ + fi = fi_baseptJ + fj = fj_baseptJ + + bfmtail = getBFM_msh(fi, fj) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmtail * brd_infl_bfm +#endif + bfm_new_right(:, 1) = bfmtail + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, 1), fi, fj) + + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + intg = intg + brm(:, i_brm_shift) * brd_infl + + i_bfm_interpJ = 1 + do pJhead = 2, this%nj_ ! loop on all OLD BFM saved points (J-dir) + + do i_bfm_ref_j = 1, n_pts_bfm_ref_j_ ! loop on all REF BFM pts between 2 old. + + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + bfmhead = getBFM_msh(fi_baseptJ, fj_baseptJ) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * ctr_infl_bfm +#endif + + ! once we moved head, restore init, distances from head/tail + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ ! interp (J-dir) between tail-head + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = & + (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for very last row -> BORDER + intg = intg + brm(:, i_brm_shift) * ctr_infl + enddo ! pJtail = 1, nipJ + + ! tail in now head (new BFM refined point) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = bfmhead + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for the very last one (BORDER) + intg = intg + brm(:, i_brm_shift) * ctr_infl + + bfmtail = bfmhead + enddo ! n. of (exact) ref points for BFM (J-dir) + + ! here, next head is special (lies on an OLD BFM I-dir infl line). + ! NOTE: don't forget to interpolate between this head and tail!! + ! NOTE: it is a center point, except for the very last one (BORDER) + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + bfmhead = getBFM_msh(fi_baseptJ, fj_baseptJ) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * vtx_infl_bfm +#endif + + ! once we moved head, restore init, distances from head/tail + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = & + (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for very last row -> BORDER + intg = intg + brm(:, i_brm_shift) * ctr_infl + enddo ! pJtail = 1, nipJ + + ! here treat this new head + fi = fi + dfJi_brm_interp ! they should equate fi_baseptJ + fj = fj + dfJj_brm_interp + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = bfmhead + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + intg = intg + brm(:, i_brm_shift) * ctr_infl + + bfmtail = bfmhead ! old head becomes new tail + enddo ! pJhead = 2, this%nj_ + + ! removing excess of very last HEAD, accounted as center, it is BORDER. + ! NOTE: even worse for very last HEAD which happens to be End point. + ! there, it is a VERTEX point. + ! However, it's the very last element in brm, we can remove it after. + intg = intg - brm(:, i_brm_shift) * brd_infl +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm - bfmtail * brd_infl_bfm +#endif + + ! Now INTERPOLATE along I-dir between left and right BFM infl lines. + ! + dfIcurr = dfI_bfm_ref_ ! reset I-dir CURR-PREV distances + dfIprev = 0._RDP + do pIprev = 1, nipI ! interp (I-dir) between prev-curr + + ! bulk I-dir interpolation until pj_head section level. + ! Then, after treat that triang shaped zone separately. + + dfIprev = dfIprev + dfI_brm_interp_ + dfIcurr = dfIcurr - dfI_brm_interp_ + + bfm_interp = & + ( bfm_new_left * dfIcurr + & + bfm_new_right * dfIprev ) / dfI_bfm_ref_ + + ! once we have the values, go through them to integrate + ! NOTE: reset base freqs pointers, this time moving them along INTERP mesh + fi = fi_baseptI + (dfIi_brm_interp * pIprev) + fj = fj_baseptI + (dfIj_brm_interp * pIprev) + + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, 1), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * brd_infl + + do pJtail = 2, nj + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, pJtail), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * ctr_infl + enddo + + ! removing excess from having accounted values at last iter HEAD as + ! center points (they are BORDER) + intg = intg - brm(:, i_brm) * brd_infl + + enddo ! pIprev = 1, nipI + + + ! now update bases along I (CURR now, PREV next iteration!) + fi_baseptI = fi_baseptI + dfIi_bfm_ref_ + fj_baseptI = fj_baseptI + dfIj_bfm_ref_ + + +#ifndef __BSA_OMP + ! Now, we can write actual new BFM I-dir infl line. + fi = fi_baseptI + fj = fj_baseptI + do pIprev = 1, nj + i_brm_write_ = i_brm_write_ + 1 + call write_brm_fptr_(fi, fj, brm(:, i_brm_write_), null()) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + enddo +#endif + + ! moving right, shift infl-lines. + bfm_new_left = bfm_new_right + + i_brm = i_brm_shift + + enddo ! BFM ref points along I dir + + + + ! + ! Here, right BFM infl line is one where we have old BFM mesh points ! + ! + + ! computing BRM offset from pi_prev and pi_curr J infl lines. + i_brm_shift = i_brm + i_brm_offsetJ + i_brm_write_ = i_brm_shift + + ! again, I bases refer to PREV infl line. + fi_baseptJ = fi_baseptI + dfIi_bfm_ref_ + fj_baseptJ = fj_baseptI + dfIj_bfm_ref_ + fi = fi_baseptJ + fj = fj_baseptJ + + i_bfm_old = i_bfm_old + 1 + bfmtail = bfm_undump(:, i_bfm_old) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmtail * brd_infl_bfm +#endif + bfm_new_right(:, 1) = bfmtail + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, 1), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + intg = intg + brm(:, i_brm_shift) * brd_infl + + ! compute right infl-line + i_bfm_interpJ = 1 + do pJhead = 2, this%nj_ + + do i_bfm_ref_j = 1, n_pts_bfm_ref_j_ ! loop on all REF BFM pts between 2 old. + + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + bfmhead = getBFM_msh(fi_baseptJ, fj_baseptJ) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * ctr_infl_bfm +#endif + + ! once we moved head, restore init, distances from head/tail + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = & + (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for very last row -> BORDER + intg = intg + brm(:, i_brm_shift) * ctr_infl + enddo ! pJtail = 1, nipJ + + ! tail in now head (new BFM refined point) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = bfmhead + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for the very last one (BORDER) + intg = intg + brm(:, i_brm_shift) * ctr_infl + + bfmtail = bfmhead + enddo + + ! next head is OLD BFM point + fi = fi_baseptJ + fj = fj_baseptJ + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + + i_bfm_old = i_bfm_old + 1 + bfmhead = bfm_undump(:, i_bfm_old) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * ctr_infl_bfm +#endif + + ! once we moved head, restore init distances from head/tail + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + ! NOTE: save it for later use. + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = & + (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for very last row -> BORDER + intg = intg + brm(:, i_brm_shift) * ctr_infl + enddo ! pJtail = 1, nipJ + + ! here, treat head, TAIL==HEAD + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = bfmhead + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for the very last one (BORDER) + intg = intg + brm(:, i_brm_shift) * ctr_infl + + ! old head becomes new tail + bfmtail = bfmhead + enddo ! pJhead = 2, this%nj_ + + + ! removing excess of very last HEAD + ! accounted as center, it is BORDER + ! NOTE: even worse for very last HEAD which happens to be End point. + ! there, it is a VERTEX point. + ! However, it's the very last element in brm, we can remove it after. + intg = intg - brm(:, i_brm_shift) * brd_infl +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm - bfmtail * brd_infl_bfm +#endif + + + ! ok, here we now have BFM values (interpolated along J) + ! at CURR and PREV (I) index pointers. + ! We have to interpolate along I between CURR and PREV, i.e. + ! prev has to start moving toward CURR. + + + dfIcurr = dfI_bfm_ref_ ! reset I-dir CURR-PREV distances + dfIprev = 0._RDP + do pIprev = 1, nipI ! interpolate along I + + ! bulk I-dir interpolation until pj_head section level. + ! Then, after treat that triang shaped zone separately. + + dfIprev = dfIprev + dfI_brm_interp_ + dfIcurr = dfIcurr - dfI_brm_interp_ + + bfm_interp = & + ( bfm_new_left * dfIcurr + & + bfm_new_right * dfIprev ) / dfI_bfm_ref_ + + + ! once we have the values, go through them to integrate + ! NOTE: reset base freqs pointers, this time moving them along INTERP mesh + fi = fi_baseptI + (dfIi_brm_interp * pIprev) + fj = fj_baseptI + (dfIj_brm_interp * pIprev) + + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, 1), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * brd_infl + + do pJtail = 2, nj + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, pJtail), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * ctr_infl + enddo + + ! removing excess from having accounted values at last iter HEAD as + ! center points (they are BORDER) + intg = intg - brm(:, i_brm) * brd_infl + + enddo ! pIprev = 1, nipI + + ! once finished with this section (CURR-PREV), since we skip J column + ! at pi_curr infl line, we reset general BRM index to point to + ! previously shifted one. + i_brm = i_brm_shift + + ! now update bases along I + fi_baseptI = fi_baseptI + dfIi_bfm_ref_ + fj_baseptI = fj_baseptI + dfIj_bfm_ref_ + + +#ifndef __BSA_OMP + ! Now, we can write actual new BFM I-dir infl line. + fi = fi_baseptI + fj = fj_baseptI + do pIprev = 1, nj + i_brm_write_ = i_brm_write_ + 1 + call write_brm_fptr_(fi, fj, brm(:, i_brm_write_), null()) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + enddo +#endif + + + bfm_new_left = bfm_new_right + + enddo ! pIcurr = 2, this%ni_ + + +! #ifdef __BSA_DEBUG + if (i_brm /= nPtsPost) then + print *, ' policy BFM-MLV factors = ', pol%interp_bfm_I_fct_, pol%interp_bfm_J_fct_ + print *, ' policy BRM factors = ', pol%interp_I_fct_, pol%interp_J_fct_ + print *, ' ibrm, nPtsPost = ', i_brm, nPtsPost + call bsa_Abort('"i_brm" does not equal rect zone''s n. of (interpolated) points.') + endif +! #endif + + + deallocate(bfm_new_left) + deallocate(bfm_new_right) + deallocate(bfm_interp) + + + ! removing overestimation for B point + intg = intg - brm(:, i_brm - nj + 1) * vtx_infl + + ! removing overestimation for last border points + intg = intg - sum(brm(:, i_brm - nj + 2 : i_brm - 1) * brd_infl, dim=2) + + ! removing overestimation for End point + intg = intg - brm(:, i_brm) * vtx_infl + + + !$omp critical +#ifdef __BSA_OMP + call write_brm_fptr_(fi_v_, fj_v_, brm, pdata) +#endif + + ! updating main point counters + msh_bfmpts_post_ = msh_bfmpts_post_ + ni_bfm_ref_ * nj_bfm_ref_ + msh_brmpts_post_ = msh_brmpts_post_ + nPtsPost + +#ifndef BSA_M3MF_ONLY_PREMESH_ + m3mf_msh_ptr_ = m3mf_msh_ptr_ + (intg_bfm * settings%i_bisp_sym_) ! update main BFM integral +#endif + m3mr_msh_ptr_ = m3mr_msh_ptr_ + (intg * settings%i_bisp_sym_) ! update main BRM integral + !$omp end critical + end subroutine interpolateRZ_HTPC_v3 + + + + + + + + + + +! !> Implementation of HTPC interpolation method for a rectangle zone. +! !> This method IS FASTER (AND MORE ACCURATE!!) +! subroutine interpolateRZ_HTPC_v2(this) +! #ifdef __BSA_OMP +! use BsaLib_Data, only: dimM_bisp_, getBRM_msh, m3mr_msh_ptr_ +! #else +! use BsaLib_Data, only: dimM_bisp_, getBRM_msh, bfm_undump, m3mr_msh_ptr_ +! #endif +! use BsaLib_MPolicy, only: MPolicy_t +! class(MRectZone_t), intent(inout) :: this + +! type(MPolicy_t) :: pol +! integer :: ni, nj +! integer :: nipI, nipJ, zNintrpPts +! real(RDP) :: dfIi_old, dfIj_old, dfJi_old, dfJj_old +! real(RDP) :: dfIi_interp, dfIj_interp, dfJi_interp, dfJj_interp +! real(RDP) :: dfI_old, dfJ_old, dfI_interp, dfJ_interp, dwI, dwJ +! real(RDP) :: vtx_infl, brd_infl, ctr_infl + +! ! HTPC indexes +! integer :: picurr, piprev, pjhead, pjtail + +! !> Pos in general BFM undumped data +! integer :: i_bfm +! integer :: i_brm, i_brm_shift, ibrmoffset +! integer :: i_bfm_interpJ + +! ! freqs +! real(RDP) :: base_fi, base_fj, fi, fj + + +! real(RDP), allocatable :: bfm_new_left(:, :), bfm_new_right(:, :) +! real(RDP), allocatable :: bfm_interp(:, :) + +! real(RDP) :: dfJtail, dfJhead, dfIcurr, dfIprev +! real(RDP) :: bfmtail(dimM_bisp_), bfmhead(dimM_bisp_) + + +! real(RDP), allocatable :: brm(:, :) +! real(RDP) :: intg(dimM_bisp_) + +! integer :: iall1, iall2, iall3, iall4 + + +! ! zone's policy +! pol = this%policy() + + +! ! get original (pre-meshing) deltas +! ! NOTE: keep them in memory unchanged since they +! ! might serve later on. +! call this%getIJfsteps(dfIi_old, dfIj_old, dfJi_old, dfJj_old) + + +! ! get interpolated deltas (GRS) +! dfIi_interp = dfIi_old / pol%interp_I_fct_ +! dfIj_interp = dfIj_old / pol%interp_I_fct_ +! dfJi_interp = dfJi_old / pol%interp_J_fct_ +! dfJj_interp = dfJj_old / pol%interp_J_fct_ + + +! ! get absolute deltas (in LRS) +! ! along I and J directions +! dfI_old = this%deltaf_I_ +! dfI_interp = dfI_old / pol%interp_I_fct_ + +! dfJ_old = this%deltaf_J_ +! dfJ_interp = dfJ_old / pol%interp_J_fct_ + + +! ! compute influence areas for integration +! dwI = dfI_interp * CST_PIt2 +! dwJ = dfJ_interp * CST_PIt2 +! ctr_infl = dwI * dwJ +! brd_infl = ctr_infl / 2._RDP +! vtx_infl = brd_infl / 2._RDP + +! ! get actualised refinements (along borders) +! ni = (this%ni_ - 1) * pol%interp_I_fct_ + 1 +! nj = (this%nj_ - 1) * pol%interp_J_fct_ + 1 + +! ! number of points to interpolate (insert) +! ! between two know points' direction lines +! nipI = pol%interp_I_fct_ - 1 +! nipJ = pol%interp_J_fct_ - 1 + +! ibrmoffset = nipI * nj + +! ! allocate data +! zNintrpPts = ni * nj +! allocate(brm(dimM_bisp_, zNintrpPts), stat=iall1) +! brm = 0._RDP +! allocate(bfm_new_left(dimM_bisp_, nj), stat=iall2) +! bfm_new_left = 0._RDP +! allocate(bfm_new_right(dimM_bisp_, nj), stat=iall3) +! bfm_new_right = 0._RDP +! allocate(bfm_interp(dimM_bisp_, nj), stat=iall4) +! bfm_interp = 0._RDP + + +! ! before starting, interpolate very first column +! ! along J dir, to get new mesh from old +! ! Then for all the others, it will be done inside +! ! the loop over the NI (old) points of the old mesh. +! ! NOTE: integrate as well. + +! ! init point vertex +! base_fi = this%Ipt_%freqI() +! base_fj = this%Ipt_%freqJ() +! fi = base_fi +! fj = base_fj +! bfmtail = bfm_undump(:, 1) +! bfm_new_left(:, 1) = bfmtail +! brm(:, 1) = getBRM_msh(bfm_new_left(:, 1), fi, fj) +! intg = brm(:, 1) * vtx_infl + +! i_brm = 1 +! do pjhead = 2, this%nj_ + +! ! OK because we stored it NJ majour. +! bfmhead = bfm_undump(:, pjhead) + +! ! once we moved head, restore init +! ! distances from head/tail +! dfJhead = dfJ_old +! dfJtail = 0._RDP + +! do pjtail = 1, nipJ + +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp + +! ! update actual distances head/tail +! dfJtail = dfJtail + dfJ_interp +! dfJhead = dfJhead - dfJ_interp + +! ! interpolation along J dir (between HEAD-TAIL) +! ! NOTE: save it for later use. +! i_brm = i_brm + 1 +! bfm_new_left(:, i_brm) = (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_old +! brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) + +! ! NOTE: it is a border point +! intg = intg + brm(:, i_brm) * brd_infl +! enddo ! pjtail = 1, nipJ + +! ! here, treat head, TAIL==HEAD +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp +! i_brm = i_brm + 1 +! bfm_new_left(:, i_brm) = bfmhead +! brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) + +! ! NOTE: it is a border point, except for the very last one (VERTEX) +! intg = intg + brm(:, i_brm) * brd_infl + +! ! old head becomes new tail +! ! TODO: we could change bfmhead here, so that +! ! it might be already ready for next loop. +! bfmtail = bfmhead +! enddo + +! ! NOTE: removing excess contribution for last HEAD (VERTEX) +! intg = intg - brm(:, i_brm) * vtx_infl + + +! i_bfm = this%nj_ + +! ! NOTE: starting from 2 because we have to take +! ! infl lines in consequent groups of two. +! do picurr = 2, this%ni_ + + +! ! before doing any computation, +! ! we need to interpolate BFM along J +! ! at new CURRENT (I) infl line +! ! NOTE: once we go through, integrate as well. + +! ! computing BRM offset from pi_prev and pi_curr J infl lines. +! i_brm_shift = i_brm + ibrmoffset + +! ! reset freqs to point to new base -> prev base moved by old deltas! +! ! (now pi_prev-pj_tail) +! ! NOTE: still keep prev base in memory here since they might serve later. +! fi = base_fi + dfIi_old +! fj = base_fj + dfIj_old + +! i_bfm = i_bfm + 1 +! bfmtail = bfm_undump(:, i_bfm) +! bfm_new_right(:, 1) = bfmtail + +! i_brm_shift = i_brm_shift + 1 +! brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, 1), fi, fj) +! intg = intg + brm(:, i_brm_shift) * brd_infl + +! i_bfm_interpJ = 1 +! do pjhead = 2, this%nj_ + +! i_bfm = i_bfm + 1 +! bfmhead = bfm_undump(:, i_bfm) + +! ! once we moved head, restore init +! ! distances from head/tail +! dfJhead = dfJ_old +! dfJtail = 0._RDP + + +! do pjtail = 1, nipJ + +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp + +! ! update actual distances head/tail +! dfJtail = dfJtail + dfJ_interp +! dfJhead = dfJhead - dfJ_interp + +! ! interpolation along J dir (between HEAD-TAIL) +! ! NOTE: save it for later use. +! i_bfm_interpJ = i_bfm_interpJ + 1 +! bfm_new_right(:, i_bfm_interpJ) = & +! (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_old + +! i_brm_shift = i_brm_shift + 1 +! brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + +! ! NOTE: it is a center point, except for very last row -> BORDER +! intg = intg + brm(:, i_brm_shift) * ctr_infl +! enddo ! pjtail = 1, nipJ + +! ! here, treat head, TAIL==HEAD +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp +! i_bfm_interpJ = i_bfm_interpJ + 1 +! bfm_new_right(:, i_bfm_interpJ) = bfmhead + +! i_brm_shift = i_brm_shift + 1 +! brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + +! ! NOTE: it is a center point, except for the very last one (BORDER) +! intg = intg + brm(:, i_brm_shift) * ctr_infl + +! ! old head becomes new tail +! bfmtail = bfmhead + +! enddo ! pjhead = 2, this%nj_ + +! ! removing excess of very last HEAD +! ! accounted as center, it is BORDER +! ! NOTE: even worse for very last HEAD which happens to be End point. +! ! there, it is a VERTEX point. +! ! However, it's the very last element in brm, we can remove it after. +! intg = intg - brm(:, i_brm_shift) * brd_infl + + + + +! ! ok, here we now have BFM values (interpolated along J) +! ! at CURR and PREV (I) index pointers. +! ! We have to interpolate along I between CURR and PREV, i.e. +! ! prev has to start moving toward CURR. + + +! ! reset I-dir CURR-PREV distances +! dfIcurr = dfI_old +! dfIprev = 0._RDP + +! ! interpolate along I +! do piprev = 1, nipI + +! ! bulk I-dir interpolation until pj_head section level. +! ! Then, after treat that triang shaped zone separately. + +! dfIprev = dfIprev + dfI_interp +! dfIcurr = dfIcurr - dfI_interp + +! bfm_interp = & +! ( bfm_new_left * dfIcurr + & +! bfm_new_right * dfIprev ) / dfI_old + +! ! once we have the values, go through them to integrate +! ! NOTE: reset base freqs pointers, this time moving them along INTERP mesh +! fi = base_fi + (dfIi_interp * piprev) +! fj = base_fj + (dfIj_interp * piprev) + +! i_brm = i_brm + 1 +! brm(:, i_brm) = getBRM_msh(bfm_interp(:, 1), fi, fj) +! intg = intg + brm(:, i_brm) * brd_infl + +! do pjtail = 2, nj + +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp + +! i_brm = i_brm + 1 +! brm(:, i_brm) = getBRM_msh(bfm_interp(:, pjtail), fi, fj) +! intg = intg + brm(:, i_brm) * ctr_infl +! enddo + +! ! removing excess from having accounted values at last iter HEAD as +! ! center points (they are BORDER) +! intg = intg - brm(:, i_brm) * brd_infl + +! enddo ! piprev = 1, nipI + + +! ! now we can update (PREV) base freqs to match CURR +! ! NOTE: CURR J infl line has already been computed! +! base_fi = base_fi + dfIi_old +! base_fj = base_fj + dfIj_old + + +! bfm_new_left = bfm_new_right + + +! ! once finished with this section (CURR-PREV), since we skip J column +! ! at pi_curr infl line, we reset general BRM index to point to +! ! previously shifted one. +! i_brm = i_brm_shift + +! enddo ! picurr = 2, this%ni_ + + + +! #ifdef __BSA_DEBUG +! if (i_brm /= zNintrpPts) & +! call bsa_Abort('"i_bfm" does not equal rect zone''s n. of (interpolated) points.') +! #endif + + +! ! removing overestimation for B point +! intg = intg - brm(:, i_brm - nj + 1) * vtx_infl + +! ! removing overestimation for last border points +! intg = intg - sum(brm(:, i_brm - nj + 2 : i_brm - 1) * brd_infl, dim=2) + +! ! removing overestimation for End point +! intg = intg - brm(:, i_brm) * vtx_infl + +! ! updating main integral +! m3mr_msh_ptr_ = m3mr_msh_ptr_ + intg + +! end subroutine interpolateRZ_HTPC_v2 + + + + +end submodule \ No newline at end of file diff --git a/src/BsaLib/bsa/meshing/zones/MTriangZone.f90 b/src/BsaLib/bsa/meshing/zones/MTriangZone.f90 new file mode 100644 index 0000000..d4fb5af --- /dev/null +++ b/src/BsaLib/bsa/meshing/zones/MTriangZone.f90 @@ -0,0 +1,261 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_MTriangZone + +#include "../../../precisions" + + use BsaLib_CONSTANTS + use BsaLib_MPoint + use BsaLib_M2DPolygZone + implicit none + private + + ! imported from <- BsaLib_M2DPolygZone <- BsaLib_MZone + public :: msh_max_zone_NPts + + ! Make it visible without needing to import Base class module + public :: UndumpZone + + + ! TODO: triang and rect actually share almost everything.. + type, public, extends(M2DPolygZone_t) :: MTriangZone_t + + !> A pt. + !> It is the upper point when rot is 0. + type(MPoint_t) :: Apt_ + + !> B point. + !> It is the point to the right when the rotation is 0. + type(MPoint_t) :: Bpt_ + + !> Corner point. + !> NOTE: we need it in case it ends being + !> either init/end point for meshing + type(MPoint_t) :: Cpt_ + + + !> PAB abgle + real(RDP) :: PABang_ + + contains + + procedure, pass :: baseI => baseI_triang + procedure, pass :: baseJ => baseJ_triang + + + procedure, pass :: deduceDeltas => deduceDeltas_triang + + + !> Returns total N of zone's meshing points. + !> NOTE: for the moment, ONLY triangles rectangles supported + !> NOTE: override inherited procedure. + procedure, pass :: zoneTotNPts => zoneTotNPts_triang + + !> Sets a values for PAB angle. + procedure, pass, private :: setPABangle + + !> Useful if we want specific deltas in I and J directions + procedure, pass, private :: adaptToDeltas + + !> Deduce zone rotation from internal data + procedure, pass, private :: deduceRotation + + !> Gets unary deltas along I and J dirs, based on zone rotation + procedure, pass :: getRotatedUnaryDF + + !> Completely defines a triang zone. + generic :: define => defineFromPts_norm, defineFromPts_refmtsORdeltas + + !> Completely defines a triang zone from points C, A, B. + !> Either from refinements, or deltas + procedure, pass, private :: defineFromPts_norm, defineFromPts_refmtsORdeltas + + !> Computes a finally defined triang zone. + procedure, pass :: compute + + !> Dumps a triang zone + procedure, pass :: dump => dumpTZ + + !> Undumps a triang zone + procedure, pass :: undump => undumpTZ + + procedure, pass :: interpolate => interpolateTZ + end type + + + !> MTriangZone constructors interafce + interface MTriangZone + module procedure MTriangZone_constr_def + end interface + public :: MTriangZone + + + + + interface + + !> Default MTriangZone basic constructor + module function MTriangZone_constr_def(name) result(this) + character(len = *), intent(in), optional :: name + type(MTriangZone_t) :: this + end function + + + + !> Gets rect base along I-dir + module elemental function baseI_triang(this) result(res) + class(MTriangZone_t), intent(in) :: this + real(RDP) :: res + end function + + + !> Gets rect base along J-dir + module elemental function baseJ_triang(this) result(res) + class(MTriangZone_t), intent(in) :: this + real(RDP) :: res + end function + + + + module subroutine deduceDeltas_triang(this) + class(MTriangZone_t), intent(inout) :: this + end subroutine + + + + !> Returns total N of zone's meshing points. + !> NOTE: for the moment, ONLY triangles rectangles supported + module pure function zoneTotNPts_triang(this) result(npt) + class(MTriangZone_t), intent(in) :: this + integer :: npt + end function + + + + !> Computes PAB angle, using "cosine" rule. + !> NOTE: this only works if Cpt is the point at which + !> the wider angle is located! + module subroutine setPABangle(this) + class(MTriangZone_t), intent(inout) :: this + end subroutine + + + !> Used if we want some specific deltas + !> along I and J directions + module subroutine adaptToDeltas(this, dfi, dfj) + class(MTriangZone_t), intent(inout) :: this + real(RDP), value :: dfi, dfj + end subroutine + + + + !> BUG: this routine might hide a bug. + !> + !> Deduce triangle zone rotation, knowing the + !> coordinates of the 3 triang points. + !> + !> Still, triangle rotation is given by the rotation + !> needed to be done to reach the CA side, starting from + !> Y positive axis of the GRS. + module subroutine deduceRotation(this) + class(MTriangZone_t), intent(inout) :: this + end subroutine + + + + + !> Gets actua points' delta increments based on this zone's + !> rotation w.r.t GRS, when moving along the mesh. + !> If NOT inverted: + !> - df_var : total delta along CA side (J-dir in LRS) + !> - df_cst : total delta along CB side (I-dir in LRS) + module subroutine getRotatedUnaryDF(this, df_I_var, df_J_var, df_I_cst, df_J_cst) + class(MTriangZone_t), intent(inout) :: this + real(RDP), intent(out) :: df_I_var, df_J_var + ! logical, intent(in), optional :: invert + real(RDP), intent(out), optional :: df_I_cst, df_J_cst + end subroutine + + + + + !> Defines a triang zone from 3 triang points. + !> No need to specify which one is A or B point, this is + !> automatically deduced. + !> Automatically choses refinements definition. + module subroutine defineFromPts_norm(this, Cp, P1, P2) + class(MTriangZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: Cp, P1, P2 + end subroutine + + + !> Defines a triang zone from 3 triang points. + !> No need to specify which one is A or B point, this is + !> automatically deduced. + !> Also, possible to specify either a value. + !> If "is_refinement", then is either refinement along I or J direction. + !> NOTE: this is the defult if no optional is passed. + !> + !> If "is_refinement" is false, but still a value is passed, + !> it is interpreted as a delta value, still along either I or J direction. + module subroutine defineFromPts_refmtsORdeltas(this, Cp, P1, P2, is_refinement, val_types, val1, val2) + class(MTriangZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: Cp, P1, P2 + logical, intent(in) :: is_refinement + character(len = *), intent(in), optional :: val_types + real(RDP), intent(in), optional :: val1, val2 + end subroutine + + + + !> Computes a completely defined triang zone + module subroutine compute(this) + class(MTriangZone_t), intent(inout) :: this + end subroutine + + + + !> Dumps a triang zone data for later reconstruction + module subroutine dumpTZ(this) + class(MTriangZone_t), intent(in) :: this + end subroutine + + + + !> Undumps a triang zone data for later reconstruction + module subroutine undumpTZ(this) + class(MTriangZone_t), intent(inout) :: this + end subroutine + + + + !> Implementation of triang zone interpolation methods + module subroutine interpolateTZ( this & +#ifdef __BSA_OMP + , bfm, pdata & +#endif + & ) + class(MTriangZone_t), intent(inout) :: this +#ifdef __BSA_OMP + real(RDP), intent(in) :: bfm(:, :) + class(*), pointer, intent(in) :: pdata +#endif + end subroutine + + + end interface + +end module BsaLib_MTriangZone \ No newline at end of file diff --git a/src/BsaLib/bsa/meshing/zones/MTriangZoneImpl.f90 b/src/BsaLib/bsa/meshing/zones/MTriangZoneImpl.f90 new file mode 100644 index 0000000..bcee130 --- /dev/null +++ b/src/BsaLib/bsa/meshing/zones/MTriangZoneImpl.f90 @@ -0,0 +1,2376 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib_MTriangZone) BsaLib_MTriangZoneImpl + +#include "../../../precisions" + +! #ifndef BSA_M3MF_ONLY_PREMESH_ +! # define BSA_M3MF_ONLY_PREMESH_ 0 +! #else +! # if (BSA_M3MF_ONLY_PREMESH_ != 0 && BSA_M3MF_ONLY_PREMESH_ != 1) +! # undef BSA_M3MF_ONLY_PREMESH_ +! # define BSA_M3MF_ONLY_PREMESH_ 0 +! # endif +! #endif + + use BsaLib_Data, only: bsa_Abort + use BsaLib_IO, only: INFOMSG, WARNMSG, ERRMSG, MSGCONT, DBGMSG, NOTEMSG + implicit none + + +contains + + + + !> Default MTriangZone basic constructor + module function MTriangZone_constr_def(name) result(this) + character(len = *), intent(in), optional :: name + type(MTriangZone_t) :: this + + if (present(name)) call this%zoneName(name) + end function + + + + + !> Gets rect base along I-dir + module elemental function baseI_triang(this) result(res) + class(MTriangZone_t), intent(in) :: this + real(RDP) :: res + + res = getPointsDistance(this%Cpt_, this%Bpt_) + end function + + + !> Gets rect base along J-dir + module elemental function baseJ_triang(this) result(res) + class(MTriangZone_t), intent(in) :: this + real(RDP) :: res + + res = getPointsDistance(this%Cpt_, this%Apt_) + end function + + + + + module subroutine deduceDeltas_triang(this) + class(MTriangZone_t), intent(inout) :: this + + ! NOTE: do nothing + ! DON JUST BECAUSE WE NEED TO IMPLEMENT THIS + ! METHOD SINCE IT IS AN ABSTRACT COMING FROM + ! PARENT CLASS. + end subroutine + + + + + + !> Returns total N of zone's meshing points. + !> NOTE: for the moment, ONLY triangles rectangles supported + !> NOTE: overrides default inherited from parent class. + module pure function zoneTotNPts_triang(this) result(npt) + class(MTriangZone_t), intent(in) :: this + integer :: npt + + npt = this%ni_ * this%ni_ + + ! BUG: might cast to real and back to int ?? + npt = (npt + this%ni_ ) / 2 + end function + + + + + + !> Computes PAB angle, using "cosine" rule. + !> NOTE: this only works if Cpt is the point at which + !> the wider angle is located! + module subroutine setPABangle(this) + class(MTriangZone_t), intent(inout) :: this + + real(RDP) :: CA, AB, CB, cang + + CA = getPointsDistance(this%Cpt_, this%Apt_) + AB = getPointsDistance(this%Apt_, this%Bpt_) + CB = getPointsDistance(this%Cpt_, this%Bpt_) + + cang = (CA*CA + AB*AB - CB*CB) / (2 * CA * AB) + this%PABang_ = acos(cang) + end subroutine + + + + + !> Used if we want some specific deltas + !> along I and J directions + module subroutine adaptToDeltas(this, dfi, dfj) + class(MTriangZone_t), intent(inout) :: this + real(RDP), value :: dfi, dfj + + real(RDP) :: CA, CB + integer :: ni, nj + + CA = this%baseJ() + CB = this%baseI() + + ! n. of segments + ni = floor(CB / dfi) + nj = floor(CA / dfj) + + ! BUG: is this necessary?? + ! readapt deltas to fit in FIXED sides (bases) + dfi = CB / ni + dfj = CA / nj + + ! now get actual n. of points (refinements) + this%ni_ = ni + 1 + this%nj_ = nj + 1 + end subroutine + + + + + + !> BUG: this routine might hide a bug. + !> + !> Deduce triangle zone rotation, knowing the + !> coordinates of the 3 triang points. + !> + !> Still, triangle rotation is given by the rotation + !> needed to be done to reach the CA side, starting from + !> Y positive axis of the GRS. + module subroutine deduceRotation(this) + class(MTriangZone_t), intent(inout) :: this + + real(RDP) :: dx, dy, ang + + ! BUG: not always 0 when supposed to. + ! machine precision + finite floating point repr instabilities + ! NOTE: do not call distance methods + ! since WE WANT TO KEEP SIGNS. + dx = this%Apt_%freqI() - this%Cpt_%freqI() + dy = this%Apt_%freqJ() - this%Cpt_%freqJ() + + ang = atan(abs(dx) / abs(dy)) + + if (.not. (dx >= 0._RDP .and. dy >= 0._RDP)) then ! NOT 1st quadrant + + if (dy < 0._RDP) then + + if (dx >= 0._RDP) then ! 2nd quadrant + + ang = CST_PIGREC - ang + else ! 3rd quadrant + + ang = CST_PIGREC + ang + endif + + else ! 4th quadrant + + ! BUG: precision instability. + ! Tru to mitigate it, vary bad!! + if (ang > 1e-14_RDP) then ! fixed tolerance acceptance + + ang = CST_PIt2 - ang + else ! assume it 0 + + ang = 0._RDP + endif + endif + endif + + this%rot_ = ang + end subroutine deduceRotation + + + + + + !> Gets actua points' delta increments based on this zone's + !> rotation w.r.t GRS, when moving along the mesh. + !> If NOT inverted: + !> - df_var : total delta along CA side (J-dir in LRS) + !> - df_cst : total delta along CB side (I-dir in LRS) + module subroutine getRotatedUnaryDF(this, df_I_var, df_J_var, df_I_cst, df_J_cst) + class(MTriangZone_t), intent(inout) :: this + real(RDP), intent(out) :: df_I_var, df_J_var + ! logical, intent(in), optional :: invert + real(RDP), intent(out), optional :: df_I_cst, df_J_cst + + logical :: do_invert = .false. + + real(RDP) :: ang + + + if (present(df_I_cst) .and. present(df_J_cst)) do_invert = .true. + + + if (this%rot_ <= CST_PId2) then ! 1st quadrant + + df_I_var = sin(this%rot_) + df_J_var = cos(this%rot_) + + elseif (this%rot_ <= CST_PIGREC) then ! 2nd quadrant + + ang = this%rot_ - CST_PId2 + df_I_var = cos(ang) + df_J_var = - sin(ang) + + elseif (this%rot_ <= CST_PIt3d2) then ! 3rd quadrant + + ang = this%rot_ - CST_PIGREC + df_I_var = - sin(ang) + df_J_var = - cos(ang) + + elseif (this%rot_ <= CST_PIt2) then ! 4th quadrant + + ang = this%rot_ - CST_PIt3d2 + df_I_var = - cos(ang) + df_J_var = sin(ang) + + endif + + ! BUG: needed to avoid machine rounding precision + if (abs(df_I_var) < MACHINE_PRECISION) df_I_var = 0._RDP + if (abs(df_J_var) < MACHINE_PRECISION) df_J_var = 0._RDP + + + if (do_invert) then ! BUG: ????????? + + df_I_cst = df_J_var + df_J_cst = - df_I_var + + ! BUG: needed to avoid machine rounding precision + if (abs(df_I_cst) < MACHINE_PRECISION) df_I_cst = 0._RDP + if (abs(df_J_cst) < MACHINE_PRECISION) df_J_cst = 0._RDP + endif + + end subroutine getRotatedUnaryDF + + + + + + + + + + !> Defines a triang zone from 3 triang points. + !> No need to specify which one is A or B point, this is + !> automatically deduced. + !> Automatically choses refinements definition. + module subroutine defineFromPts_norm(this, Cp, P1, P2) + class(MTriangZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: Cp, P1, P2 + + if (this%ni_ == 0 .or. this%nj_ == 0) & + call bsa_Abort('Missing refinement information. Aborting.') + + + block + integer :: ni, nj + character(len = *), parameter :: msg_segm = & + ERRMSG//'Triangle collapsed into a segment. Aborting.' + + ni = this%ni_ + nj = this%nj_ + + + ! Try to deduce which one is A and B points. + ! NOTE: this relies on the fact that we know + ! a priori which is the corner point. + if (P1%freqJ() > P2%freqJ() .or. P1%freqJ() < P2%freqJ()) then ! NE, E, SE || SW, W, NW + + this%Apt_ = P1 + this%Bpt_ = P2 + + else ! same FJ + + if (P1%freqJ() > Cp%freqJ()) then ! w2 > 0 + + if (P1%freqI() < P2%freqI()) then + + this%Apt_ = P1 + this%Bpt_ = P2 + + elseif (P2%freqI() < P1%freqI()) then + + this%Apt_ = P2 + this%Bpt_ = P1 + else + call bsa_Abort(msg_segm) + endif + + elseif (P1%freqJ() < Cp%freqJ()) then ! w2 < 0 + + if (P1%freqI() > P2%freqI()) then + + this%Apt_ = P1 + this%Bpt_ = P2 + + elseif (P2%freqI() > P1%freqI()) then + + this%Apt_ = P2 + this%Bpt_ = P1 + else + call bsa_Abort(msg_segm) + endif + + else + call bsa_Abort('Three points are aligned on the same line. Aborting.') + endif + endif + + end block + + + ! NOTE: make a copy + this%Cpt_ = MPoint(Cp) + + call this%setPABangle() + call this%deduceRotation() + + end subroutine defineFromPts_norm + + + + + + + + + + !> Defines a triang zone from 3 triang points. + !> No need to specify which one is A or B point, this is + !> automatically deduced. + !> Also, possible to specify either a value. + !> If "is_refinement", then is either refinement along I or J direction. + !> NOTE: this is the defult if no optional is passed. + !> + !> If "is_refinement" is false, but still a value is passed, + !> it is interpreted as a delta value, still along either I or J direction. + module subroutine defineFromPts_refmtsORdeltas(& + this, Cp, P1, P2, is_refinement, val_types, val1, val2) + class(MTriangZone_t), intent(inout) :: this + class(MPoint_t), intent(in) :: Cp, P1, P2 + logical, intent(in) :: is_refinement + character(len = *), intent(in), optional :: val_types + real(RDP), intent(in), optional :: val1, val2 + + integer :: ni, nj + real(RDP) :: dfi, dfj + + + if (is_refinement) then + + if (present(val_types) .and. present(val1) .and. present(val2)) then ! is present, acquire + + block + integer :: slen, i + + slen = len(val_types) + if (slen == 0 .or. slen > 2) & + call bsa_Abort('"val_types" is either empty or too long.') + + do i = 1, slen + + if (val_types(i:i) == 'i') then + + if (this%ni_ == 0) then ! we need to set it + if (i == 1) then + if (.not.(present(val1))) & + call bsa_Abort('Missing base information along I-dir') + ni = val1 + else ! == 2 + if (.not.(present(val2))) & + call bsa_Abort('Missing base information along I-dir') + ni = val2 + endif + this%ni_ = ni + endif + + elseif (val_types(i:i) == 'j') then + + if (this%nj_ == 0) then ! we need to set it + if (i == 1) then + if (.not.(present(val1))) & + call bsa_Abort('Missing base information along J-dir') + nj = val1 + else ! == 2 + if (.not.(present(val2))) & + call bsa_Abort('Missing base information along J-dir') + nj = val2 + endif + this%nj_ = nj + endif + + endif + enddo + + end block + + endif ! optional vals present + + + else ! use deltas + + + + if (.not. (present(val_types) .and. present(val1) .and. present(val2))) & + call bsa_Abort('Please provide both deltas.') + + + block + integer :: slen, i + + slen = len(val_types) + if (slen == 0 .or. slen > 2) & + call bsa_Abort('"val_types" is either empty or too long.') + + do i = 1, slen + + if (val_types(i:i) == 'i') then + + if (i == 1) then + if (.not.(present(val1))) & + call bsa_Abort('Missing delta information along I-dir') + dfi = val1 + else ! == 2 + if (.not.(present(val2))) & + call bsa_Abort('Missing delta information along I-dir') + dfi = val2 + endif + + elseif (val_types(i:i) == 'j') then + + if (i == 1) then + if (.not.(present(val1))) & + call bsa_Abort('Missing delta information along J-dir') + dfj = val1 + else ! == 2 + if (.not.(present(val2))) & + call bsa_Abort('Missing delta information along J-dir') + dfj = val2 + endif + + endif + enddo + end block + + endif ! use refinements / deltas + + ! Common definition. + call this%defineFromPts_norm(Cp, P1, P2) + + if (.not. is_refinement) call this%adaptToDeltas(dfi, dfj) + end subroutine defineFromPts_refmtsORdeltas + + + + + + + + + !> Computes a completely defined triang zone + module subroutine compute(this) + class(MTriangZone_t), intent(inout) :: this + + real(RDP) :: df_CA, df_CB + + + ! get (full) deltas in straight directions + df_CA = getPointsDistance(this%Cpt_, this%Apt_) ! base J + df_CB = getPointsDistance(this%Cpt_, this%Bpt_) ! base I + + + ! BUG: Allow for different triangle sides (NOT isosceles) + + ! BUG: it might be that they're not equal + ! when they should. So, no direct comparison + ! instead use MACHINE PRECISION + if (abs(df_CA - df_CB) <= MACHINE_PRECISION) then + call computeISOTriangle(this) + else + call bsa_Abort('Triangle must be "isosceles". Aborting.') + endif + end subroutine compute + + + + + subroutine computeISOTriangle(this) + use BsaLib_Data, only: & + dimM_bisp_, getBFM_msh, settings & + , m3mf_msh_ptr_, msh_NZones, msh_bfmpts_pre_ + class(MTriangZone_t), intent(inout) :: this + + if (this%ni_ /= this%nj_) & + call bsa_Abort('Different sides'' refinements not yet allowed. Aborting.') + + block + integer :: Np, Np_m1, Nj_m1 + real(RDP) :: df_CA, df_CST, dfMAJi, dfMAJj, dfMINi, dfMINj + + integer :: id, i, j + real(RDP) :: base_fi, base_fj, fi, fj + + integer :: tot + real(RDP), allocatable :: bfm(:, :) + +#ifdef BSA_M3MF_ONLY_PREMESH_ + real(RDP) :: dw, ctr_infl, brd_infl, vtx_infl_rect, vtx_infl_triang + real(RDP), allocatable :: intg(:) +#endif + + type(MPoint_t) :: pt + + ! caching + Np = this%ni_ + + ! tot = (Np*Np + Np) / 2 + tot = Np*Np + tot = tot + Np + tot = tot / 2 + + Np_m1 = Np - 1 + Nj_m1 = Np_m1 + + + ! get unary delta freq increments in both I and J directions + ! get (full) deltas in straight directions + df_CA = getPointsDistance(this%Cpt_, this%Apt_) ! base J + df_CST = df_CA / Np_m1 + call this%getRotatedUnaryDF(dfMAJi, dfMAJj, dfMINi, dfMINj) + + ! get actualised values + dfMAJi = dfMAJi * df_CST + dfMAJj = dfMAJj * df_CST + dfMINi = dfMINi * df_CST + dfMINj = dfMINj * df_CST + +#ifdef BSA_M3MF_ONLY_PREMESH_ + ! influences for integration + dw = df_CST * CST_PIt2 + ctr_infl = dw * dw + brd_infl = ctr_infl / 2._RDP + vtx_infl_rect = brd_infl / 2._RDP + vtx_infl_triang = vtx_infl_rect / 2._RDP + + allocate(intg(dimM_bisp_)) +#endif + allocate(bfm(dimM_bisp_, tot)) + + + !======================================================= + ! + ! FIRST COLUMN (CA side) + ! + + ! track base points + base_fi = this%Cpt_%freqI() + base_fj = this%Cpt_%freqJ() + + ! first line + fi = base_fi + fj = base_fj + bfm(:, 1) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg = bfm(:, 1) * vtx_infl_rect +#endif + + ! internal lines + ! NOTE: since is beginning, we can use j directly + ! to index into bfm. + do j = 2, Nj_m1 + + fi = fi + dfMAJi + fj = fj + dfMAJj + bfm(:, j) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg = intg + bfm(:, j) * brd_infl +#endif + enddo + + ! last line + fi = fi + dfMAJi + fj = fj + dfMAJj + pt = MPoint(fi, fj) + + if (.not. pt == this%Apt_) & + call bsa_Abort('First end point does not match triang A point. Aborting.') + + id = j + bfm(:, id) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg = intg + bfm(:, id) * vtx_infl_triang +#endif + + + + !======================================================= + ! + ! INTERNAL COLUMNS (Parallel to CA) + ! + do i = 2, Np_m1 + + Nj_m1 = Nj_m1 - 1 + id = id + 1 + + base_fi = base_fi + dfMINi + base_fj = base_fj + dfMINj + + ! first line + fi = base_fi + fj = base_fj + bfm(:, id) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg = intg + bfm(:, id) * brd_infl +#endif + + ! internal lines + do j = 2, Nj_m1 + + id = id + 1 + fi = fi + dfMAJi + fj = fj + dfMAJj + bfm(:, id) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg = intg + bfm(:, id) * ctr_infl +#endif + enddo + + ! last line + id = id + 1 + fi = fi + dfMAJi + fj = fj + dfMAJj + bfm(:, id) = getBFM_msh(fi, fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg = intg + bfm(:, id) * brd_infl +#endif + enddo ! i + + + !======================================================= + ! + ! LAST COLUMN (B point !!) + ! + base_fi = base_fi + dfMINi + base_fj = base_fj + dfMINj + + pt = MPoint(base_fi, base_fj) + + if (.not. pt == this%Bpt_) & + call bsa_Abort('End point does not match B triang point. Aborting.') + + id = id + 1 + bfm(:, id) = getBFM_msh(base_fi, base_fj) +#ifdef BSA_M3MF_ONLY_PREMESH_ + intg = intg + bfm(:, id) * vtx_infl_triang +#endif + + +! #ifdef __BSA_DEBUG + if (.not. id == tot) & + call bsa_Abort('"id" does not equal tot N of Triang zone''s points.') +! #endif + + !$omp critical +#ifdef BSA_M3MF_ONLY_PREMESH_ + m3mf_msh_ptr_ = m3mf_msh_ptr_ + (intg * settings%i_bisp_sym_) ! update main integral +#endif + msh_NZones = msh_NZones + 1 ! update n. of zones count + msh_bfmpts_pre_ = msh_bfmpts_pre_ + tot ! update tot num of meshing points + + ! eventually, update zone with max N of points + if (tot > msh_max_zone_NPts) msh_max_zone_NPts = tot + + ! dump zone info + call DumpZone(this, bfm) + !$omp end critical + + end block + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @MTriangZoneImpl::computeISOTriangle() : init -- ok.' +! #endif + end subroutine computeISOTriangle + + + + + + + + !> Dumps a triang zone data for later reconstruction + module subroutine dumpTZ(this) + class(MTriangZone_t), intent(in) :: this + + write(unit_dump_bfm_) MZone_ID%TRIANGLE + + ! 3 pts + write(unit_dump_bfm_) this%Cpt_%freqI(), this%Cpt_%freqJ() + write(unit_dump_bfm_) this%Apt_%freqI(), this%Apt_%freqJ() + write(unit_dump_bfm_) this%Bpt_%freqI(), this%Bpt_%freqJ() + + ! NOTE: useless, since rot might reconstructed from points + write(unit_dump_bfm_) this%rot_ + write(unit_dump_bfm_) this%ni_, this%nj_ + +#ifdef __BSA_ZONE_DEBUG + write(unit=4533, fmt=*) & + 'Refms at TZ=', trim(this%name_), this%ni_, this%nj_, & + 'thread id= ', omp_get_thread_num() +#endif + end subroutine dumpTZ + + + + + !> Undumps a triang zone data for later reconstruction + module subroutine undumpTZ(this) + class(MTriangZone_t), intent(inout) :: this + real(RDP) :: rval1, rval2 + + ! 3 pts + read(unit_dump_bfm_) rval1, rval2 + call this%Cpt_%setFreqs(rval1, rval2) + + read(unit_dump_bfm_) rval1, rval2 + call this%Apt_%setFreqs(rval1, rval2) + + read(unit_dump_bfm_) rval1, rval2 + call this%Bpt_%setFreqs(rval1, rval2) + + + read(unit_dump_bfm_) this%rot_ + read(unit_dump_bfm_) this%ni_, this%nj_ + end subroutine undumpTZ + + + + + !> Implementation of triang zone interpolation methods + module subroutine interpolateTZ( this & +#ifdef __BSA_OMP + , bfm, pdata & +#endif + & ) + class(MTriangZone_t), intent(inout) :: this +#ifdef __BSA_OMP + real(RDP), intent(in) :: bfm(:, :) + class(*), pointer, intent(in) :: pdata + + ! NOTE: for the moment only supporting HTPC method + call interpolateTZ_HTPC_v3(this, bfm, pdata) +#else + call interpolateTZ_HTPC_v3(this) +#endif + end subroutine + + + + + + !> Queries Triang zone n of points if it had ni/nj refinements + elemental function getTriangZoneEquivNPts(ni, nj) result(npt) + integer, intent(in) :: ni, nj + integer :: npt + + ! NOTE: for the moment ni==nj + npt = ni * nj + + ! BUG: might cast to real and back to int ?? + npt = (npt + ni) / 2._RDP + end function + + + + + !> Implementation of HTPC interpolation method for a rectangle zone, + !> including MultiLevel-Refinement for BFM data. + subroutine interpolateTZ_HTPC_v3( this & +#ifdef __BSA_OMP + , bfm_undump, pdata & +#endif + & ) + use BsaLib_Data, only: & +#ifndef __BSA_OMP + bfm_undump, & +#endif + dimM_bisp_, getBFM_msh, getBRM_msh, m3mf_msh_ptr_, m3mr_msh_ptr_, settings & + , msh_bfmpts_post_, msh_brmpts_post_ & + , write_brm_fptr_, do_export_brm_, BrmExportBaseData_t + + class(MTriangZone_t), intent(inout) :: this +#ifdef __BSA_OMP + real(RDP), intent(in) :: bfm_undump(:, :) + class(*), pointer, intent(in) :: pdata +#endif + + integer :: interp_fact, njOld, njNew_piprev, njNew_picurr, njNew_tmp, njtmp + integer :: ni, nj, ni_bfm_ref_, nj_bfm_ref_ + integer :: nipI, nipJ, ipos, nPtsPost + integer :: i, ist, n_segs_bfm_ref_i_, n_segs_bfm_ref_j_ + integer :: n_pts_bfm_ref_i_, n_pts_bfm_ref_j_ + real(RDP) :: dfIi_bfm_lv0_, dfIj_bfm_lv0_, dfJi_bfm_lv0_, dfJj_bfm_lv0_ + real(RDP) :: dfIi_bfm_ref_, dfIj_bfm_ref_, dfJi_bfm_ref_, dfJj_bfm_ref_ + real(RDP) :: dfI_bfm_lv0_, dfJ_bfm_lv0_, dfI_bfm_ref_, dfJ_bfm_ref_, df_cst + real(RDP) :: dfIi_brm_interp, dfIj_brm_interp, dfJi_brm_interp, dfJj_brm_interp + real(RDP) :: dfI_brm_interp_, dfJ_brm_interp_, dw_cst, df_diag_old, df_diag_bfm_ref, df_diag_brm_interp + real(RDP) :: vtx_infl_r, brd_infl_r, ctr_infl_r, brd_infl_t, vtx_infl_t + + ! HTPC indexes + integer :: pIcurr, pIprev, pJhead, pJtail + + ! Pos in general BFM undumped data + integer :: i_bfm_old, i_bfm_ref_i, i_bfm_ref_j + integer :: i_brm, i_brm_shift, i_brm_offsetJ +#ifndef __BSA_OMP + integer :: i_brm_write_ +#endif + integer :: i_bfm_interpJ + + ! freqs + real(RDP) :: fi_baseptI, fj_baseptI, fi, fj, fi_baseptJ, fj_baseptJ +#ifdef __BSA_OMP + real(RDP), allocatable, dimension(:) :: fi_v_, fj_v_ +#endif + + real(RDP), allocatable :: bfm_new_left(:, :), bfm_new_right(:, :) + real(RDP), allocatable :: bfm_interp(:, :) + + real(RDP) :: dfJtail, dfJhead, dfIcurr, dfIprev, dfJ_oldtmp + real(RDP) :: bfmtail(dimM_bisp_), bfmhead(dimM_bisp_) + + real(RDP), allocatable :: brm(:, :) +#ifndef BSA_M3MF_ONLY_PREMESH_ + real(RDP) :: vtx_infl_r_bfm, brd_infl_r_bfm, ctr_infl_r_bfm, brd_infl_t_bfm, vtx_infl_t_bfm + real(RDP) :: intg_bfm(dimM_bisp_) +#endif + real(RDP) :: intg(dimM_bisp_) + + + ! BUG: for the moment, we take the max + ! such to ensure having the SAME n. of points + ! along both sides. + ! Later, consider supporting more general approach. + interp_fact = max(this%policy_%interp_I_fct_, this%policy_%interp_J_fct_) + + ! get unary delta freqs increments in I and J directions + ! (old BFM values, to be interpolated) + njOld = this%nj_ - 1 + df_cst = getPointsDistance(this%Cpt_, this%Apt_) / njOld + + ! NOTE: first two refer to MAJOUR direction (J), then MINOR (I) + call this%getRotatedUnaryDF(dfJi_bfm_lv0_, dfJj_bfm_lv0_, dfIi_bfm_lv0_, dfIj_bfm_lv0_) + + ! actualise them (scaled w.r.t actual sides' length) + dfIi_bfm_lv0_ = dfIi_bfm_lv0_ * df_cst + dfIj_bfm_lv0_ = dfIj_bfm_lv0_ * df_cst + dfJi_bfm_lv0_ = dfJi_bfm_lv0_ * df_cst + dfJj_bfm_lv0_ = dfJj_bfm_lv0_ * df_cst + + dfI_bfm_lv0_ = df_cst + dfJ_bfm_lv0_ = df_cst + + ! get n. of BFM refinement segments (between two old ones) + n_segs_bfm_ref_i_ = 1 ! original + n_segs_bfm_ref_j_ = 1 + do i = 1, this%policy_%n_interp_bfm_lvs_ + n_segs_bfm_ref_i_ = n_segs_bfm_ref_i_ * this%policy_%interp_bfm_I_fct_ + n_segs_bfm_ref_j_ = n_segs_bfm_ref_j_ * this%policy_%interp_bfm_J_fct_ + enddo + n_pts_bfm_ref_i_ = n_segs_bfm_ref_i_ - 1 + n_pts_bfm_ref_j_ = n_segs_bfm_ref_j_ - 1 + + ! get refined (BFM) deltas (GRS) + dfIi_bfm_ref_ = dfIi_bfm_lv0_ / n_segs_bfm_ref_i_ + dfIj_bfm_ref_ = dfIj_bfm_lv0_ / n_segs_bfm_ref_i_ + dfJi_bfm_ref_ = dfJi_bfm_lv0_ / n_segs_bfm_ref_j_ + dfJj_bfm_ref_ = dfJj_bfm_lv0_ / n_segs_bfm_ref_j_ + + + ! get BRM interpolated deltas (GRS) (taken from refined BFM deltas this time) + dfIi_brm_interp = dfIi_bfm_ref_ / interp_fact + dfIj_brm_interp = dfIj_bfm_ref_ / interp_fact + dfJi_brm_interp = dfJi_bfm_ref_ / interp_fact + dfJj_brm_interp = dfJj_bfm_ref_ / interp_fact + + + ! get absolute deltas (in LRS), along I and J directions + dfI_bfm_ref_ = dfI_bfm_lv0_ / n_segs_bfm_ref_i_ + dfI_brm_interp_ = dfI_bfm_ref_ / interp_fact + + dfJ_bfm_ref_ = dfJ_bfm_lv0_ / n_segs_bfm_ref_j_ + dfJ_brm_interp_ = dfJ_bfm_ref_ / interp_fact + + +#ifndef BSA_M3MF_ONLY_PREMESH_ + ! influence areas for BRM integration + dw_cst = dfI_bfm_ref_ * CST_PIt2 + ctr_infl_r_bfm = dw_cst * dw_cst + brd_infl_r_bfm = ctr_infl_r_bfm / 2._RDP + vtx_infl_r_bfm = brd_infl_r_bfm / 2._RDP + brd_infl_t_bfm = brd_infl_r_bfm + vtx_infl_t_bfm = vtx_infl_r_bfm / 2._RDP +#endif + + ! influence areas for BRM integration + dw_cst = dfI_brm_interp_ * CST_PIt2 + ctr_infl_r = dw_cst * dw_cst + brd_infl_r = ctr_infl_r / 2._RDP + vtx_infl_r = brd_infl_r / 2._RDP + brd_infl_t = brd_infl_r + vtx_infl_t = vtx_infl_r / 2._RDP + + ! get actualised BFM-refined and BRM-interp refinements (along borders) + ni_bfm_ref_ = (this%ni_ - 1) + nj_bfm_ref_ = (this%nj_ - 1) + + ! take a backup since this will be decremented by one each time we move pi_curr + njOld = nj_bfm_ref_ + + ni = ni_bfm_ref_ * (n_segs_bfm_ref_i_ * interp_fact) + 1 + nj = nj_bfm_ref_ * (n_segs_bfm_ref_j_ * interp_fact) + 1 + ni_bfm_ref_ = ni_bfm_ref_ * n_segs_bfm_ref_i_ + 1 + nj_bfm_ref_ = nj_bfm_ref_ * n_segs_bfm_ref_j_ + 1 + + njNew_picurr = nj + + ! number of BRM points to interpolate (insert) + ! between two know BFM (refined) points' direction lines. + nipI = interp_fact - 1 + nipJ = nipI + + i_brm_offsetJ = nipI * nj + + ! TODO: deltas along the hypotenuse + ! Last section when moving pj_head + df_diag_old = sqrt(dfI_bfm_lv0_**2 + dfJ_bfm_lv0_**2) + df_diag_bfm_ref = df_diag_old / n_segs_bfm_ref_i_ + df_diag_brm_interp = df_diag_bfm_ref / interp_fact + + ! allocate data + nPtsPost = getTriangZoneEquivNPts(ni, nj) + allocate(brm(dimM_bisp_, nPtsPost), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""brm"" in interpolating RZ.") + brm = 0._RDP + + allocate(bfm_new_left(dimM_bisp_, nj), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""bfm_new_left"" in interpolating RZ.") + bfm_new_left = 0._RDP + + allocate(bfm_new_right(dimM_bisp_, nj - nipJ - 1), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""bfm_new_right"" in interpolating RZ.") + bfm_new_right = 0._RDP + + allocate(bfm_interp(dimM_bisp_, nj), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""bfm_interp"" in interpolating RZ.") + bfm_interp = 0._RDP + + +#ifdef __BSA_OMP + allocate(fi_v_(nPtsPost), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""fi"" in interpolating RZ.") + fi = 0._RDP + + allocate(fj_v_(nPtsPost), stat=ist) + if (ist /= 0) call bsa_Abort("Error allocating ""fj"" in interpolating RZ.") + fj = 0._RDP + +# define __FREQ_I_ fi_v_(i_brm) = fi +# define __FREQ_J_ fj_v_(i_brm) = fj +# define __FREQ_I_shift_ fi_v_(i_brm_shift) = fi +# define __FREQ_J_shift_ fj_v_(i_brm_shift) = fj +# define __PDATA ,pdata + if (do_export_brm_ .and. associated(pdata)) then + select type (pdata) + class is (BrmExportBaseData_t) + pdata%nI_ = ni + pdata%nJ_ = nj + end select + endif + +#else + +! # define __FREQ_I_ +! # define __FREQ_J_ +# define __FREQ_I_shift_ +# define __FREQ_J_shift_ +# define __PDATA ,null() + +#endif + + + ! before starting, interpolate very first column + ! along J dir, to get new mesh from old + ! Then for all the others, it will be done inside + ! the loop over the NI (old) points of the old mesh. + ! NOTE: integrate as well. + + ! init point vertex + fi_baseptI = this%Cpt_%freqI() + fj_baseptI = this%Cpt_%freqJ() + fi = fi_baseptI + fj = fj_baseptI + fi_baseptJ = fi + fj_baseptJ = fj + + bfmtail = bfm_undump(:, 1) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = bfmtail * vtx_infl_r_bfm +#endif + bfm_new_left(:, 1) = bfmtail + + brm(:, 1) = getBRM_msh(bfmtail, fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, 1) __PDATA) +#endif + intg = brm(:, 1) * vtx_infl_r + + i_brm = 1 + do pJhead = 2, this%nj_ ! loop on all OLD BFM saved points (J-dir) + + do i_bfm_ref_j = 1, n_pts_bfm_ref_j_ ! loop on all REF BFM pts between 2 old. + + ! compute head + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + bfmhead = getBFM_msh(fi_baseptJ, fj_baseptJ) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * brd_infl_r_bfm +#endif + + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ ! interp (J-dir) between tail-head + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + ! NOTE: save BFM for later use. + i_brm = i_brm + 1 + bfm_new_left(:, i_brm) = (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * brd_infl_r ! NOTE: it is a border point + enddo + + ! treat head (new BFM refined point) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + +#ifdef __BSA_DEBUG + ! DEBUG: they should equate fi/fj_baseptI!! + if (abs(fi - fi_baseptJ) > MACHINE_PRECISION .or. & + abs(fj - fj_baseptJ) > MACHINE_PRECISION) & + call bsa_Abort(& + 'BAD (1): fi or fj at the end of a BFM ref segment does not coincide..') +#endif + + i_brm = i_brm + 1 + bfm_new_left(:, i_brm) = bfmhead + brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + ! NOTE: it is a border point, except for the very last one (VERTEX) + intg = intg + brm(:, i_brm) * brd_infl_r + + bfmtail = bfmhead + enddo ! n. of (exact) ref points for BFM + + ! + ! NOTE: now new head is OLD BFM (next) point! + ! + bfmhead = bfm_undump(:, pJhead) ! OK because we stored it NJ majour. +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * brd_infl_r_bfm +#endif + +#ifdef __BSA_DEBUG + ! DEBUG: + if (n_pts_bfm_ref_j_ > 0) then + if (abs((fi_baseptI + (dfJi_bfm_lv0_*(pJhead-1))) - (fi_baseptJ + dfJi_bfm_ref_)) > MACHINE_PRECISION .or. & + abs((fj_baseptI + (dfJj_bfm_lv0_*(pJhead-1))) - (fj_baseptJ + dfJj_bfm_ref_)) > MACHINE_PRECISION) & + call bsa_Abort(& + 'BAD (2-t): fi or fj at the end of a BFM ref segment does not coincide..') + endif +#endif + + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ ! interp (J-dir) between tail-head + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + ! NOTE: save it for later use. + i_brm = i_brm + 1 + bfm_new_left(:, i_brm) = (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * brd_infl_r ! NOTE: it is a border point + enddo ! pJtail = 1, nipJ + + ! here, treat head, TAIL==HEAD (head - old mesh) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_brm = i_brm + 1 + bfm_new_left(:, i_brm) = bfmhead + brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + + ! NOTE: it is a border point, except for the very last one (VERTEX) + intg = intg + brm(:, i_brm) * brd_infl_r + + ! old head (old mesh) becomes new tail + ! TODO: we could change bfmhead here, so that + ! it might be already ready for next loop. + bfmtail = bfmhead + + ! NOTE: set new bfm ref base freqs as (current) head (old-mesh) point + fi_baseptJ = fi + fj_baseptJ = fj + enddo ! pJhead = 2, this%nj_ + + ! NOTE: removing excess contribution for last HEAD (VERTEX) + intg = intg + brm(:, i_brm) * (vtx_infl_t - brd_infl_r) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm - bfmtail * vtx_infl_t_bfm +#endif + + + + ! + i_bfm_old = this%nj_ + + do pIcurr = 2, this%ni_ ! loop on all OLD BFM infl lines (I-dir) + + ! before doing any computation, + ! we need to interpolate BFM along J + ! at new CURRENT (I) infl line (including ref infl lines) + ! NOTE: once we go through, integrate as well. + + do i_bfm_ref_i = 1, n_pts_bfm_ref_i_ ! loop on all REF BFM pts between 2 old (I-dir) + + ! computing BRM offset from pi_prev and pi_curr infl lines. + i_brm_shift = i_brm + njNew_tmp = njNew_picurr + do pJhead = 1, nipI + njNew_tmp = njNew_tmp - 1 + i_brm_shift = i_brm_shift + njNew_tmp + enddo +#ifndef __BSA_OMP + i_brm_write_ = i_brm_shift +#endif + + ! reset freqs to point to new base -> prev base moved by ref deltas! + ! (now pi_prev-pj_tail) + ! NOTE: still keep prev base in memory here since they might serve later. + fi_baseptJ = fi_baseptI + dfIi_bfm_ref_ ! reset J bases to match next I + fj_baseptJ = fj_baseptI + dfIj_bfm_ref_ + fi = fi_baseptJ + fj = fj_baseptJ + + bfmtail = getBFM_msh(fi, fj) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmtail * brd_infl_r_bfm +#endif + bfm_new_right(:, 1) = bfmtail + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, 1), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + intg = intg + brm(:, i_brm_shift) * brd_infl_r + + ! + ! here is where we compute right infl-line (for I-dir interpolation) + ! + i_bfm_interpJ = 1 + do pJhead = 2, njOld ! loop on all OLD BFM saved points (J-dir) + + do i_bfm_ref_j = 1, n_pts_bfm_ref_j_ ! loop on all REF BFM pts between 2 old. + + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + bfmhead = getBFM_msh(fi_baseptJ, fj_baseptJ) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * ctr_infl_r_bfm +#endif + + ! once we moved head, restore init, distances from head/tail + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ ! interp (J-dir) between tail-head + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = & + (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for very last row -> BORDER + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + enddo ! pJtail = 1, nipJ + + ! tail in now head (new BFM refined point) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + +#ifdef __BSA_DEBUG + ! DEBUG: + if (abs(fi - fi_baseptJ) > MACHINE_PRECISION .or. & + abs(fj - fj_baseptJ) > MACHINE_PRECISION) & + call bsa_Abort(& + 'BAD (4-t): fi or fj at the end of a BFM ref segment does not coincide..') +#endif + + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = bfmhead + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for the very last one (BORDER) + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + + bfmtail = bfmhead + enddo ! n. of (exact) ref points for BFM + + ! here, treat head, TAIL==HEAD (old mesh, J-dir) + ! NOTE: it is a center point, except for the very last one (BORDER) + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + bfmhead = getBFM_msh(fi_baseptJ, fj_baseptJ) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * ctr_infl_r_bfm +#endif + + ! once we moved head, restore init, distances from head/tail + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = & + (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for very last row -> BORDER + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + enddo ! pJtail = 1, nipJ + + ! here treat this new head + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = bfmhead + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + + bfmtail = bfmhead ! old head becomes new tail + enddo ! pJhead = 2, njOld + + ! + ! Last segments + ! I.e. next BFM head (computed) lies on the hypotenuse + ! + do i_bfm_ref_j = 1, n_pts_bfm_ref_j_ - (i_bfm_ref_i - 1) + + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + bfmhead = getBFM_msh(fi_baseptJ, fj_baseptJ) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * ctr_infl_r_bfm +#endif + + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = & + (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + enddo + + ! here treat actual HEAD (last on diag line -> remove integral surplus) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = bfmhead + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + + bfmtail = bfmhead + enddo + + ! removing excess of very last HEAD, accounted as center, it is BORDER. + ! NOTE: even worse for very last HEAD which happens to be End point. + ! there, it is a VERTEX point. + ! However, it's the very last element in brm, we can remove it after. + intg = intg - brm(:, i_brm_shift) * brd_infl_t +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm - bfmtail * brd_infl_t_bfm +#endif + + + ! backup NJ new intrp n. of points for next iteration + ! NOTE: also, refers to NJ point at pi_curr J inlf line. + njNew_piprev = njNew_picurr + njNew_picurr = i_bfm_interpJ ! NOTE: at last iter, should be 1 + + + ! + ! Now INTERPOLATE along I-dir between left and right BFM infl lines. + ! + dfIcurr = dfI_bfm_ref_ ! reset I-dir CURR-PREV distances + dfIprev = 0._RDP + + dfJ_oldtmp = dfJ_bfm_lv0_ + njtmp = nipJ + do pIprev = 1, nipI ! interp (I-dir) between prev-curr + + ! bulk I-dir interpolation until pj_head section level. + ! Then, after treat that triang shaped zone separately. + + dfIprev = dfIprev + dfI_brm_interp_ + dfIcurr = dfIcurr - dfI_brm_interp_ + + bfm_interp(:, 1 : njNew_picurr) = & + ( bfm_new_left (:, 1 : njNew_picurr) * dfIcurr + & + bfm_new_right(:, 1 : njNew_picurr) * dfIprev ) / dfI_bfm_ref_ + + ! once we have the values, go through them to integrate + ! NOTE: reset base freqs pointers, this time moving them along INTERP mesh + fi = fi_baseptI + (dfIi_brm_interp * pIprev) + fj = fj_baseptI + (dfIj_brm_interp * pIprev) + + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, 1), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * brd_infl_r + + do pJtail = 2, njNew_picurr + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, pJtail), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * ctr_infl_r + enddo + + !============================================== + ! here we have to treat triang shaped zone. + ! NOTE: tmp head is interpolated along hypotenuse!! + bfmhead = (& + bfm_new_left (:, njNew_piprev) * (df_diag_brm_interp * pIprev) + & + bfm_new_right(:, njNew_picurr) * (df_diag_brm_interp * (nipI + 1 - pIprev)) ) / df_diag_bfm_ref + + ! once we have the head, continue interpolating along J between tail and tmp head + ! NOTE: everytime we move pi_prev, actual Nj points reduce by 1 + njtmp = njtmp - 1 + dfJ_oldtmp = dfJ_oldtmp - dfJ_brm_interp_ + dfJhead = dfJ_oldtmp + dfJtail = 0._RDP + ipos = njNew_picurr ! tail index position + do pJtail = 1, njtmp + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! NOTE: tail is stored in bfm_interp(:, njNew_picurr) + ipos = ipos + 1 + bfm_interp(:, ipos) = & + (bfmhead * dfJtail + dfJhead * bfm_interp(:, njNew_picurr)) / dfJ_oldtmp + + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, ipos), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * ctr_infl_r + enddo + + ! treat HEAD (on hypotenuse) separately + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfmhead, fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * vtx_infl_t + !============================================== + + enddo ! pIprev = 1, nipI (interp points along I dir) + + ! now update bases along I (CURR now, PREV next iteration!) + fi_baseptI = fi_baseptI + dfIi_bfm_ref_ + fj_baseptI = fj_baseptI + dfIj_bfm_ref_ + + +#ifndef __BSA_OMP + ! ! BUG: check this condition + ! if (njNew_picurr /= ((njOld - 1) * (nipJ + 1) + 1)) & + ! call bsa_Abort("""njNew_picurr"" does not match computed value.") + + fi = fi_baseptI + fj = fj_baseptI + do pIprev = 1, njNew_picurr + i_brm_write_ = i_brm_write_ + 1 + call write_brm_fptr_(fi, fj, brm(:, i_brm_write_), null()) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + enddo +#endif + + bfm_new_left(:, 1 : njNew_picurr) = bfm_new_right(:, 1 : njNew_picurr) + + ! once finished with this section (CURR-PREV), since we skip J column + ! at pi_curr infl line, we reset general BRM index to point to + ! previously shifted one. + i_brm = i_brm_shift + + ! njOld = njOld - 1 + + enddo ! BFM ref points along I dir + + + + ! + ! Here, right BFM infl line is one where we have old BFM mesh points ! + ! + + ! computing BRM offset from pi_prev and pi_curr J infl lines. + i_brm_shift = i_brm + njNew_tmp = njNew_picurr + do pJhead = 1, nipI + njNew_tmp = njNew_tmp - 1 + i_brm_shift = i_brm_shift + njNew_tmp + enddo +#ifndef __BSA_OMP + i_brm_write_ = i_brm_shift +#endif + + ! again, I bases refer to PREV infl line. + fi_baseptJ = fi_baseptI + dfIi_bfm_ref_ + fj_baseptJ = fj_baseptI + dfIj_bfm_ref_ + fi = fi_baseptJ + fj = fj_baseptJ + + i_bfm_old = i_bfm_old + 1 + bfmtail = bfm_undump(:, i_bfm_old) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmtail * brd_infl_r_bfm +#endif + bfm_new_right(:, 1) = bfmtail + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, 1), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + intg = intg + brm(:, i_brm_shift) * brd_infl_r + + ! compute right infl-line + i_bfm_interpJ = 1 + do pJhead = 2, njOld + + do i_bfm_ref_j = 1, n_pts_bfm_ref_j_ ! loop on all REF BFM pts between 2 old. + + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + bfmhead = getBFM_msh(fi_baseptJ, fj_baseptJ) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * ctr_infl_r_bfm +#endif + + ! once we moved head, restore init, distances from head/tail + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = & + (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for very last row -> BORDER + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + enddo ! pJtail = 1, nipJ + + ! tail in now head (new BFM refined point) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = bfmhead + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for the very last one (BORDER) + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + + bfmtail = bfmhead + enddo ! i_bfm_ref_j = 1, n_pts_bfm_ref_j_ + + ! next head is OLD BFM point + fi = fi_baseptJ + fj = fj_baseptJ + fi_baseptJ = fi_baseptJ + dfJi_bfm_ref_ + fj_baseptJ = fj_baseptJ + dfJj_bfm_ref_ + + i_bfm_old = i_bfm_old + 1 + bfmhead = bfm_undump(:, i_bfm_old) +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm + bfmhead * ctr_infl_r_bfm +#endif + + ! once we moved head, restore init distances from head/tail + dfJhead = dfJ_bfm_ref_ + dfJtail = 0._RDP + do pJtail = 1, nipJ + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + ! update actual distances head/tail + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! interpolation along J dir (between HEAD-TAIL) + ! NOTE: save it for later use. + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = & + (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_bfm_ref_ + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for very last row -> BORDER + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + enddo ! pJtail = 1, nipJ + + ! here, treat head, TAIL==HEAD + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_bfm_interpJ = i_bfm_interpJ + 1 + bfm_new_right(:, i_bfm_interpJ) = bfmhead + + i_brm_shift = i_brm_shift + 1 + brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + ! call write_brm_fptr_(fi, fj, brm(:, i_brm_shift), null()) + __FREQ_I_shift_ + __FREQ_J_shift_ + + ! NOTE: it is a center point, except for the very last one (BORDER) + intg = intg + brm(:, i_brm_shift) * ctr_infl_r + + ! old head becomes new tail + bfmtail = bfmhead + enddo ! pJhead + + ! removing excess of very last HEAD + ! accounted as center, it is BORDER + ! NOTE: even worse for very last HEAD which happens to be End point. + ! there, it is a VERTEX point. + ! However, it's the very last element in brm, we can remove it after. + intg = intg - brm(:, i_brm_shift) * brd_infl_t +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm - bfmtail * brd_infl_t_bfm +#endif + + + ! backup NJ new intrp n. of points for next iteration + ! NOTE: also, refers to NJ point at pi_curr J inlf line. + njNew_piprev = njNew_picurr + njNew_picurr = i_bfm_interpJ ! NOTE: at last iter, should be 1 + + + + + ! ok, here we now have BFM values (interpolated along J) + ! at CURR and PREV (I) index pointers. + ! We have to interpolate along I between CURR and PREV, i.e. + ! prev has to start moving toward CURR. + + dfIcurr = dfI_bfm_ref_ ! reset I-dir CURR-PREV distances + dfIprev = 0._RDP + dfJ_oldtmp = dfJ_bfm_ref_ + njtmp = nipJ + do pIprev = 1, nipI ! interpolate along I + + ! bulk I-dir interpolation until pj_head section level. + ! Then, after treat that triang shaped zone separately. + + dfIprev = dfIprev + dfI_brm_interp_ + dfIcurr = dfIcurr - dfI_brm_interp_ + + bfm_interp(:, 1 : njNew_picurr) = & + ( bfm_new_left (:, 1 : njNew_picurr) * dfIcurr + & + bfm_new_right(:, 1 : njNew_picurr) * dfIprev ) / dfI_bfm_ref_ + + ! once we have the values, go through them to integrate + ! NOTE: reset base freqs pointers, this time moving them along INTERP mesh + fi = fi_baseptI + (dfIi_brm_interp * pIprev) + fj = fj_baseptI + (dfIj_brm_interp * pIprev) + + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, 1), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * brd_infl_r + + do pJtail = 2, njNew_picurr + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, pJtail), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * ctr_infl_r + enddo + + !============================================== + ! here we have to treat triang shaped zone. + ! NOTE: tmp head is interpolated along hypotenuse!! + bfmhead = (& + bfm_new_left (:, njNew_piprev) * (df_diag_brm_interp * pIprev) + & + bfm_new_right(:, njNew_picurr) * (df_diag_brm_interp * (nipI + 1 - pIprev)) ) / df_diag_bfm_ref + + ! once we have the head, continue interpolating along J between tail and tmp head + ! NOTE: everytime we move pi_prev, actual Nj points reduce by 1 + njtmp = njtmp - 1 + dfJ_oldtmp = dfJ_oldtmp - dfJ_brm_interp_ + dfJhead = dfJ_oldtmp + dfJtail = 0._RDP + ipos = njNew_picurr ! tail index position + do pJtail = 1, njtmp + + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + + dfJtail = dfJtail + dfJ_brm_interp_ + dfJhead = dfJhead - dfJ_brm_interp_ + + ! NOTE: tail is stored in bfm_interp(:, njNew_picurr) + ipos = ipos + 1 + bfm_interp(:, ipos) = & + (bfmhead * dfJtail + dfJhead * bfm_interp(:, njNew_picurr)) / dfJ_oldtmp + + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfm_interp(:, ipos), fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * ctr_infl_r + enddo + + ! treat HEAD (on hypotenuse) separately + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + i_brm = i_brm + 1 + brm(:, i_brm) = getBRM_msh(bfmhead, fi, fj) +#ifdef __BSA_OMP + __FREQ_I_ + __FREQ_J_ +#else + call write_brm_fptr_(fi, fj, brm(:, i_brm), null()) +#endif + intg = intg + brm(:, i_brm) * vtx_infl_t + !============================================== + + enddo ! pIprev = 1, nipI + + + ! now we can update (PREV) base freqs to match CURR + ! NOTE: CURR J infl line has already been computed! + fi_baseptI = fi_baseptI + dfIi_bfm_ref_ + fj_baseptI = fj_baseptI + dfIj_bfm_ref_ + + +#ifndef __BSA_OMP + ! BUG: check this condition + if (njNew_picurr /= ((njOld - 1) * (nipJ + 1) + 1)) & + call bsa_Abort("""njNew_picurr"" does not match computed value.") + + fi = fi_baseptI + fj = fj_baseptI + do pIprev = 1, njNew_picurr + i_brm_write_ = i_brm_write_ + 1 + call write_brm_fptr_(fi, fj, brm(:, i_brm_write_), null()) + fi = fi + dfJi_brm_interp + fj = fj + dfJj_brm_interp + enddo +#endif + + + bfm_new_left(:, 1 : njNew_picurr) = bfm_new_right(:, 1 : njNew_picurr) + + + ! once finished with this section (CURR-PREV), since we skip J column + ! at pi_curr infl line, we reset general BRM index to point to + ! previously shifted one. + i_brm = i_brm_shift + + + njOld = njOld - 1 + + enddo ! pIcurr = 2, this%ni_ + + +! #ifdef __BSA_DEBUG + if (i_brm /= nPtsPost) & + call bsa_Abort('"i_bfm_old" does not equal rect zone''s n. of (interpolated) points.') +! #endif + + + ! removing overestimation for B point + ! NOTE: should be stored at very last index!! + intg = intg - brm(:, i_brm) * vtx_infl_t +#ifndef BSA_M3MF_ONLY_PREMESH_ + intg_bfm = intg_bfm - bfmtail * vtx_infl_t_bfm +#endif + + !$omp critical +#ifdef __BSA_OMP + call write_brm_fptr_(fi_v_, fj_v_, brm, pdata) +#endif + + msh_bfmpts_post_ = msh_bfmpts_post_ + getTriangZoneEquivNPts(ni_bfm_ref_, nj_bfm_ref_) + msh_brmpts_post_ = msh_brmpts_post_ + nPtsPost + +#ifndef BSA_M3MF_ONLY_PREMESH_ + m3mf_msh_ptr_ = m3mf_msh_ptr_ + (intg_bfm * settings%i_bisp_sym_) ! update main BFM integral +#endif + m3mr_msh_ptr_ = m3mr_msh_ptr_ + (intg * settings%i_bisp_sym_) ! update main BRM integral + !$omp end critical + + end subroutine interpolateTZ_HTPC_v3 + + + + + + + + + + + + + + + +! subroutine interpolateTZ_HTPC_v2(this) +! #ifdef __BSA_OMP +! use BsaLib_Data, only: dimM_bisp_, getBRM_msh, m3mr_msh_ptr_ +! #else +! use BsaLib_Data, only: dimM_bisp_, getBRM_msh, bfm_undump, m3mr_msh_ptr_ +! #endif +! class(MTriangZone_t), intent(inout) :: this + +! integer :: interp_fact, ni, nj, njOld, njNew_piprev, njNew_picurr, njNew_tmp, njtmp +! integer :: nipI, nipJ, zNintrpPts, ipos +! real(RDP) :: df_cst, dfIi_old, dfIj_old, dfJi_old, dfJj_old +! real(RDP) :: dfIi_interp, dfIj_interp, dfJi_interp, dfJj_interp +! real(RDP) :: dfI_old, dfJ_old, dfI_interp, dfJ_interp +! real(RDP) :: df_diag_old, df_diag_interp +! real(RDP) :: dw_cst +! real(RDP) :: vtx_infl_r, brd_infl_r, ctr_infl_r, brd_infl_t, vtx_infl_t + +! ! HTPC indexes +! integer :: picurr, piprev, pjhead, pjtail + +! !> Pos in general BFM undumped data +! integer :: i_bfm + +! ! BRM current position index tracker (general) +! integer :: i_brm, i_brm_shift + +! integer :: i_bfm_interpJ + + +! ! freqs +! real(RDP) :: base_fi, base_fj, fi, fj + + +! real(RDP), allocatable :: bfm_new_left(:, :), bfm_new_right(:, :) +! real(RDP), allocatable :: bfm_interp(:, :) + +! real(RDP) :: dfJtail, dfJhead, dfIcurr, dfIprev, dfJ_oldtmp +! real(RDP) :: bfmtail(dimM_bisp_), bfmhead(dimM_bisp_) + + +! real(RDP), allocatable :: brm(:, :) +! real(RDP) :: intg(dimM_bisp_) + + +! ! BUG: for the moment, we take the max +! ! such to ensure having the SAME n. of points +! ! along both sides. +! ! Later, consider supporting more general approach. +! interp_fact = max(this%policy_%interp_I_fct_, this%policy_%interp_J_fct_) + +! ! take a backup since this will be decremented by one +! ! each time we move pi_curr +! njOld = this%nj_ - 1 + + +! ! get unary delta freqs increments in I and J directions +! ! (old values, to be interpolated) +! df_cst = getPointsDistance(this%Cpt_, this%Apt_) / njOld + +! ! NOTE: first two refer to MAJOUR direction (J), then MINOR (I) +! call this%getRotatedUnaryDF(dfJi_old, dfJj_old, dfIi_old, dfIj_old) + +! ! actualise them +! dfIi_old = dfIi_old * df_cst +! dfIj_old = dfIj_old * df_cst +! dfJi_old = dfJi_old * df_cst +! dfJj_old = dfJj_old * df_cst + + +! ! get interpolated deltas (in GRS) +! dfIi_interp = dfIi_old / interp_fact +! dfIj_interp = dfIj_old / interp_fact +! dfJi_interp = dfJi_old / interp_fact +! dfJj_interp = dfJj_old / interp_fact + + + +! ! get absolute deltas (in LRS) along I and J directions +! ! NOTE: they refer to interpolation +! dfI_old = df_cst +! dfJ_old = df_cst +! dfI_interp = df_cst / interp_fact +! dfJ_interp = df_cst / interp_fact + + +! ! influence areas for integration +! dw_cst = dfI_interp * CST_PIt2 +! ctr_infl_r = dw_cst*dw_cst +! brd_infl_r = ctr_infl_r / 2._RDP +! vtx_infl_r = brd_infl_r / 2._RDP +! brd_infl_t = brd_infl_r +! vtx_infl_t = vtx_infl_r / 2._RDP + +! ! get actualised refinements (along borders) +! ni = (this%ni_ - 1) * interp_fact + 1 +! nj = njOld * interp_fact + 1 +! njNew_picurr = nj + + +! ! n of points to interpolate between two known points' direction lines +! ! Refers to the number of points (or equally the number of segments) +! ! that are contained between two known pre-meshed points +! ! TODO: use max ref to have same n of points along both sides +! nipI = interp_fact - 1 +! nipJ = nipI + +! ! TODO: deltas along the hypotenuse +! ! Last section when moving pj_head +! df_diag_old = sqrt(dfI_old**2 + dfJ_old**2) +! df_diag_interp = df_diag_old / interp_fact + + +! ! allocate data +! zNintrpPts = getTriangZoneEquivNPts(ni, nj) +! allocate(brm(dimM_bisp_, zNintrpPts)) +! brm = 0._RDP + + +! ! NOTE: allocate intil before-last section. +! ! Keep upper triang shaped zone out +! ! treating it seperately. +! ! This means that we have to take one interp section +! ! out from allocation. +! ! NOTE: however, or left, needed to store nj values, +! ! since at first iteration along J, we have +! ! nj point. Not optimal.. +! ! NOTE: 0 assignment is like memset() in C. +! allocate(bfm_new_left(dimM_bisp_, nj)) +! bfm_new_left = 0._RDP +! allocate(bfm_new_right(dimM_bisp_, nj - nipJ - 1)) +! bfm_new_right = 0._RDP + +! allocate(bfm_interp, source=bfm_new_left) +! bfm_interp = 0._RDP + + + + +! ! before starting, interpolate very first column +! ! along J dir, to get new mesh from old +! ! Then for all the others, it will be done inside +! ! the loop over the NI (old) points of the old mesh. +! ! NOTE: integrate as well. + +! ! init point vertex +! base_fi = this%Cpt_%freqI() +! base_fj = this%Cpt_%freqJ() +! fi = base_fi +! fj = base_fj +! bfmtail = bfm_undump(:, 1) +! bfm_new_left(:, 1) = bfmtail +! brm(:, 1) = getBRM_msh(bfm_new_left(:, 1), base_fi, base_fj) +! intg = brm(:, 1) * vtx_infl_r + +! i_brm = 1 +! do pjhead = 2, this%nj_ + +! ! OK because we stored irt NJ majour. +! bfmhead = bfm_undump(:, pjhead) + +! ! once we moved head, restore init +! ! distances from head/tail +! dfJhead = dfJ_old +! dfJtail = 0._RDP + +! do pjtail = 1, nipJ + +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp + +! ! update actual distances head/tail +! dfJtail = dfJtail + dfJ_interp +! dfJhead = dfJhead - dfJ_interp + +! ! interpolation along J dir (between HEAD-TAIL) +! ! NOTE: save it for later use. +! i_brm = i_brm + 1 +! bfm_new_left(:, i_brm) = (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_old +! brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) + +! ! NOTE: it is a border point +! intg = intg + brm(:, i_brm) * brd_infl_r +! enddo ! pjtail = 1, nipJ + +! ! here, treat head, TAIL==HEAD +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp + +! i_brm = i_brm + 1 +! bfm_new_left(:, i_brm) = bfmhead +! brm(:, i_brm) = getBRM_msh(bfm_new_left(:, i_brm), fi, fj) + +! ! NOTE: it is a border point, except for the very last one (VERTEX_t) +! intg = intg + brm(:, i_brm) * brd_infl_r + +! ! old head becomes new tail +! ! TODO: we could change bfmhead here, so that +! ! it might be already ready for next loop. +! bfmtail = bfmhead +! enddo + +! ! NOTE: removing excess contribution for last HEAD (VERTEX_t) +! intg = intg + brm(:, i_brm) * (vtx_infl_t - brd_infl_r) + +! i_bfm = this%nj_ + + +! ! NOTE: starting from 2 because we have to take +! ! infl lines in consequent groups of two. +! do picurr = 2, this%ni_ + +! ! before doing any computation, +! ! we need to interpolate BFM along J +! ! at new CURRENT (I) infl line +! ! NOTE: once we go through, integrate as well. + + +! ! computing BRM offset. +! ! NOTE: njNew_picurr refers at NJ points in the new mesh +! ! at pi_prev infl line (along J). +! i_brm_shift = i_brm +! njNew_tmp = njNew_picurr +! do pjhead = 1, nipI +! njNew_tmp = njNew_tmp - 1 +! i_brm_shift = i_brm_shift + njNew_tmp +! enddo + + +! ! reset freqs to point to new base -> prev base moved by old deltas! +! ! (now pi_prev-pj_tail) +! ! NOTE: still keep prev base in memory here since they might serve later. +! fi = base_fi + dfIi_old +! fj = base_fj + dfIj_old + +! i_bfm = i_bfm + 1 +! bfmtail = bfm_undump(:, i_bfm) +! bfm_new_right(:, 1) = bfmtail + +! i_brm_shift = i_brm_shift + 1 +! ! brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, 1), base_fi, base_fj) +! brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, 1), fi, fj) +! intg = intg + brm(:, i_brm_shift) * brd_infl_r + +! i_bfm_interpJ = 1 +! do pjhead = 2, njOld + +! i_bfm = i_bfm + 1 +! bfmhead = bfm_undump(:, i_bfm) + +! ! once we moved head, restore init +! ! distances from head/tail +! dfJhead = dfJ_old +! dfJtail = 0._RDP + + +! do pjtail = 1, nipJ + +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp + +! ! update actual distances head/tail +! dfJtail = dfJtail + dfJ_interp +! dfJhead = dfJhead - dfJ_interp + +! ! interpolation along J dir (between HEAD-TAIL) +! ! NOTE: save it for later use. +! i_bfm_interpJ = i_bfm_interpJ + 1 +! bfm_new_right(:, i_bfm_interpJ) = & +! (bfmhead * dfJtail + bfmtail * dfJhead) / dfJ_old + +! i_brm_shift = i_brm_shift + 1 +! brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + +! ! NOTE: it is a border point +! intg = intg + brm(:, i_brm_shift) * ctr_infl_r +! enddo ! pjtail = 1, nipJ + +! ! here, treat head, TAIL==HEAD +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp +! i_bfm_interpJ = i_bfm_interpJ + 1 +! bfm_new_right(:, i_bfm_interpJ) = bfmhead +! i_brm_shift = i_brm_shift + 1 +! brm(:, i_brm_shift) = getBRM_msh(bfm_new_right(:, i_bfm_interpJ), fi, fj) + +! ! NOTE: it is a center point, except for the very last one (BORDER_t) +! intg = intg + brm(:, i_brm_shift) * ctr_infl_r + +! ! old head becomes new tail +! bfmtail = bfmhead +! enddo ! pjhead = 2, njOld + + +! ! removing excess of very last HEAD +! ! accounted as center, it is BORDER_t +! ! NOTE: even worse for very last HEAD which happens to be B point. +! ! there, it is a VERTEX_t point. +! ! However, it's the very last element in brm , we can remove it after. +! intg = intg + brm(:, i_brm_shift) * (ctr_infl_r - brd_infl_t) + + +! ! backup NJ new intrp n. of points for next iteration +! ! NOTE: also, refers to NJ point at pi_curr J inlf line. +! njNew_piprev = njNew_picurr +! njNew_picurr = i_bfm_interpJ ! NOTE: at last iter, should be 1 + + + + +! ! ok, here we now have BFM values (interp along J) +! ! at CURR and PREV (I) index pointers. +! ! We have to interpolate along I between CURR and PREV, i.e. +! ! prev has to start moving toward CURR. + + +! ! reset I-dir CURR-PREV distances +! dfIcurr = dfI_old +! dfIprev = 0._RDP + +! dfJ_oldtmp = dfJ_old +! njtmp = nipJ + +! ! interpolate along I +! do piprev = 1, nipI + +! ! bulk I-dir interpolation until pj_head section level. +! ! Then, after treat that triang shaped zone separately. + +! dfIprev = dfIprev + dfI_interp +! dfIcurr = dfIcurr - dfI_interp + +! bfm_interp(:, 1 : njNew_picurr) = & +! ( bfm_new_left (:, 1 : njNew_picurr) * dfIcurr + & +! bfm_new_right(:, 1 : njNew_picurr) * dfIprev ) / dfI_old + +! ! once we have the values, go through them to integrate +! ! NOTE: reset base freqs pointers, this time moving them along INTERP mesh +! fi = base_fi + (dfIi_interp * piprev) +! fj = base_fj + (dfIj_interp * piprev) + +! i_brm = i_brm + 1 +! brm(:, i_brm) = getBRM_msh(bfm_interp(:, 1), fi, fj) +! intg = intg + brm(:, i_brm) * brd_infl_r + + +! do pjtail = 2, njNew_picurr + +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp + +! i_brm = i_brm + 1 +! brm(:, i_brm) = getBRM_msh(bfm_interp(:, pjtail), fi, fj) +! intg = intg + brm(:, i_brm) * ctr_infl_r +! enddo + + +! !============================================== +! ! here we have to treat triang shaped zone. + +! ! NOTE: tmp head is interpolated along hypotenuse!! +! bfmhead = (& +! bfm_new_left (:, njNew_piprev) * (df_diag_interp * piprev) + & +! bfm_new_right(:, njNew_picurr) * (df_diag_interp * (nipI+1-piprev)) ) / df_diag_old + + +! ! once we have the head, continue interpolating along J between tail +! ! and tmp head +! ! NOTE: everytime we move pi_prev, actual Nj points reduce by 1 +! njtmp = njtmp - 1 +! dfJ_oldtmp = dfJ_oldtmp - dfJ_interp +! dfJhead = dfJ_oldtmp +! dfJtail = 0._RDP +! ipos = njNew_picurr ! tail index position +! do pjtail = 1, njtmp + +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp + +! dfJtail = dfJtail + dfJ_interp +! dfJhead = dfJhead - dfJ_interp + +! ! NOTE: tail is stored in bfm_interp(:, njNew_picurr) +! ipos = ipos + 1 +! bfm_interp(:, ipos) = & +! (bfmhead * dfJtail + dfJhead * bfm_interp(:, njNew_picurr)) / dfJ_oldtmp + +! i_brm = i_brm + 1 +! brm(:, i_brm) = getBRM_msh(bfm_interp(:, ipos), fi, fj) +! intg = intg + brm(:, i_brm) * ctr_infl_r +! enddo + +! ! treat HEAD (on hypotenuse) separately +! fi = fi + dfJi_interp +! fj = fj + dfJj_interp + +! i_brm = i_brm + 1 +! brm(:, i_brm) = getBRM_msh(bfmhead, fi, fj) +! intg = intg + brm(:, i_brm) * vtx_infl_t + +! enddo ! piprev = 1, nipI + + +! ! now we can update (PREV) base freqs. +! base_fi = base_fi + dfIi_old +! base_fj = base_fj + dfIj_old + + +! bfm_new_left(: , 1:njNew_picurr) = bfm_new_right(:, 1:njNew_picurr) + + +! ! once finished with this section (CURR-PREV), since we skip J column +! ! at pi_curr infl line, we reset general BRM index to point to +! ! previously shifted one. +! i_brm = i_brm_shift + + +! ! NOTE: at last iter, should be 1! +! ! NOTE: this is true just because ni==nj. +! njOld = njOld - 1 + +! enddo ! picurr = 2, this%ni_ + + +! #ifdef __BSA_DEBUG +! if (i_brm /= zNintrpPts) call bsa_Abort('"i_bfm" does not equal triang zone''s n. of points.') +! #endif + + +! ! removing overestimation for B point +! ! NOTE: should be stored at very last index!! +! intg = intg - brm(:, i_brm) * vtx_infl_t + +! ! updating main integral +! m3mr_msh_ptr_ = m3mr_msh_ptr_ + intg + +! end subroutine interpolateTZ_HTPC_v2 + + + + + + + + + + + + + + + + + +end submodule \ No newline at end of file diff --git a/src/BsaLib/bsa/meshing/zones/MZone.f90 b/src/BsaLib/bsa/meshing/zones/MZone.f90 new file mode 100644 index 0000000..eacb1b3 --- /dev/null +++ b/src/BsaLib/bsa/meshing/zones/MZone.f90 @@ -0,0 +1,259 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_MZone + +#include "../../../precisions" + + use BsaLib_MPolicy + use BsaLib_IO, only: unit_dump_bfm_, unit_debug_, undebug_fname_ + use BsaLib_CONSTANTS + use BsaLib_Data, only: bsa_Abort, test_no_bfm_mlr_ + implicit none + private + + public :: DefaultInitBaseZone, DumpZone, UndumpZone + + ! BUG: make them public to child MZone classes. Not optimal!! + public :: unit_debug_, unit_dump_bfm_ + + ! BUG: same as before, export constants values + public :: CST_2d3, CST_3d2, CST_PId2 + public :: CST_PIGREC, CST_PIt2, CST_PIt3d2, CST_PIt4 + + + !> Tracks zone with max N. of points + integer(kind = 4), public :: msh_max_zone_NPts = 0 + + type, public :: MZoneEnum_t + integer(kind = 4) :: NULL = 0 + integer(kind = 4) :: RECTANGLE = 1 + integer(kind = 4) :: TRIANGLE = 2 + integer(kind = 4) :: LINE = 3 + end type MZoneEnum_t + type(MZoneEnum_t), public, parameter :: MZone_ID = MZoneEnum_t() + ! integer, public, parameter :: MZone_RECTANGLE = 1 + ! integer, public, parameter :: MZone_TRIANGLE = 2 + ! integer, public, parameter :: MZone_LINEAR = 3 + + + type, abstract, public :: MZone_t + + character(len = 64) :: name_ = '' + type(MPolicy_t) :: policy_ + + !> Pointer to index of zone's interest modes + integer(kind = 4), public :: id_im_ + + contains + procedure, pass :: zoneName + procedure, pass :: setPolicy + procedure, pass :: policy + procedure, pass :: setInterestModeIndexPtr + procedure, pass :: disableZonePolicyBfmMLR + procedure(intf_MZoneIntFct_), pass, deferred :: zoneTotNPts + procedure(intf_MZoneGenIn_), pass, deferred :: dump + procedure(intf_MZoneGenInOut_), pass, deferred :: undump +#ifdef __BSA_OMP + procedure(intf_MZoneInterpOMP_), pass, deferred :: interpolate +#else + procedure(intf_MZoneGenInOut_), pass, deferred :: interpolate +#endif + end type MZone_t + + + + abstract interface + pure function intf_MZoneIntFct_(this) result(res) + import MZone_t + class(MZone_t), intent(in) :: this + integer :: res + end function + + subroutine intf_MZoneGenIn_(this) + import MZone_t + class(MZone_t), intent(in) :: this + end subroutine + + subroutine intf_MZoneGenInOut_(this) + import MZone_t + class(MZone_t), intent(inout) :: this + end subroutine + +#ifdef __BSA_OMP + subroutine intf_MZoneInterpOMP_(this, bfm, pdata) + import MZone_t, RDP + class(MZone_t), intent(inout) :: this + real(RDP), intent(in) :: bfm(:, :) + class(*), pointer, intent(in) :: pdata + end subroutine +#endif + end interface + + + +contains + + + + subroutine DefaultInitBaseZone(this) + class(MZone_t), intent(inout) :: this + + this%policy_ = MPolicy_NULL + end subroutine + + + subroutine zoneName(this, name_in) + class(MZone_t), intent(inout) :: this + character(len=*), intent(in) :: name_in + + this%name_ = name_in(1:len_trim(name_in)) + end subroutine + + + + + subroutine setInterestModeIndexPtr(this, id) + class(MZone_t), intent(inout) :: this + integer(kind = 4), intent(in) :: id + + this%id_im_ = id + end subroutine + + + + + subroutine setPolicy(this, var_in) + class(MZone_t), intent(inout) :: this + class(*), intent(in) :: var_in + select type (var_in) + class is (MPolicy_t) + this%policy_ = var_in + type is (integer) + this%policy_ = var_in + class default + call bsa_Abort('Unsupported type. Must be either "integer" or "MPolicy_t".') + end select + end subroutine + + function policy(this) result(pol_out) + class(MZone_t), intent(inout) :: this + type(MPolicy_t) :: pol_out + + pol_out = this%policy_ + end function + + + + + + + + subroutine DumpZone(z, data) + class(MZone_t), intent(in) :: z + real(RDP), intent(in) :: data(:, :) + ! integer :: tot + + ! dump specific zone data + ! NOTE: keep this first since + ! we want to read as first parameter, + ! the actual zone type identifier, so that + ! we can directly specialise undumping in Mesh() + ! routine. + call z%dump() + + ! write common zone data + write(unit_dump_bfm_) z%name_ + + ! policy + write(unit_dump_bfm_) z%policy_%getID() + + ! zone interest modes index ptr + write(unit_dump_bfm_) z%id_im_ + + + ! Dump BFM data. + ! + ! ! write how many bytes in total to be read + ! ! afterwards. Then, dimBISP is automatically + ! ! deferred knowing num of zone's meshing points + ! tot = size(data) + ! write(unit_dump_bfm_) tot + + write(unit_dump_bfm_) data ! NOTE: dimBISP first, then nj * ni + end subroutine DumpZone + + + +#ifdef __BSA_OMP + subroutine UndumpZone(z, bfm_undump) + use BsaLib_Data, only: dimM_bisp_ + real(RDP), allocatable, intent(inout) :: bfm_undump(:, :) +#else + subroutine UndumpZone(z) + use BsaLib_Data, only: bfm_undump +#endif + class(MZone_t), intent(inout) :: z + character(len = 64) :: name_hdr + integer :: zNp + + call z%undump() ! read zone's specific data first + + ! read zone common data + read(unit_dump_bfm_) name_hdr + call z%zoneName(name_hdr(1:len_trim(name_hdr))) + + ! policy (ID) + read(unit_dump_bfm_) zNp + call z%setPolicy(zNp) + if (test_no_bfm_mlr_) call z%disableZonePolicyBfmMLR() + + ! zone interest modes index ptr + read(unit_dump_bfm_) z%id_im_ + + ! once zone is undumped, get its N. of points + ! NOTE: needed in order to correctly index into bfm_undump ! + zNp = z%zoneTotNPts() + +#ifdef __BSA_OMP + if (.not. allocated(bfm_undump)) then + allocate(bfm_undump(dimM_bisp_, zNp)) + else + ! reallocate if more space needed + if (zNp > size(bfm_undump, 2)) then + deallocate(bfm_undump) + allocate(bfm_undump(dimM_bisp_, zNp)) + endif + endif +#endif + + ! read actual BFM dumped data + ! NOTE: in second dimension, nj leading over ni + ! laydown. + read(unit_dump_bfm_) bfm_undump(:, 1 : zNp) + end subroutine UndumpZone + + + + + elemental pure subroutine disableZonePolicyBfmMLR(z) + class(MZone_t), intent(inout) :: z + + z%policy_%interp_bfm_I_fct_ = 1 + z%policy_%interp_bfm_J_fct_ = 1 + end subroutine + + +end module diff --git a/src/BsaLib/precisions b/src/BsaLib/precisions new file mode 100644 index 0000000..a5edc9a --- /dev/null +++ b/src/BsaLib/precisions @@ -0,0 +1,11 @@ + +use iso_fortran_env + +#ifndef MY_PRECISIONS + +#define MY_PRECISIONS + +#define RDP real64 +#define RSP real32 + +#endif \ No newline at end of file diff --git a/src/BsaLib/settings/Settings.f90 b/src/BsaLib/settings/Settings.f90 new file mode 100644 index 0000000..dfcc50c --- /dev/null +++ b/src/BsaLib/settings/Settings.f90 @@ -0,0 +1,204 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_Settings + +#include "../precisions" + + implicit none + private + + !> Minimum rounding precision to guarantee. + integer, public :: i_min_round_prec_ = 10 + + type, public :: settings_t + + ! GENERAL settings + + + !> Subanalysis type + !> ==1, classic + !> ==2, mesher + !> ==3, BOTH (comparison) + integer(kind = 4) :: i_suban_type_ = 2 + + !> NOTE: only for "classic" suban type. + !> Manage which version to use (specially for dev testing). + !> ==1 uses old adapted spectra + !> ==2, uses new spectra, sistematic + integer(kind = 4) :: i_vers_ = 2 + + !> Turbulence PSDs scaling convention + !> ==1, pulsations (-infty, +infty) + !> ==2, frequencies (0, +infty) + integer(kind = 4) :: i_def_scaling_ = 1 + + !> If ==0, do not compute PSDs + integer(kind = 4) :: i_compute_psd_ = 1 + + !> If ==0, do not compute BISPs + integer(kind = 4) :: i_compute_bisp_ = 1 + + !> Whether computing FULL matrices or not. + !> True if ==1. + integer(kind = 4) :: i_only_diag_ = 0 + + !> Activate for testing some new features. + integer(kind = 4) :: i_test_mode_ = 0 + + + + ! CLASSIC settings + + + !> If suban=="classic", number of sistematic freqs. + integer(kind = 4) :: nfreqs_ = 0 + + !> If suban=="classic", constant delta frequency. + real(RDP) :: df_ = 0._RDP + + !> If ==0, using VECTORISED functions version. + !> Otherwise (==1), using SCALAR versions. + integer(kind = 4) :: i_scalar_vers_ = 0 + + !> Bisp symmetry case. + !> 0 = full + !> 2 = half + !> 4 = fourth + integer(kind = 4) :: i_bisp_sym_ = 0 + + !> 3D bisp matrix symmetry exploitation. + !> 0 = no + !> 1 = yes + !> NOTE: if i_bisp_sym_==4, automatically 0 + integer(kind = 4) :: i_3d_sym_ = 0 + + + + + ! MESHER settings + + + !> If ==1, using SVD to S_uvw matrices + integer(kind = 4) :: i_use_svd_ = 1 + + !> How many points (per side) for meshing + !> main central BKG peak zone. + integer(kind = 4) :: bkg_base_rfmnt_ = 20 + + !> + integer(kind = 4) :: max_area_extension_ = 2 + + !> How much to extend BKG peak area influence. + integer(kind = 4) :: bkg_area_extension_ = 2 + + !> How much to extend general peak area influence. + integer(kind = 4) :: gen_peak_area_extension_ = 3 + + !> If true, we get up to 2*max_freq. + integer(kind = 4) :: i_full_coverage_ = 1 + + !> Controls wheter to include modal info when + !> writing to dump file. + !> Unactive by default! + !> Warn if gets activated. + integer(kind = 4) :: i_dump_modal_ = 0 + + + contains + + procedure, public, pass :: SetSubanType + procedure, public, pass :: SetVersion + procedure, public, pass :: SetScalingType + procedure, public, pass :: ActivateSpectraComputation + procedure, public, pass :: SetExtension + procedure, public, pass :: TestMode + procedure, public, pass :: setSymmetries + procedure, public, pass :: setClsSettings + procedure, public, pass :: SetMshrSetts + end type settings_t + + + + interface + + !> Sets sub analysis type + module subroutine SetSubanType(this, isuban) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: isuban + end subroutine + + !> Set version + module subroutine SetVersion(this, ivers) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ivers + end subroutine + + !> Sets PSDs scaling convention. + !> ==1, default, pulsation (-infty, +infty) + !> ==2, frequencies [WARNING] (0, +infty) + module subroutine SetScalingType(this, idefsc) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: idefsc + end subroutine + + + !> Allows to control spectra comptation. + !> Pass 0 to deactivate. + module subroutine ActivateSpectraComputation(this, ipsd, ibisp) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in), optional :: ipsd, ibisp + end subroutine + + + !> Allows to specify whether full 2d/3d matrices are to be computed. + !> If 0, only main diagonal elements are computed (uncorrelated case). + module subroutine SetExtension(this, ionlydiag) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ionlydiag + end subroutine + + + !> Controls whether testing mode is active. + module subroutine TestMode(this, itest) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: itest + end subroutine + + + module subroutine setSymmetries(this, ibispsym, i3dsym) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ibispsym, i3dsym + end subroutine + + + !> Sets main Classic suban settings. + module subroutine setClsSettings(this, nfreqs, df) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nfreqs + real(RDP), intent(in) :: df + end subroutine + + + !> Sets main Mesher suban settings. + module subroutine SetMshrSetts(this, isvd, bkgrfmt, bkgaext, genpaext, maxaext, ifcov, idumpmod) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: isvd, bkgrfmt, bkgaext, genpaext, maxaext, ifcov, idumpmod + end subroutine + + end interface + + +end module \ No newline at end of file diff --git a/src/BsaLib/settings/SettingsImpl.f90 b/src/BsaLib/settings/SettingsImpl.f90 new file mode 100644 index 0000000..36b6b0f --- /dev/null +++ b/src/BsaLib/settings/SettingsImpl.f90 @@ -0,0 +1,154 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib_Settings) BsaLib_SettingsImpl + +#include "../precisions" + + use BsaLib_IO, only: INFOMSG, WARNMSG, ERRMSG, MSGCONT, DBGMSG & + , BSA_SETTS_DATA_DUMPFILE, unit_debug_ + use BsaLib_Data, only: bsa_Abort + use BsaLib_CONSTANTS, only: BSA_SPATIAL_SYM_NONE + implicit none + +contains + + + + module subroutine SetSubanType(this, isuban) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: isuban + + if (isuban < 0 .or. isuban > 3) call bsa_Abort('Invalid "sub-an" value.') + this%i_suban_type_ = isuban + end subroutine SetSubanType + + + module subroutine SetVersion(this, ivers) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ivers + + if (ivers < 0 .or. ivers > 2) call bsa_Abort('Invalid "ivers" value.') + this%i_vers_ = ivers + end subroutine SetVersion + + + module subroutine SetScalingType(this, idefsc) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: idefsc + + if (idefsc < 0 .or. idefsc > 2) call bsa_Abort('Invalid "idefsc" value.') + this%i_def_scaling_ = idefsc + end subroutine SetScalingType + + + module subroutine ActivateSpectraComputation(this, ipsd, ibisp) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in), optional :: ipsd, ibisp + + if (present(ipsd)) then + if (ipsd < 0 .or. ipsd > 1) call bsa_Abort('Invalid "ipsd" value.') + this%i_compute_psd_ = ipsd + endif + + if (present(ibisp)) then + if (ibisp < 0 .or. ibisp > 1) call bsa_Abort('Invalid "ibisp" value.') + this%i_compute_bisp_ = ibisp + endif + end subroutine ActivateSpectraComputation + + + + module subroutine SetExtension(this, ionlydiag) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ionlydiag + + if (ionlydiag < 0 .or. ionlydiag > 1) call bsa_Abort('Invalid "ionlydiag" value.') + this%i_only_diag_ = ionlydiag + end subroutine SetExtension + + + + module subroutine TestMode(this, itest) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: itest + + if (itest < 0 .or. itest > 1) call bsa_Abort('Invalid "itest" value.') + this%i_test_mode_ = itest + end subroutine TestMode + + + module subroutine setSymmetries(this, ibispsym, i3dsym) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ibispsym, i3dsym + + if (ibispsym == 0) then + this%i_bisp_sym_ = BSA_SPATIAL_SYM_NONE + elseif (ibispsym == 2 .or. ibispsym == 4) then + this%i_bisp_sym_ = ibispsym + else + call bsa_Abort('Invalid "ibispsym" value.') + endif + + if (i3dsym < 0 .or. i3dsym > 1) call bsa_Abort('Invalid "i3dsym" value.') + this%i_3d_sym_ = i3dsym + end subroutine + + + + module subroutine setClsSettings(this, nfreqs, df) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nfreqs + real(RDP), intent(in) :: df + + if (nfreqs <= 0) call bsa_Abort('Invalid "nfreqs" value.') + this%nfreqs_ = nfreqs + + if (df <= 0._RDP) call bsa_Abort('Invalid "df" value.') + this%df_ = df + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') & + INFOMSG, '@SettingsImpl::setClsSettings() : setting Bsa Classic settings -- ok.' +#endif + end subroutine setClsSettings + + + + + + module subroutine SetMshrSetts(this, isvd, bkgrfmt, bkgaext, genpaext, maxaext, ifcov, idumpmod) + class(settings_t), intent(inout) :: this + integer(kind = 4), intent(in) :: isvd, bkgrfmt, bkgaext, genpaext, maxaext, ifcov, idumpmod + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) ' @SettingsImpl::SetMshrSetts() : init setting Bsa Mesher settings...' +! #endif + + this%i_use_svd_ = isvd + this%bkg_base_rfmnt_ = bkgrfmt + this%bkg_area_extension_ = bkgaext + this%gen_peak_area_extension_ = genpaext + this%max_area_extension_ = maxaext + this%i_full_coverage_ = ifcov + this%i_dump_modal_ = idumpmod + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') & + INFOMSG, '@SettingsImpl::SetMshrSetts() : setting Bsa Mesher settings -- ok.' +#endif + end subroutine SetMshrSetts + +end submodule \ No newline at end of file diff --git a/src/BsaLib/structure/StructureData.f90 b/src/BsaLib/structure/StructureData.f90 new file mode 100644 index 0000000..2fabfe2 --- /dev/null +++ b/src/BsaLib/structure/StructureData.f90 @@ -0,0 +1,223 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_Structure + +#include "../precisions" + + implicit none + private + + + type, public :: StructureModalData_t + + !> n. of (in memory) kept structure vibration modes + integer(kind = 4) :: nm_ = 0 + + !> n. of "usable" structure vibration modes + !> To account for non 1-normalised modes, if any. + integer(kind = 4) :: nm_eff_ = 0 + + !> List of "usable" structural vibration modes. + !> They might be less than the actual computed, + !> since some of them might refer to torsional + !> modes, etc.. + integer(kind = 4), allocatable :: modes_(:) + + !> structural natural frequencies + real(RDP), dimension(:), pointer :: nat_freqs_; + + !> generalised modal matrix + real(RDP), dimension(:, :), pointer :: phi_; + + !> modal damping ratios + real(RDP), dimension(:), pointer :: xsi_; + + !> generalised mass matrix + real(RDP), dimension(:), pointer :: Mm_; + + !> generalised damping matrix (Rayleigh) + real(RDP), dimension(:, :), pointer :: Cm_; + + !> generalised stiffness matrix + real(RDP), dimension(:), pointer :: Km_; + end type StructureModalData_t + + + + type, public :: StructureData_t + + !> n. of all nodes + integer(kind = 4) :: nn_ = 0 + + !> n. of all libs (per node) + integer(kind = 4) :: nlibs_ = 0 + + !> n. of total DOFs + integer(kind = 4) :: ndofs_ = 0 + + !> n. of actually loaded nodes + integer(kind = 4) :: nn_load_ = 0 + + !> n. of actually loaded DOFs (per loaded node) + integer(kind = 4) :: nlibs_load_ = 0 + + !> list of actual loaded nodes + integer(kind = 4), pointer :: n_load_(:) => null(); + + !> list of actual loaded DOFs (per node) + integer(kind = 4), pointer :: libs_load_(:) => null(); + + ! NOTE: pointer since we do not want to copy. + !> Nodal coordinates. + real(RDP), pointer :: coords_(:, :) => null() + + !> modal structure info + type(StructureModalData_t) :: modal_ + + + ! NOTE: following allocatables since are local instances ! + + !> structure time scales + real(RDP), dimension(:), allocatable :: str_time_scales_ + + !> background peak widths + real(RDP), dimension(:, :), allocatable :: bkg_peak_width_ + + !> resonant peak widths + real(RDP), dimension(:), allocatable :: res_peak_width_ + + contains + + procedure, public, pass :: SetNodalCoords + procedure, public, pass :: SetNOfNodalDOFs + procedure, public, pass :: SetTotalNOfNodes + procedure, public, pass :: SetLoadedNodalDOFs + procedure, public, pass :: SetLoadedNodes + procedure, public, pass :: SetModalInfo + procedure, public, pass :: SetKeptModes + procedure, public, pass :: SetKeptModesDefault + procedure, public, pass :: SetModalMatrices + procedure, public, pass :: SetTotDamping + procedure, public, pass :: ComputeResPeakWidths + procedure, public, pass :: computeBKGPeakWidths + procedure, public, pass :: clean + end type StructureData_t + + + + + + interface + + module subroutine SetNodalCoords(this, nn, coords) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nn + real(RDP), target, allocatable :: coords(:, :) + end subroutine + + module subroutine SetNOfNodalDOFs(this, nlibs) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nlibs + end subroutine + + + module subroutine SetTotalNOfNodes(this, nn) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nn + end subroutine + + + + module subroutine SetLoadedNodalDOFs(this, nlib, lib) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nlib + integer(kind = 4), target, intent(in) :: lib(:) + end subroutine + + + + module subroutine SetLoadedNodes(this, nnl, nl) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nnl + integer(kind = 4), target, intent(in) :: nl(:) + end subroutine + + + + + + + module subroutine SetModalInfo(this, ndofs, nm, Phi, natf) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ndofs, nm + real(RDP), intent(in), target :: Phi(ndofs, nm), natf(nm) + end subroutine + + + module subroutine SetKeptModes(this, modes) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: modes(:) + end subroutine + + + !> NOTE: assumes that modes are not allocated yet. + module subroutine SetKeptModesDefault(this) + class(StructureData_t), intent(inout) :: this + end subroutine + + + + module subroutine SetModalMatrices(this, nm, Mg, Kg, Cg) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nm + real(RDP), intent(in), target, dimension(nm) :: Mg, Kg + real(RDP), intent(in), target :: Cg(nm, nm) + end subroutine + + + + module subroutine SetTotDamping(this, xsi) + class(StructureData_t), intent(inout) :: this + real(RDP), target, intent(in) :: xsi(this%modal_%nm_) + end subroutine + + + + + + + module subroutine ComputeResPeakWidths(this) + class(StructureData_t), intent(inout) :: this + end subroutine + + + + module subroutine computeBKGPeakWidths(this, wind_scales) + class(StructureData_t), intent(inout) :: this + real(RDP), intent(in) :: wind_scales(:, :) + end subroutine + + + + + module subroutine clean(this) + class(StructureData_t) :: this + end subroutine + + end interface + + +end module BsaLib_Structure \ No newline at end of file diff --git a/src/BsaLib/structure/StructureImpl.f90 b/src/BsaLib/structure/StructureImpl.f90 new file mode 100644 index 0000000..db4da41 --- /dev/null +++ b/src/BsaLib/structure/StructureImpl.f90 @@ -0,0 +1,466 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib_Structure) BsaLib_StructDataImpl + +#include "../precisions" + + use Logging + use BsaLib_IO, only: INFOMSG, WARNMSG, ERRMSG, MSGCONT, DBGMSG & + , BSA_STRUCT_DATA_DUMPFILE, unit_debug_ + use BsaLib_Data, only: bsa_Abort + implicit none + + +contains + + + module subroutine SetNodalCoords(this, nn, coords) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nn + real(RDP), target, allocatable :: coords(:, :) + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetNodalCoords() : init...' +#endif + + if (this%nn_ == 0) then + this%nn_ = nn + else + if (this%nn_ /= nn) & + call bsa_Abort('Nodal info does not match in setting nodal coordinates. Check again.') + endif + + this%coords_ => coords + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetNodalCoords() : init -- ok.' +#endif + end subroutine SetNodalCoords + + + + + + + module subroutine SetNOfNodalDOFs(this, nlibs) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nlibs + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetNOfNodalDOFs() : init...' +#endif + + this%nlibs_ = nlibs + + ! BUG: this might cause errors if NN==0 + this%ndofs_ = this%nn_ * nlibs + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetNOfNodalDOFs() : init -- ok.' +#endif + end subroutine SetNOfNodalDOFs + + + + + + + module subroutine SetTotalNOfNodes(this, nn) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nn + + this%nn_ = nn + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetTotalNOfNodes() : init -- ok.' +#endif + end subroutine SetTotalNOfNodes + + + + + module subroutine SetLoadedNodalDOFs(this, nlib, lib) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nlib + integer(kind = 4), target, intent(in) :: lib(:) + + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetLoadedNodalDOFs() : init...' +#endif + + this%nlibs_load_ = nlib + this%libs_load_ => lib + +#ifdef __BSA_DEBUG + ! write(unit_debug_, '(1x, a, /, i5, /, *(6i5))') & + ! ' @StructImpl::SetLoadedNodalDOFs() : loaded LIBs (per node) = ', this%nlibs_load_, this%libs_load_ + + write(unit_debug_, *) INFOMSG//'@StructImpl::SetLoadedNodalDOFs() : init -- ok.' +#endif + end subroutine SetLoadedNodalDOFs + + + + + + + module subroutine SetLoadedNodes(this, nnl, nl) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nnl + integer(kind = 4), target, intent(in) :: nl(:) + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetLoadedNodes() : init...' +#endif + + this%nn_load_ = nnl + this%n_load_ => nl + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetLoadedNodes() : init -- ok.' +#endif + end subroutine SetLoadedNodes + + + + + + + + + module subroutine SetModalInfo(this, ndofs, nm, Phi, natf) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ndofs, nm + real(RDP), intent(in), target :: Phi(ndofs, nm), natf(nm) + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetModalInfo() : init...' +#endif + + this%modal_%nm_ = nm + this%modal_%phi_ => Phi + this%modal_%nat_freqs_ => natf + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetModalInfo() : init -- ok.' +#endif + end subroutine SetModalInfo + + + + + + module subroutine SetKeptModes(this, modes) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: modes(:) + integer :: istat, nmodes + character(len = 256) :: emsg + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetKeptModes() : init...' +#endif + + nmodes = size(modes) + if (this%modal_%nm_eff_ == 0) then + this%modal_%nm_eff_ = nmodes + else + if (nmodes /= this%modal_%nm_eff_) call bsa_Abort('Sizes do not match.') + endif + + + if (.not. allocated(this%modal_%modes_)) then + allocate(this%modal_%modes_(this%modal_%nm_eff_), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('this % modal_%modes_', & + this%modal_%nm_eff_, loc(this%modal_%modes_), sizeof(this%modal_%modes_)) +#endif + else + call allocKOMsg('this % modal_%modes_', istat, emsg) + endif + endif + + this%modal_%modes_ = modes + + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetKeptModes() : init -- ok.' +#endif + end subroutine SetKeptModes + + + + + module subroutine SetKeptModesDefault(this) + class(StructureData_t), intent(inout) :: this + integer :: istat + character(len = 256) :: emsg + + if (this%modal_%nm_ == 0) call bsa_Abort('Trying to allocate modes when NM==0 yet.') + + if (.not. allocated(this%modal_%modes_)) then + allocate(this%modal_%modes_(this%modal_%nm_), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('this % modal_%modes_', & + this%modal_%nm_, loc(this%modal_%modes_), sizeof(this%modal_%modes_)) +#endif + else + call allocKOMsg('this % modal_%modes_', istat, emsg) + endif + endif + + this%modal_%modes_ = [1 : this%modal_%nm_] + end subroutine SetKeptModesDefault + + + + + + module subroutine SetModalMatrices(this, nm, Mg, Kg, Cg) + class(StructureData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: nm + real(RDP), intent(in), target :: Mg(nm), Kg(nm) + real(RDP), intent(in), target :: Cg(nm, nm) + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetModalMatrices() : init...' +#endif + + if (.not. this%modal_%nm_ == 0) then + if (.not. this%modal_%nm_ == nm) & + call bsa_Abort('You passed a value of "nm" which differs from previously set.') + else ! == 0 + this%modal_%nm_ = nm + endif + + + this%modal_%Mm_ => Mg + this%modal_%Km_ => Kg + this%modal_%Cm_ => Cg + + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetModalMatrices() : init -- ok.' +#endif + end subroutine SetModalMatrices + + + + + + module subroutine SetTotDamping(this, xsi) + class(StructureData_t), intent(inout) :: this + real(RDP), target, intent(in) :: xsi(this%modal_%nm_) + + if (this%modal_%nm_ == 0) then + print '(/ 1x, a, a, a /)', & + ' ' // ERRMSG // 'NM == 0 when setting Damping info.' + call bsa_Abort() + endif + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::SetTotDamping() : init...' +#endif + + this%modal_%xsi_ => xsi + +#ifdef __BSA_DEBUG + ! write(unit_debug_, *) DBGMSG, '@StructDataImpl::SetTotDamping() : log checking modal damping...' + ! write(unit_debug_, '(6g)') this%modal_%xsi_ + + write(unit_debug_, *) INFOMSG//'@StructImpl::SetTotDamping() : init -- ok.' +#endif + end subroutine + + + + + + + + + module subroutine ComputeResPeakWidths(this) + class(StructureData_t), intent(inout) :: this + integer :: istat + character(len = 256) :: emsg + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::ComputeResPeakWidths() : init...' +#endif + + if (allocated(this%res_peak_width_)) then + + if (.not. all(this%res_peak_width_ == 0._RDP)) return + + else + + allocate(this%res_peak_width_(this%modal_%nm_), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('this % res_peak_width_', & + this%modal_%nm_, loc(this%res_peak_width_), sizeof(this%res_peak_width_)) +#endif + else + call allocKOMsg('this % res_peak_width_', istat, emsg) + endif + + endif + + this%res_peak_width_ = this%modal_%xsi_ * this%modal_%nat_freqs_ + +#ifdef __BSA_DEBUG + write(unit_debug_, *) DBGMSG, '@StructImpl::ComputeResPeakWidths() : res peak widths = ' + write(unit_debug_, '(*(g12.5, 2x))') this%res_peak_width_ +#endif + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::ComputeResPeakWidths() : init -- ok.' +#endif + end subroutine ComputeResPeakWidths + + + + + + + module subroutine computeBKGPeakWidths(this, wind_scales) + class(StructureData_t), intent(inout) :: this + real(RDP), intent(in) :: wind_scales(:, :) + integer :: j, i + integer :: istat + character(len = 256) :: emsg + +! #ifdef __BSA_DEBUG +! write(*, *) INFOMSG//'@StructImpl::computeBKGPeakWidths() : init...' +! #endif + + + if (.not. allocated(this%bkg_peak_width_)) then + allocate(this%bkg_peak_width_(3, 3), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('this % bkg_peak_width_', & + [3, 3], loc(this%bkg_peak_width_), sizeof(this%bkg_peak_width_)) +#endif + else + call allocKOMsg('this % bkg_peak_width_', istat, emsg) + endif + endif + + this%bkg_peak_width_ = 0._RDP + + ! BUG: this is not optimal! +!DIR$ UNROLL + do j = 1, 3 + do i = 1, 3 + if (wind_scales(i, j) == 0._RDP) cycle + this%bkg_peak_width_(i, j) = 1 / wind_scales(i, j) + enddo + enddo + +#ifdef __BSA_DEBUG + write(unit_debug_, *) & + DBGMSG, '@StructImpl::computeBKGPeakWidths() : bkg peak widths = ' + write(unit_debug_, '(3(g12.5, 2x))') this%bkg_peak_width_ +#endif + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::computeBKGPeakWidths() : init -- ok.' +#endif + end subroutine computeBKGPeakWidths + + + + + + + + + module subroutine clean(this) + class(StructureData_t) :: this + integer :: istat + character(len = 256) :: emsg + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *) INFOMSG//'@StructImpl::clean() : cleaning up...' +! #endif + + if (associated(this%n_load_)) nullify(this%n_load_) + if (associated(this%libs_load_)) nullify(this%libs_load_) + if (associated(this%coords_)) nullify(this%coords_) + + + if (allocated(this%modal_%modes_)) then + deallocate(this%modal_%modes_, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('this%modal_%modes_') +#endif + else + call deallocKOMsg('this%modal_%modes_', istat, emsg) + endif + endif + + if (associated(this%modal_%Cm_)) nullify(this%modal_%Cm_) + if (associated(this%modal_%Km_)) nullify(this%modal_%Km_) + if (associated(this%modal_%Mm_)) nullify(this%modal_%Mm_) + if (associated(this%modal_%nat_freqs_)) nullify(this%modal_%nat_freqs_) + if (associated(this%modal_%phi_)) nullify(this%modal_%phi_) + if (associated(this%modal_%xsi_)) nullify(this%modal_%xsi_) + + + if (allocated(this%str_time_scales_)) then + deallocate(this%str_time_scales_, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('this%str_time_scales_') +#endif + else + call deallocKOMsg('this%str_time_scales_', istat, emsg) + endif + endif + + if (allocated(this%bkg_peak_width_)) then + deallocate(this%bkg_peak_width_, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('this%bkg_peak_width_') +#endif + else + call deallocKOMsg('this%bkg_peak_width_', istat, emsg) + endif + endif + + if (allocated(this%res_peak_width_)) then + deallocate(this%res_peak_width_, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call deallocOKMsg('this%res_peak_width_') +#endif + else + call deallocKOMsg('this%res_peak_width_', istat, emsg) + endif + endif + +#ifdef __BSA_DEBUG + write(unit_debug_, *) INFOMSG//'@StructImpl::clean() : cleaning up -- ok.' +#endif + end subroutine clean + + +end submodule \ No newline at end of file diff --git a/src/BsaLib/timing/Timer.f90 b/src/BsaLib/timing/Timer.f90 new file mode 100644 index 0000000..d52f99f --- /dev/null +++ b/src/BsaLib/timing/Timer.f90 @@ -0,0 +1,121 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_Timing + + + implicit none + private + + + type, public :: timer_t + private + real(kind = 8) :: t_init_ = 0.d0 + real(kind = 8) :: t_last_ = 0.d0 + real(kind = 8) :: t_tot_ = 0.d0 + real(kind = 8) :: t_tot_prev_ = 0.d0 + contains + procedure, public, pass(this) :: init => InitTimer + procedure, public, pass(this) :: time => ClockTimer + procedure, public, pass(this) :: total => GetTimerTotal + procedure, public, pass(this) :: reset => ResetTimer + end type timer_t + + + + +contains + + + + subroutine InitTimer(this) + class(timer_t) :: this + + ! write(unit_debug_, *), ' @BsaLib_Timing::InitTimer() : Init timer...' + + call cpu_time(this%t_init_) + this%t_last_ = this%t_init_ + + ! write(unit_debug_, *), ' @BsaLib_Timing::InitTimer() : Init timer -- ok.' + end subroutine InitTimer + + + + + function ClockTimer(this) result(dt) + class(timer_t) :: this + real(kind = 8) :: dt_tmp + real(kind = 8) :: dt + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *), ' @BsaLib_Timing::ClockTimer() : save partial time...' +! #endif + + call cpu_time(dt_tmp) + dt = dt_tmp - this%t_last_ + + ! update total + this%t_tot_ = this%t_tot_ + dt + + ! update last cpu_time call + this%t_last_ = dt_tmp + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *), ' @BsaLib_Timing::ClockTimer() : save partial time -- ok.' +! #endif + end function ClockTimer + + + + + + pure elemental function GetTimerTotal(this) result(tot) + class(timer_t), intent(in) :: this + real(kind = 8) :: tot + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *), ' @BsaLib_Timing::GetTimerTotal() : getting timer total time...' +! #endif + + tot = this%t_tot_ + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *), ' @BsaLib_Timing::GetTimerTotal() : getting timer total time -- ok.' +! #endif + end function GetTimerTotal + + + + + subroutine ResetTimer(this) + class(timer_t) :: this + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *), ' @BsaLib_Timing::ResetTimer() : Reset timer...' +! #endif + + this%t_init_ = 0.d0 + this%t_last_ = 0.d0 + this%t_tot_ = 0.d0 + this%t_tot_prev_ = 0.d0 + +! #ifdef __BSA_DEBUG +! write(unit_debug_, *), ' @BsaLib_Timing::ResetTimer() : Reset timer -- ok.' +! #endif + end subroutine ResetTimer + + + +end module \ No newline at end of file diff --git a/src/BsaLib/utils/utility.f90 b/src/BsaLib/utils/utility.f90 new file mode 100644 index 0000000..6adc212 --- /dev/null +++ b/src/BsaLib/utils/utility.f90 @@ -0,0 +1,79 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_Utility + + use BsaLib_CONSTANTS, only: INFOMSG, ERRMSG, MSGCONT, WARNMSG, NOTEMSG + implicit none + public + +contains + + + function util_createDirIfNotExist(dirname) result(ierr) + !! + !! Creates a directory if it does not exists. + !! + character(len = *), intent(in) :: dirname + character(len = :), allocatable :: cmd + integer :: ierr + logical :: lflag + + ierr = 0 + inquire(directory=dirname, exist=lflag) + if (lflag) then + print '(1x, a, a)', & + INFOMSG, 'Directory "'//dirname//'" already exists.' + return + endif + +#ifdef _WIN32 + cmd = 'mkdir '//dirname(3:12) ! BUG: fix this!! +#else + cmd = 'mkdir '//dirname +#endif + call execute_command_line(cmd, .true., ierr) + if (ierr == 0) return + + print '(1x, 3a)', & + ERRMSG, 'Cannot create directory ', dirname + print '(1x, a, a, i0, a)', & + MSGCONT, 'Command execution returned error code ', ierr, '. Aborting..' + end function + + + pure elemental function util_getCorrVectIndex(ni, nj, tot) result(id) + !! Returns the equivalent index when storing spatial nodal + !! correlation as a vector (avoiding storing duplicates, symmetric) + !! NOTE: assumes that ni is the leading node, nj >= ni. + !! Otherwise, swaps them (makes use of symmetry). + integer(kind = 4), intent(in) :: ni, nj + integer(kind = 4), intent(in) :: tot + + integer(kind = 4) :: id + + if (nj >= ni) then + id = (ni - 1) * tot + nj - int((ni*ni - ni) / 2., kind = 4) + else + id = (nj - 1) * tot + ni - int((nj*nj - nj) / 2., kind = 4) + endif + +! #ifdef __BSA_DEBUG +! print '(1x, a, 2i5, a, i5)', & +! '@BsaLib_Utility::util_getCorrVectIndex() : with (ni - nj) = ', ni, nj, ', result index -> ', id +! #endif + end function + +end module BsaLib_Utility \ No newline at end of file diff --git a/src/BsaLib/wind/WindPSDImpl.f90 b/src/BsaLib/wind/WindPSDImpl.f90 new file mode 100644 index 0000000..27b4e82 --- /dev/null +++ b/src/BsaLib/wind/WindPSDImpl.f90 @@ -0,0 +1,327 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib_WindData) BsaLib_WindPSDImpl + +#include "../precisions" + + use BsaLib_IO, only: INFOMSG, WARNMSG, ERRMSG, MSGCONT, DBGMSG + implicit none + + type :: arr_proc_pointer_t + procedure(PSDfunc), pointer, nopass :: ptr => null() + end type arr_proc_pointer_t + + ! TODO: might be statically initialised (parameter) + type(arr_proc_pointer_t), dimension(5) :: psd_funcs + +contains + + + module subroutine SetPSDType(this, ipsd) + class(WindData_t), intent(inout) :: this + integer(kind = 4), value :: ipsd + integer :: istat + character(len = 256) :: emsg + + ! if (ipsd < 1 .or. ipsd > 5) call bsa_Abort('Invalid "ipsd" value.') + ! if (ipsd < 1 .or. ipsd > 5) ipsd = 1 + if (ipsd < 1 .or. ipsd > 5) error stop ERRMSG//'Invalid "ipsd" value.' + + ! TODO: this might be removed + this%i_psd_type_ = ipsd + + allocate(this%psd_, stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('this % psd_', loc(this%psd_), sizeof(this%psd_)) +#endif + else + call allocKOMsg('this % psd_', istat, emsg) + endif + + ! setting function pointer array + psd_funcs(1)%ptr => vonKarmanPSD_ + psd_funcs(2)%ptr => kaimalPSD_ + psd_funcs(3)%ptr => davenportPSD_Greisch_ + psd_funcs(5)%ptr => davenportPSD_Uliege_ + + call this%psd_%SetPSDFunction(psd_funcs(ipsd)%ptr) + +#ifdef __BSA_DEBUG + print *, INFOMSG, '@WindImpl::SetPSDType() : PSD type set to ', this%i_psd_type_ +#endif + end subroutine SetPSDType + + + + + + module function getFullNodalPSD(this, innl, nodesl, PSDvec, f, idir) result(PSDmat) + use BsaLib_Utility, only: util_getCorrVectIndex + use BsaLib_Data, only: struct_data + class(WindData_t), intent(in) :: this + integer(kind = 4), intent(in) :: innl, idir + integer(kind = 4), intent(in) :: nodesl(innl) + real(RDP), intent(in) :: PSDvec(innl) + real(RDP), intent(in) :: f + real(RDP) :: PSDmat(innl, innl) + real(RDP) :: absf + integer(kind = 4) :: i, j, ni, nj, id + + absf = abs(f) + + ! do concurrent (i = 1 : innl) shared(PSDvec) + ! PSDmat(:, i) = sqrt(PSDvec * PSDvec(i)) + ! ni = nodesl(i) + ! do concurrent (j = 1 : innl) shared(this, i) + ! nj = nodesl(j) + ! id = util_getCorrVectIndex(nj, ni, struct_data%nn_) + ! PSDmat(j, i) = PSDmat(j, i) * & + ! this%nod_corr_(id, idir)**(absf) + ! enddo + ! enddo + do i = 1, innl + PSDmat(:, i) = sqrt(PSDvec * PSDvec(i)) + ni = nodesl(i) + do j = 1, innl + nj = nodesl(j) + id = util_getCorrVectIndex(nj, ni, struct_data%nn_) + PSDmat(j, i) = PSDmat(j, i) * & + this%nod_corr_(id, idir)**(absf) + enddo + enddo + end function + + + + + + + + module subroutine SetPSDFunction(this, func) + class(psd_t) :: this + procedure(PSDfunc), intent(in), pointer :: func + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindPSDImpl::SetPSDFunction() : setting PSD function pointer...' +! #endif + + this%psd_fct_ptr => func + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindPSDImpl::SetPSDFunction() : setting PSD function pointer -- ok.' +#endif + end subroutine SetPSDFunction + + + + module function evalPSD_(this, nf, f, innl, nnl, idir, itc) result(PSD) + use BsaLib_Data, only: settings + class(WindData_t), intent(in) :: this + integer(kind = 4), intent(in) :: nf, innl, idir, itc + integer(kind = 4), intent(in) :: nnl(innl) + real(RDP), intent(in) :: f(nf) + real(RDP) :: PSD(nf, innl) + + if (idir /= 1) then + print '(/ 1x, a, a, i1, a)', & + WARNMSG, 'IDIR= ', idir, ', when usually SHOULD be 1 (X wind direction).' + print '(1x, a, a/, a, a)', & + MSGCONT, '(It is uncommon to compute PSDs of wind turbulence assuming', & + MSGCONT, ' that vortices do not move along X (idir=1), direction of mean wind)' + endif + + ! invoking internal function pointer + PSD = this%psd_%psd_fct_ptr(this, nf, f, innl, nnl, idir, itc) + + ! NOTE: PSD scaling (convention based) + if (settings%i_def_scaling_ == 1) PSD = PSD / CST_PIt4 + end function + + + + + function vonKarmanPSD_(wd, nf, freqs, innl, nnl, idir, itc) result(PSD) + class(WindData_t), intent(in) :: wd + integer(kind = 4), intent(in) :: nf ! n. frequencies + integer(kind = 4), intent(in) :: innl ! n. actual nodes loaded + integer(kind = 4), intent(in) :: idir ! wind direction + integer(kind = 4), intent(in) :: itc ! + real(RDP), intent(in) :: freqs(nf) ! frequencies + integer(kind = 4), intent(in) :: nnl(innl) ! list of actual loaded nodes + real(RDP) :: PSD(nf, innl) + + ! tmp + real(RDP), dimension(1, innl) :: L + real(RDP), allocatable :: rtmp1(:, :) + integer :: i + + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindPSDImpl::vonKarmanPSD_() : computing PSD...' +! #endif + + L(1, :) = wd%turb_scales_wz_(itc, idir, wd%wz_node_(1 : innl)) + + ! NOTE: how was programmed in FINELG + ! BUG: check. + if (idir == 1) then + + ! L/U + rtmp1 = L / reshape(wd%u_node_(1 : innl), [1, innl]) + PSD = matmul(reshape(abs(freqs), [nf, 1]), rtmp1) + PSD = PSD * PSD ! square + rtmp1 = rtmp1 * reshape(wd%sigmaUVW_wz_(itc, wd%wz_node_(1 : innl))**2, [1, innl]) + PSD = (1 + 70.7_RDP * PSD)**(5._RDP/6._RDP) + + + ! BUG: LOCAL(i) is superflous (should be error..) + do concurrent (i = 1 : innl) local(i) + PSD(:, i) = 4._RDP * rtmp1(1, i) / PSD(:, i) + enddo + + else ! WARNING: should not pass from here + + block + real(RDP) :: dnlsu(nf, innl), rtmp2(nf, innl), rtmp3(nf, innl) + + dnlsu = 2._RDP * & + matmul(reshape(freqs, [nf, 1]), & + reshape(wd%turb_scales_wz_(1, idir, wd%wz_node_(nnl)), [1, innl]) / & + reshape(wd%u_node_(1 : innl), [1, innl])) + + dnlsu = dnlsu*dnlsu + + rtmp1 = 1._RDP + 70.7_RDP * dnlsu + rtmp2 = rtmp1 ** (11._RDP / 6._RDP) + rtmp2 = rtmp2 * reshape(wd%u_node_(1 : innl), [1, innl]) + rtmp3 = reshape(wd%turb_scales_wz_(itc, idir, wd%wz_node_(nnl)), [1, innl]) * & + (1._RDP + 188.4_RDP * dnlsu) / & + rtmp2 * reshape(wd%sigmaUVW_wz_(itc, wd%wz_node_(nnl))**2, [1, innl]) + + rtmp1 = rtmp3 + rtmp3 + PSD = rtmp1 + rtmp1 + end block + endif + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindPSDImpl::vonKarmanPSD_() : computing PSD -- ok.' +! #endif + end function vonKarmanPSD_ + + + + + function kaimalPSD_(wd, nf, freqs, innl, nnl, idir, itc) result(PSD) + class(WindData_t), intent(in) :: wd + integer(kind = 4), intent(in) :: nf ! n. frequencies + integer(kind = 4), intent(in) :: innl ! n. actual nodes loaded + integer(kind = 4), intent(in) :: idir ! wind direction + integer(kind = 4), intent(in) :: itc ! + integer(kind = 4), intent(in) :: nnl(innl) ! list of actual loaded nodes + real(RDP), intent(in) :: freqs(nf) ! frequencies + real(RDP) :: PSD(nf, innl) + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindPSDImpl::kaimalPSD_() : computing PSD.. [NOT YET IMPLEMENTED]' +#endif + + PSD = 0._RDP + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') & +! INFOMSG, '@WindPSDImpl::kaimalPSD_() : computing PSD -- ok.' +! #endif + end function kaimalPSD_ + + + + + + function davenportPSD_Greisch_(wd, nf, freqs, innl, nnl, idir, itc) result(PSD) + class(WindData_t), intent(in) :: wd + integer(kind = 4), intent(in) :: nf ! n. frequencies + integer(kind = 4), intent(in) :: innl ! n. actual nodes loaded + integer(kind = 4), intent(in) :: idir ! wind direction + integer(kind = 4), intent(in) :: itc ! + integer(kind = 4), intent(in) :: nnl(innl) ! list of actual loaded nodes + real(RDP), intent(in) :: freqs(nf) ! frequencies + real(RDP), parameter :: cst1 = 1200._RDP + integer :: i, n + real(RDP) :: PSD(nf, innl) + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindPSDImpl::davenportPSD_Greisch_() : computing PSD...' +! #endif + + do i = 1, innl + + n = nnl(i) + + PSD(:, i) = wd%sigmaUVW_wz_(itc, wd%wz_node_(n)) * wd%sigmaUVW_wz_(itc, wd%wz_node_(n)) * & + 0.65_RDP * cst1 / wd%u_mean_ref_wz_(wd%wz_node_(n)) / & + (1 + (cst1 * freqs / wd%u_mean_ref_wz_(wd%wz_node_(n)))**2._RDP)**(5._RDP / 6._RDP) + enddo + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindPSDImpl::davenportPSD_Greisch_() : computing PSD -- ok.' +! #endif + end function davenportPSD_Greisch_ + + + + + + function davenportPSD_Uliege_(wd, nf, freqs, innl, nnl, idir, itc) result(PSD) + class(WindData_t), intent(in) :: wd + integer(kind = 4), intent(in) :: nf ! n. frequencies + integer(kind = 4), intent(in) :: innl ! n. actual nodes loaded + integer(kind = 4), intent(in) :: idir ! wind direction + integer(kind = 4), intent(in) :: itc ! + integer(kind = 4), intent(in) :: nnl(innl) ! list of actual loaded nodes + real(RDP), intent(in) :: freqs(nf) ! frequencies + real(RDP) :: PSD(nf, innl) + real(RDP) :: cstL_U(1, innl), cstFL_U(nf, innl) + integer :: i, n + + + cstL_U(1, :) = wd%turb_scales_wz_(itc, idir, wd%wz_node_(nnl)) / wd%u_node_(nnl) + cstFL_U = matmul(reshape(abs(freqs), [nf, 1]), cstL_U) + + + ! do i = 1, innl + ! PSD(:, i) = & + ! (CST_2d3 * cstFL_U(:, i) * cstL_U(1, i) * wd%sigmaUVW_wz_(itc, wd%wz_node_(i))**2) / & + ! ((1.d0 + (cstFL_U(:, i)**2))**(4.d0 / 3.d0)) + ! enddo + do concurrent (i = 1 : innl) shared(cstFL_U, cstL_U, itc, wd) local(n) + + n = nnl(i) + + PSD(:, i) = & + (CST_2d3 * cstFL_U(:, i) * cstL_U(1, i) * wd%sigmaUVW_wz_(itc, wd%wz_node_(n))**2) / & + ((1.d0 + (cstFL_U(:, i)**2))**(4.d0 / 3.d0)) + enddo + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindPSDImpl::davenportPSD_Uliege_() : computing PSD -- ok.' +! #endif + end function davenportPSD_Uliege_ + + + + +end submodule \ No newline at end of file diff --git a/src/BsaLib/wind/WindSetImpl.f90 b/src/BsaLib/wind/WindSetImpl.f90 new file mode 100644 index 0000000..d5c6814 --- /dev/null +++ b/src/BsaLib/wind/WindSetImpl.f90 @@ -0,0 +1,518 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +submodule(BsaLib_WindData) BsaLib_WindDataImpl + +#include "../precisions" + + use BsaLib_IO, only: INFOMSG, WARNMSG, ERRMSG, MSGCONT, DBGMSG & + , BSA_WIND_DATA_DUMPFILE + use BsaLib_Data, only: bsa_Abort + implicit none + +contains + + + + module subroutine SetWindvertProf(this, ivaru) + class(WindData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ivaru + + if (ivaru < 1 .or. ivaru > 3) call bsa_Abort('Invalid "ivaru" value.') + + this%i_wind_prof_ = ivaru + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a, a)') & + INFOMSG, '@WindImpl::SetWindvertProf() : wind vert prof set to ', & + trim(CST_WIND_V_PROFILES(this%i_wind_prof_)) +#endif + end subroutine SetWindvertProf + + + + + module subroutine SetMainvertDir(this, ivert) + class(WindData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ivert + + if (ivert < 1 .or. ivert > 3) call bsa_Abort('Invalid "ivert" value.') + this%i_vert_ = ivert + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a, i0)') INFOMSG, '@WindImpl::SetMainvertDir() : wind vert direction set to ', this%i_vert_ +#endif + end subroutine SetMainvertDir + + + + + module subroutine SetWindZoneLimits(this, lim, ilim) + class(WindData_t), intent(inout) :: this + real(RDP), intent(in), target :: lim(..) + integer(kind = 4), intent(in), optional :: ilim(..) + + + select rank (lim) + rank (0) + + if (.not. present(ilim)) call bsa_Abort('Please provide "ilim" value.') + + select rank (ilim) + rank (0) + if (ilim < 1 .or. ilim > this%nz_ + 1) call bsa_Abort('Invalid "ilim" value.') + this%limits_wz_(ilim) = lim + rank default + call bsa_Abort('"ilim" must be an integer scalar value.') + endselect + + rank (1) + + if (present(ilim)) then + + select rank (ilim) + rank (1) + if (.not. (size(lim(:)) == size(ilim(:)))) & + call bsa_Abort('sizes of "lim" and "ilim" do not match.') + + this%limits_wz_(ilim(:)) = lim(:) + rank default + call bsa_Abort('expecting "ilim" to be a 1-rank array.') + endselect + + else + + if (.not. this%nz_ == 0) then + if (.not. (size(lim(:)) == this%nz_ + 1)) & + call bsa_Abort('size of "lim" does not match number of wind zones.') + else + this%nz_ = size(lim(:)) - 1 + endif + this%limits_wz_ => lim(:) + endif ! present ilim + + + rank default + call bsa_Abort('Expeting "lim" either to be a scalar or a 1-rank array.') + endselect + end subroutine SetWindZoneLimits + + + + + + module subroutine SetAirDensity(aird) + real(RDP), intent(in) :: aird + + if (aird < 0._RDP) call bsa_Abort('Air density has a negative value.') + air_dens_ = aird + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetAirDensity() : air density set -- ok.' +#endif + end subroutine SetAirDensity + + + + + module subroutine SetGlobalW2G(mat) + real(RDP), intent(in) :: mat(3, 3) + integer(kind = 4) :: istat + character(len = 256) :: emsg + + if (.not. allocated(rot_W2G_)) then + allocate(rot_W2G_(3, 3), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('rot_W2G_', [3, 3], loc(rot_W2G_), sizeof(rot_W2G_)) +#endif + else + call allocKOMsg('rot_W2G_', istat, emsg) + endif + endif + rot_W2G_ = mat + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetGlobalW2G() : global rotation matrix WIND-GLOB set -- ok.' +#endif + end subroutine SetGlobalW2G + + + + + module subroutine SetWZMeanWindVel(this, UBref) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: UBref(this%nz_) + + this%u_mean_ref_wz_ => UBref + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') & + INFOMSG, & + '@WindImpl::SetWZMeanWindVel() : wind zone mean wind speeds (at reference altitude) set -- ok.' +#endif + end subroutine SetWZMeanWindVel + + + + + module subroutine SetWZRefAlt(this, Zref) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: Zref(this%nz_) + + this%Zref_wz_ => Zref + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetWZRefAlt() : wind zones reference altitudes set -- ok.' +#endif + end subroutine SetWZRefAlt + + + + + module subroutine SetTurbWindScales(this, L) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: L(3, 3, this%nz_) + + this%turb_scales_wz_ => L + end subroutine SetTurbWindScales + + + + + module subroutine SetTurbWindSDT(this, wtstd) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: wtstd(3, this%nz_) + + this%sigmaUVW_wz_ => wtstd + end subroutine SetTurbWindSDT + + + + + module subroutine SetWindCorrCoeffs(this, corrcoeff) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: corrcoeff(3, 3, this%nz_) + + this%corrCoeffs_wz_ => corrcoeff + end subroutine SetWindCorrCoeffs + + + + + module subroutine SetWindCorrExpnts(this, correxpn) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: correxpn(3, 3, this%nz_) + + this%corrExp_wz_ => correxpn + end subroutine SetWindCorrExpnts + + + + + + module subroutine SetIncidenceAngles(this, incang) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: incang(this%nz_) + + this%incAng_wz_ => incang + end subroutine SetIncidenceAngles + + + + + + module subroutine SetLocalRotMatW2G(this, rotW2G_L) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: rotW2G_L(3, 3, this%nz_) + + this%rot_LW2G_wz_ => rotW2G_L + end subroutine SetLocalRotMatW2G + + + + + module subroutine setWindDirections(this, dirs, ndirs) + class(WindData_t) :: this + integer(kind = 4), intent(in) :: dirs(:) + integer(kind = 4), intent(in), optional :: ndirs + integer(kind = 4) :: itmp + + itmp = size(dirs) + + if (present(ndirs)) then + if (itmp /= ndirs) then + print '(1x, a, a/)', & + ERRMSG, 'Size mismatch in setting spatial directions.' + call bsa_Abort() + endif + endif + + this%i_ndirs_ = itmp + this%dirs_ = dirs(1 : itmp) + end subroutine + + + + module subroutine setTurbComps(this, tc, ntc) + class(WindData_t) :: this + integer(kind = 4), intent(in) :: tc(:) + integer(kind = 4), intent(in), optional :: ntc + integer(kind = 4) :: itmp + + itmp = size(tc) + + if (present(ntc)) then + if (itmp /= ntc) then + print '(1x, a, a/)', & + ERRMSG, 'Size mismatch in setting turbulent components.' + call bsa_Abort() + endif + endif + + this%i_ntc_ = itmp + this%tc_ = tc(1 : itmp) + end subroutine + + + + + + module subroutine SetTurbCompsAndDirsDefault(this) + class(WindData_t), intent(inout) :: this + integer :: itmp + integer(kind = 4) :: istat + character(len = 256) :: emsg + + this%i_ntc_ = 1 + if (.not. allocated(this%tc_)) then + allocate(this%tc_(1), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('this % tc_', 1, loc(this%tc_), sizeof(this%tc_)) +#endif + else + call allocKOMsg('this % tc_', istat, emsg) + endif + else + itmp = size(this%tc_) + if (itmp /= 1) then + deallocate(this%tc_) + allocate(this%tc_(1), stat=istat, errmsg=emsg) + if (istat == 0) then +#ifdef __BSA_ALLOC_DEBUG + call allocOKMsg('this % tc_', 1, loc(this%tc_), sizeof(this%tc_)) +#endif + else + call allocKOMsg('this % tc_', istat, emsg) + endif + endif + endif + this%tc_(1) = 1 + + this%i_ndirs_ = 1 + if (.not. allocated(this%dirs_)) then + allocate(this%dirs_(1)) + else + itmp = size(this%dirs_) + if (itmp /= 1) then + deallocate(this%dirs_) + allocate(this%dirs_(1)) + endif + endif + this%dirs_(1) = 1 + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') & + INFOMSG, & + '@WindImpl::SetTurbCompsAndDirsDefault() : default direction and turbulent components set -- ok.' +#endif + end subroutine SetTurbCompsAndDirsDefault + + + + + + module subroutine SetNodalVel(this, Unod) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: Unod(:) + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetNodalVel() : setting nodal velocities...' +! #endif + + this%u_node_ => Unod + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetNodalVel() : setting nodal velocities -- ok.' +#endif + end subroutine SetNodalVel + + + + + module subroutine SetNodalWindZones(this, NodWZ) + class(WindData_t), intent(inout) :: this + integer(kind = 4), target, intent(in) :: NodWZ(:) + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetNodalWindZones() : setting nodal wind zones...' +! #endif + + this%wz_node_ => NodWZ + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetNodalWindZones() : setting nodal wind zones -- ok.' +#endif + end subroutine SetNodalWindZones + + + + + + module subroutine SetNodalWindAltitudes(this, WnodAlt) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: WnodAlt(:) + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetNodalWindAltitudes() : setting nodal wind altitudes...' +! #endif + + this%wAlt_node_ => WnodAlt + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetNodalWindAltitudes() : setting nodal wind altitudes -- ok.' +#endif + end subroutine SetNodalWindAltitudes + + + + + + + module subroutine SetSpatialNodalCorr(this, nodCorr) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: nodCorr(:, :) + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetSpatialNodalCorr() : setting spatial nodal correlation...' +! #endif + + this%nod_corr_ => nodCorr + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetSpatialNodalCorr() : setting spatial nodal correlation -- ok.' +#endif + end subroutine SetSpatialNodalCorr + + + + module subroutine getFull2DNodCorrMat(this, nn, nodcorr2d) + use BsaLib_Utility, only: util_getCorrVectIndex + class(WindData_t), intent(in) :: this + integer(kind = 4), intent(in) :: nn + real(RDP), allocatable, intent(inout) :: nodcorr2d(:, :) + integer :: i_ = 0, j_, id_ + + if (.not. associated(this%nod_corr_)) return + + if (.not. allocated(nodcorr2d)) allocate(nodcorr2d(nn, nn), stat=i_) + if (i_ /= 0) return + do j_ = 1, nn + do i_ = 1, nn + id_ = util_getCorrVectIndex(i_, j_, nn) + nodcorr2d(i_, j_) = this%nod_corr_(id_, 1) + enddo + enddo + end subroutine + + + + + module subroutine SetWindFCoeffs(this, wfc) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: wfc(:, :, :) + +! #ifdef __BSA_DEBUG +! write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetWindFCoeffs() : setting wind forces coefficients...' +! #endif + + this%wfc_ => wfc + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetWindFCoeffs() : setting wind forces coefficients -- ok.' +#endif + end subroutine SetWindFCoeffs + + + + + + module subroutine SetPhitimesC(this, phiTc) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: phiTc(:, :, :) + + + this%phi_times_A_ndegw_ => phiTc + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::SetPhitimesC() : setting projected wind forces coefficients -- ok.' +#endif + end subroutine SetPhitimesC + + + + + + + + module subroutine clean(this) + class(WindData_t) :: this + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::clean() : cleaning up...' +#endif + + if (allocated(rot_W2G_)) deallocate(rot_W2G_) + + if (associated(this%u_node_)) nullify(this%u_node_) + if (associated(this%wz_node_)) nullify(this%wz_node_) + if (associated(this%nod_corr_)) nullify(this%nod_corr_) + if (associated(this%wfc_)) nullify(this%wfc_) + if (associated(this%phi_times_A_ndegw_)) nullify(this%phi_times_A_ndegw_) + + if (associated(this%sigmaUVW_wz_)) nullify(this%sigmaUVW_wz_) + if (associated(this%turb_scales_wz_)) nullify(this%turb_scales_wz_) + if (associated(this%corrCoeffs_wz_)) nullify(this%corrCoeffs_wz_) + if (associated(this%corrExp_wz_)) nullify(this%corrExp_wz_) + if (associated(this%u_mean_ref_wz_)) nullify(this%u_mean_ref_wz_) + if (associated(this%Zref_wz_)) nullify(this%Zref_wz_) + if (associated(this%rot_LW2G_wz_)) nullify(this%rot_LW2G_wz_) + if (associated(this%limits_wz_)) nullify(this%limits_wz_) + if (associated(this%incAng_wz_)) nullify(this%incAng_wz_) + + if (allocated(this%psd_)) deallocate(this%psd_) + +#ifdef __BSA_DEBUG + write(unit_debug_, '(1x, a, a)') INFOMSG, '@WindImpl::clean() : cleaning up -- ok.' +#endif + end subroutine clean + + + + + + +end submodule \ No newline at end of file diff --git a/src/BsaLib/wind/WindType.f90 b/src/BsaLib/wind/WindType.f90 new file mode 100644 index 0000000..ef4a4c9 --- /dev/null +++ b/src/BsaLib/wind/WindType.f90 @@ -0,0 +1,417 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module BsaLib_WindData + +#include "../precisions" + + use Logging + use BsaLib_IO, only: unit_dump_bfm_, unit_debug_, undebug_fname_ + use BsaLib_CONSTANTS + use BsaLib_Settings + implicit none + private + + + !************************************************************************************** + ! WIND LABELs + !************************************************************************************** + character(len = *), dimension(6), public, parameter :: CST_PSD_TYPES = [& + 'VON_KARMAN ' & + , 'KAIMAL ' & + , 'DAVENPORT ' & + , 'EUROCODE ' & + , 'DAVENPORT_REFORM ' & + , 'ORNSTEIN_UHLENBECK' & + &] + + + + character(len = *), dimension(5), public, parameter :: CST_WIND_V_PROFILES = [& + 'POWER ' & + , 'LOGARITHM ' & + , 'MILLAU ' & + , 'MILLAU MAQ' & + , 'GLOB. POW ' & + &] + !! NOTE: some wind profile definitions come from real measurement campaigns + !! conducted by Greisch Design Office (Liège, Belgium) for the + !! design of the Millau Bridge (Millau, France). + + + + + ! ----- private variables + real(RDP) :: air_dens_ = 1.225_RDP + real(RDP), allocatable :: rot_W2G_(:, :) ! rotation from GRS to WRS (global) + + + type, public :: psd_t + procedure(PSDfunc), nopass, private, pointer :: psd_fct_ptr => null() + contains + procedure, public, pass :: SetPSDFunction + end type psd_t + + + + type, public :: WindData_t + + !> N. of wind zones + integer(kind = 4) :: nz_ = 0 + + + !> PSD type (VonKarman, Davenport, Kaimal, etc..). + integer(kind = 4) :: i_psd_type_ = 5 + + !> If true, using same nodal wind speed everywhere. + integer(kind = 4) :: i_eq_nod_wind_speed_ = 0 + + !> Wind vertical profile (Power, Log). + integer(kind = 4) :: i_wind_prof_ = 2 + + !> Specifies which of the three is the main + !> structural direction (for wind altidude!!) + integer(kind = 4) :: i_vert_ = 3 + + + + + !> Number of considered turbulent components + !> By default ==1, i.e. only u(t) considered. + integer(kind = 4) :: i_ntc_ = 1 + + !> List of considered wind turbulent components + !> Range from 1 (u) to 3 (w). + integer(kind = 4), allocatable :: tc_(:) + + !> How many spatial directions are considered + !> By default ==1, only direction parallel to mean wind. + integer(kind = 4) :: i_ndirs_ = 1 + + !> List of considered spatial directions. + !> Range from 1 (u) to 3 (w). + integer(kind = 4), allocatable :: dirs_(:) + + + + + + + !> Actual nodal wind speeds (i.e. dipending on altitude, and wind zone) + real(RDP), pointer :: u_node_(:) => null() + + !> Wind loaded nodes' wind zone + integer(kind = 4), pointer :: wz_node_(:) => null() + + !> Nodal Wind Altitudes (needed for some PSDs computation) + real(RDP), pointer :: wAlt_node_(:) => null() + + !> Nodal spatial coherence + !! + !! NOTE: dimensions [(NN**2 + NN)/2, 3-dirs]) + !! Hence, reconstruct 2D sym matrix if needed. + real(RDP), pointer :: nod_corr_(:, :) => null() + + + + + + + !> Wind forces coefficients (nlib_l, ndegw+3, nnodes_l) + real(RDP), pointer :: wfc_(:, :, :) => null() + + !> Wind forces coefficients projected onto modal base (pre-computed) + !> NOTE: dimensions (NM, NNL, NDEGW) + real(RDP), pointer :: phi_times_A_ndegw_(:, :, :) => null() + + + + + + + !> u(t), v(t), w(t) std deviations [m] (per wind zone) + real(RDP), pointer :: sigmaUVW_wz_(:, :) => null() + + !> Lu_xyz, Lv_xyz, Lw_xyz wind turbulence scales [m] (per wind zone) + real(RDP), pointer :: turb_scales_wz_(:, :, :) => null() + + !> Spatial turbulence correlation coefficients + real(RDP), pointer :: corrCoeffs_wz_(:, :, :) => null() + + !> Spatial turbulence correlation exponents + real(RDP), pointer :: corrExp_wz_(:, :, :) => null() + + !> reference altitude [m] (per wind zone) + real(RDP), pointer :: Zref_wz_(:) => null() + + !> Mean Wind Speed at Zref (ref altitude) [m/s] (per wind zone) + real(RDP), pointer :: u_mean_ref_wz_(:) => null() + + !> Rotation matrix from LWRS (Local Element) to GRS + real(RDP), pointer :: rot_LW2G_wz_(:, :, :) => null() + + !> Wind zones limits + !> (might be along X, Y, Z, depending on relative orientation) + real(RDP), pointer :: limits_wz_(:) => null() + + !> Mean wind incidence angle (per wind zone) + real(RDP), pointer :: incAng_wz_(:) => null() + + + + !> internal PSd type variable + type(psd_t), allocatable, private :: psd_ + + contains + + procedure, public, nopass :: SetAirDensity + procedure, public, nopass :: SetGlobalW2G + procedure, public, pass :: SetWindVertProf + procedure, public, pass :: SetPSDType + procedure, public, pass :: SetMainVertDir + procedure, public, pass :: SetNodalVel + procedure, public, pass :: SetNodalWindZones + procedure, public, pass :: SetSpatialNodalCorr + procedure, public, pass :: getFull2DNodCorrMat + procedure, public, pass :: SetWindFCoeffs + procedure, public, pass :: SetPhitimesC + procedure, public, pass :: SetNodalWindAltitudes + procedure, public, pass :: SetWindZoneLimits + procedure, public, pass :: SetWZMeanWindVel + procedure, public, pass :: SetWZRefAlt + procedure, public, pass :: SetTurbWindScales + procedure, public, pass :: SetTurbWindSDT + procedure, public, pass :: SetWindCorrCoeffs + procedure, public, pass :: SetWindCorrExpnts + procedure, public, pass :: SetLocalRotMatW2G + procedure, public, pass :: SetIncidenceAngles + + procedure, public, pass :: setTurbComps + procedure, public, pass :: setWindDirections + procedure, public, pass :: SetTurbCompsAndDirsDefault + + procedure, public, pass :: evalPSD => evalPSD_ + + procedure, public, pass :: getFullNodalPSD + + procedure, public, pass :: clean + end type WindData_t + + + + + abstract interface + function PSDfunc(wd, nf, freqs, innl, nodes_loaded, idir, itc) result(PSD) + import WindData_t, RDP + class(WindData_t), intent(in) :: wd + integer(kind = 4), intent(in) :: nf ! n. frequencies + integer(kind = 4), intent(in) :: innl ! n. actual nodes loaded + integer(kind = 4), intent(in) :: idir ! wind direction + integer(kind = 4), intent(in) :: itc ! turb component id + real(RDP), intent(in) :: freqs(nf) ! frequencies + integer(kind = 4), intent(in) :: nodes_loaded(innl) ! list of actual loaded nodes + real(RDP), dimension(nf, innl) :: PSD + end function + end interface + + + + interface + + module subroutine SetAirDensity(aird) + real(RDP), intent(in) :: aird + end subroutine + + + module subroutine SetGlobalW2G(mat) + real(RDP), intent(in) :: mat(3, 3) + end subroutine + + + module subroutine SetWindVertProf(this, ivaru) + class(WindData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ivaru + end subroutine + + + module subroutine SetPSDType(this, ipsd) + class(WindData_t), intent(inout) :: this + integer(kind = 4), value :: ipsd + end subroutine + + + module subroutine SetMainvertDir(this, ivert) + class(WindData_t), intent(inout) :: this + integer(kind = 4), intent(in) :: ivert + end subroutine + + + module subroutine SetWindZoneLimits(this, lim, ilim) + class(WindData_t), intent(inout) :: this + real(RDP), intent(in), target :: lim(..) + integer(kind = 4), intent(in), optional :: ilim(..) + end subroutine + + + module subroutine SetWZMeanWindVel(this, UBref) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: UBref(this%nz_) + end subroutine + + + module subroutine SetWZRefAlt(this, Zref) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: Zref(this%nz_) + end subroutine + + + module subroutine SetTurbWindScales(this, L) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: L(3, 3, this%nz_) + end subroutine + + + module subroutine SetTurbWindSDT(this, wtstd) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: wtstd(3, this%nz_) + end subroutine + + module subroutine SetWindCorrCoeffs(this, corrcoeff) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: corrcoeff(3, 3, this%nz_) + end subroutine + + module subroutine SetWindCorrExpnts(this, correxpn) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: correxpn(3, 3, this%nz_) + end subroutine + + module subroutine SetIncidenceAngles(this, incang) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: incang(this%nz_) + end subroutine + + + module subroutine SetLocalRotMatW2G(this, rotW2G_L) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: rotW2G_L(3, 3, this%nz_) + end subroutine + + + + module subroutine setWindDirections(this, dirs, ndirs) + class(WindData_t) :: this + integer(kind = 4), intent(in) :: dirs(:) + integer(kind = 4), intent(in), optional :: ndirs + end subroutine + + + module subroutine setTurbComps(this, tc, ntc) + class(WindData_t) :: this + integer(kind = 4), intent(in) :: tc(:) + integer(kind = 4), intent(in), optional :: ntc + end subroutine + + + + module subroutine SetTurbCompsAndDirsDefault(this) + class(WindData_t), intent(inout) :: this + end subroutine + + + module subroutine SetNodalVel(this, Unod) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: Unod(:) + end subroutine + + + module subroutine SetNodalWindZones(this, NodWZ) + class(WindData_t), intent(inout) :: this + integer(kind = 4), target, intent(in) :: NodWZ(:) + end subroutine + + + module subroutine SetNodalWindAltitudes(this, WnodAlt) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: WnodAlt(:) + end subroutine + + + module subroutine SetSpatialNodalCorr(this, nodCorr) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: nodCorr(:, :) + end subroutine + + + module subroutine getFull2DNodCorrMat(this, nn, nodcorr2d) + class(WindData_t), intent(in) :: this + integer(kind = 4), intent(in) :: nn + real(RDP), allocatable, intent(inout) :: nodcorr2d(:, :) + end subroutine + + + module subroutine SetWindFCoeffs(this, wfc) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: wfc(:, :, :) + end subroutine + + + module subroutine SetPhitimesC(this, phiTc) + class(WindData_t), intent(inout) :: this + real(RDP), target, intent(in) :: phiTc(:, :, :) + end subroutine + + + + + module subroutine SetPSDFunction(this, func) + import psd_t + class(psd_t) :: this + procedure(PSDfunc), intent(in), pointer :: func + end subroutine + + + + + + module function evalPSD_(this, nf, f, innl, nnl, idir, itc) result(PSD) + class(WindData_t), intent(in) :: this + integer(kind = 4), intent(in) :: nf, innl, idir, itc + integer(kind = 4), intent(in) :: nnl(innl) + real(RDP), intent(in) :: f(nf) + real(RDP) :: PSD(nf, innl) + end function + + + + module function getFullNodalPSD(this, innl, nodesl, PSDvec, f, idir) result(PSDmat) + class(WindData_t), intent(in) :: this + integer(kind = 4), intent(in) :: innl, idir + integer(kind = 4), intent(in) :: nodesl(innl) + real(RDP), intent(in) :: PSDvec(innl) + real(RDP), intent(in) :: f + real(RDP) :: PSDmat(innl, innl) + end function + + + + module subroutine clean(this) + class(WindData_t) :: this + end subroutine + + end interface + + +end module \ No newline at end of file diff --git a/src/bsa.f90 b/src/bsa.f90 new file mode 100644 index 0000000..e3929dc --- /dev/null +++ b/src/bsa.f90 @@ -0,0 +1,1243 @@ +!! This file is part of BSA Library. +!! Copyright (C) 2023 Michele Esposito Marzino +!! +!! BSA Library is free software: you can redistribute it and/or modify +!! it under the terms of the GNU General Public License as published by +!! the Free Software Foundation, either version 3 of the License, or +!! (at your option) any later version. +!! +!! BSA Library is distributed in the hope that it will be useful, +!! but WITHOUT ANY WARRANTY; without even the implied warranty of +!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!! GNU General Public License for more details. +!! +!! You should have received a copy of the GNU General Public License +!! along with BSA Library. If not, see . +module data + + use BsaLib + + implicit none + public + integer(kind = 4), parameter :: IUN_BSADATA = 22222 + integer(kind = 4), parameter :: IUN_FINDATA = 22223 + logical :: l_formmode = .false. + logical :: fin_data_read_ = .false. + logical :: bsa_data_read_ = .false. + character(len = :), allocatable :: FINFILE_FNAME_ + + + integer(kind = 4) :: i_suban, i_vers, i_defsc, i_psd, i_bisp, i_onlyd, i_test + integer(kind = 4) :: i_bispsym, i_3dsym, i_nfreqs + real(kind = 8) :: r_df + integer(kind = 4) :: i_svd, i_bkgrfmt, i_bkgaext, i_genpaext, i_maxaext, i_fcov, i_dumpmod + + integer(kind = 4) :: i_ntc, i_ndirs, tc(3), dirs(3) + + integer(kind = 4) :: i_nnodes, i_nlibs, i_nnodesl, i_nlibsl + integer(kind = 4), target, allocatable :: nodesl(:), libsl(:) + real(kind = 8), target, allocatable :: nod_cords(:, :) + + integer(kind = 4) :: i_varu, i_su, i_vert, i_degw + integer(kind = 4) :: i_nzones + real(kind = 8) :: r_aird, r_rotW2G(3, 3) + real(kind = 8), target, allocatable :: r_Zref_z(:), r_UBref_z(:), r_alph_z(:), r_lims_z(:) + real(kind = 8), target, allocatable :: r_L_z(:, :, :), r_std_z(:, :), r_corrC_z(:, :, :) + real(kind = 8), target, allocatable :: r_corrEx_z(:, :, :), r_rotW2G_z(:, :, :), r_incang_z(:) + + integer(kind = 4), target, allocatable :: i_wzNod(:) + real(kind = 8), target, allocatable :: r_wAltNod(:), r_UBnod(:), r_corrNod(:, :) + + real(kind = 8), target, allocatable :: r_wfc(:, :, :) + + integer(kind = 4) :: i_nm, i_ndofs + real(kind = 8), target, allocatable :: r_natf(:), r_modm(:, :) + real(kind = 8), target, allocatable :: r_Mg(:), r_Kg(:), r_Cg(:, :) + real(kind = 8), target, allocatable :: r_xsist(:), r_xsiad(:) + + logical :: use_custom_damping_ = .false. + real(kind = 8), allocatable :: custom_damp_val_(:) + + integer(kind = 4) :: i_exprt_mode_ = BSA_EXPORT_MODE_APPEND + integer(kind = 4) :: i_exprt_form_ = BSA_EXPORT_FORMAT_FORMATTED + logical :: export_results_to_files_ = .true. +end module data + + + +!========================================================================================= +!========================================================================================= +! MAIN PROGRAM +!========================================================================================= +!========================================================================================= +program bsa + + use data + + implicit none + + ! local, used to retrieve single run BSA results + real(kind = 8), allocatable :: bkg_(:), res_(:) + real(kind = 8), allocatable :: m2mf_(:), m2mr_(:), m2o2mr_(:) ! NOTE: implicitly classic + real(kind = 8), allocatable :: m3mf_cls_(:), m3mr_cls_(:) + real(kind = 8), allocatable :: m3mf_msh_(:), m3mr_msh_(:) + + + real(kind = 8), allocatable, dimension(:) :: m2_r_diag, m3_r_diag, sk_r_diag, m2o2_r_diag + real(kind = 8), allocatable, dimension(:) :: m2_r_full, m3_r_full, sk_r_full, m2o2_r_full + + real(kind = 8), allocatable :: peak_pos_r_diag_g(:), peak_pos_r_diag_ng(:) + real(kind = 8), allocatable :: peak_pos_r_full_g(:), peak_pos_r_full_ng(:) + real(kind = 8), allocatable :: extr_pos_r_diag_g(:), extr_pos_r_diag_ng(:) + real(kind = 8), allocatable :: extr_pos_r_full_g(:), extr_pos_r_full_ng(:) + + real(kind = 8), allocatable :: peak_neg_r_diag_ng(:) + real(kind = 8), allocatable :: peak_neg_r_full_ng(:) + real(kind = 8), allocatable :: extr_neg_r_diag_ng(:) + real(kind = 8), allocatable :: extr_neg_r_full_ng(:) + + character(len = *), parameter :: exp_prfx = 'export_' + character(len = *), parameter :: cls_sffx = 'cls', msh_sffx = 'msh' + character(len = *), parameter :: exp_fext = '.txt', udscr = '_' + character(len = :), allocatable :: fname, cmb_sffx + + +#ifdef __BSA_CL +# define BSACL_SFFX_ //'_CL' +#else +# ifdef __BSA_CUDA +# define BSACL_SFFX_ //'_CUDA' +# else +# define BSACL_SFFX_ +# endif +#endif + + +!========================================================================================= +! MAIN BODY +!========================================================================================= + call bsa_printBSAHeader() + call printTool() + call parseArgs() + + ! set defaults for entities not provided by user. + if (.not. allocated(FINFILE_FNAME_)) FINFILE_FNAME_ = 'bsa.findata' + call readDataFiles() + + call setup() + + ! NOTE: save in r_xsist the total, before pass it + if (use_custom_damping_) then + print '(1x, 2a, g, a)', & + WARNMSG, 'Using custom damping of ', custom_damp_val_(1), ' for all modes.' + r_xsist(:) = custom_damp_val_(1) + endif + call bsa_setTotDamping(r_xsist) + + ! BUG: allow bsa_Run to accept already allocated entities + ! (check for size match). + call bsa_Run(m2mf_, m2mr_, m2o2mr_, m3mf_msh_, m3mr_msh_, m3mf_cls_, m3mr_cls_) + + ! POST-PROCESSING + if (export_results_to_files_) then + + + if (i_onlyd) then + cmb_sffx = 'diag' BSACL_SFFX_ + else + cmb_sffx = 'full' BSACL_SFFX_ + endif + + block + integer(kind = 4), allocatable :: i_modes(:) + + i_modes = bsa_getUsedModeShapes() + + if (allocated(m2mf_)) then + call bsa_computeBRdecomp(m2mf_, bkg_, res_) + fname = exp_prfx // 'm2_BR_decomp.txt' + call bsa_exportBRdecomp(fname, bkg_, res_, r_xsist(i_modes)) + + fname = exp_prfx // 'm2_mf_' // cls_sffx // udscr // cmb_sffx // exp_fext + call bsa_exportMomentToFile(fname, m2mf_) + + if (allocated(m3mf_cls_)) & + call bsa_exportSkewness(exp_prfx // 'sk_mf_' // cls_sffx // udscr // cmb_sffx // exp_fext, m2mf_, m3mf_cls_) + if (allocated(m3mf_msh_)) & + call bsa_exportSkewness(exp_prfx // 'sk_mf_' // msh_sffx // udscr // cmb_sffx // exp_fext, m2mf_, m3mf_msh_) + endif + + + if (allocated(m2mr_)) then + + fname = exp_prfx // 'm2_mr_' // cls_sffx // udscr // cmb_sffx // exp_fext + call bsa_exportMomentToFile(fname, m2mr_) + + if (allocated(m3mr_msh_)) then + fname = exp_prfx // 'sk_mr_' // msh_sffx // udscr // cmb_sffx // exp_fext + call bsa_exportSkewness(fname, m2mr_, m3mr_msh_) + call modalRecombination(r_modm(:, i_modes), m2mr_, m3mr_msh_, m2o2mr_) + endif + + if (allocated(m3mr_cls_)) then + fname = exp_prfx // 'sk_mr_' // cls_sffx // udscr // cmb_sffx // exp_fext + call bsa_exportSkewness(fname, m2mr_, m3mr_cls_) + if (.not. allocated(m3mr_msh_)) & + call modalRecombination(r_modm(:, i_modes), m2mr_, m3mr_cls_, m2o2mr_) + endif + + + ! TODO: introduce proper T variable + call bsa_computePeakFactors(m2_r_diag, m2o2_r_diag, 600.d0, peak_pos_r_diag_g, sk_r_diag, peak_pos_r_diag_ng, peak_neg_r_diag_ng) + call bsa_computePeakFactors(m2_r_full, m2o2_r_full, 600.d0, peak_pos_r_full_g, sk_r_full, peak_pos_r_full_ng, peak_neg_r_full_ng) + + + if (allocated(sk_r_full)) then + fname = exp_prfx // 'sk_r_full' // exp_fext + call bsa_exportSkewness(fname, sk_r_full) + endif + + + ! TODO: maybe check if file already exists + call bsa_saveCoordinatesToFile('coordinates.txt') + + if (i_onlyd == 0) then + if (allocated(peak_pos_r_diag_g)) then + fname = exp_prfx // 'peak_pos_r_' // cmb_sffx // 'D' // '_g' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, peak_pos_r_diag_g) + extr_pos_r_diag_g = peak_pos_r_diag_g * sqrt(m2_r_diag) + fname = exp_prfx // 'extr_pos_r_' // cmb_sffx // 'D' // '_g' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, extr_pos_r_diag_g) + endif + + if (allocated(peak_pos_r_diag_ng)) then + fname = exp_prfx // 'peak_pos_r_' // cmb_sffx // 'D' // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, peak_pos_r_diag_ng) + extr_pos_r_diag_ng = peak_pos_r_diag_ng * sqrt(m2_r_diag) + fname = exp_prfx // 'extr_pos_r_' // cmb_sffx // 'D' // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, extr_pos_r_diag_ng) + endif + if (allocated(peak_neg_r_diag_ng)) then + fname = exp_prfx // 'peak_neg_r_' // cmb_sffx // 'D' // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, peak_neg_r_diag_ng) + extr_neg_r_diag_ng = peak_neg_r_diag_ng * sqrt(m2_r_diag) + fname = exp_prfx // 'extr_neg_r_' // cmb_sffx // 'D' // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, extr_neg_r_diag_ng) + endif + + if (allocated(peak_pos_r_full_g)) then + fname = exp_prfx // 'peak_pos_r_' // cmb_sffx // 'F' // '_g' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, peak_pos_r_full_g) + extr_pos_r_full_g = peak_pos_r_full_g * sqrt(m2_r_full) + fname = exp_prfx // 'extr_pos_r_' // cmb_sffx // 'F' // '_g' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, extr_pos_r_full_g) + endif + + if (allocated(peak_pos_r_full_ng)) then + fname = exp_prfx // 'peak_pos_r_' // cmb_sffx // 'F' // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, peak_pos_r_full_ng) + extr_pos_r_full_ng = peak_pos_r_full_ng * sqrt(m2_r_full) + fname = exp_prfx // 'extr_pos_r_' // cmb_sffx // 'F' // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, extr_pos_r_full_ng) + endif + if (allocated(peak_neg_r_full_ng)) then + fname = exp_prfx // 'peak_neg_r_' // cmb_sffx // 'F' // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, peak_neg_r_full_ng) + extr_neg_r_full_ng = peak_neg_r_full_ng * sqrt(m2_r_full) + fname = exp_prfx // 'extr_neg_r_' // cmb_sffx // 'F' // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, extr_neg_r_full_ng) + endif + + else + + if (allocated(peak_pos_r_diag_g)) then + fname = exp_prfx // 'peak_pos_r_' // cmb_sffx // '_g' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, peak_pos_r_diag_g) + extr_pos_r_diag_g = peak_pos_r_diag_g * sqrt(m2_r_diag) + fname = exp_prfx // 'extr_pos_r_' // cmb_sffx // '_g' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, extr_pos_r_diag_g) + endif + + + if (allocated(peak_pos_r_diag_ng)) then + fname = exp_prfx // 'peak_pos_r_' // cmb_sffx // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, peak_pos_r_diag_ng) + extr_pos_r_diag_ng = peak_pos_r_diag_ng * sqrt(m2_r_diag) + fname = exp_prfx // 'extr_pos_r_' // cmb_sffx // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, extr_pos_r_diag_ng) + endif + if (allocated(peak_neg_r_diag_ng)) then + fname = exp_prfx // 'peak_neg_r_' // cmb_sffx // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, peak_neg_r_diag_ng) + extr_neg_r_diag_ng = peak_neg_r_diag_ng * sqrt(m2_r_diag) + fname = exp_prfx // 'extr_neg_r_' // cmb_sffx // '_ng' // exp_fext + call bsa_exportPeakOrExtremesToFile(fname, extr_neg_r_diag_ng) + endif + endif + + endif ! allocated m2mr + deallocate(i_modes) + + if (allocated(m3mf_cls_)) then + fname = exp_prfx // 'm3_mf_' // cls_sffx // udscr // cmb_sffx // exp_fext + call bsa_exportMomentToFile(fname, m3mf_cls_) + endif + if (allocated(m3mr_cls_)) then + fname = exp_prfx // 'm3_mr_' // cls_sffx // udscr // cmb_sffx // exp_fext + call bsa_exportMomentToFile(fname, m3mr_cls_) + endif + if (allocated(m3mf_msh_)) then + fname = exp_prfx // 'm3_mf_' // msh_sffx // udscr // cmb_sffx // exp_fext + call bsa_exportMomentToFile(fname, m3mf_msh_) + endif + if (allocated(m3mr_msh_)) then + fname = exp_prfx // 'm3_mr_' // msh_sffx // udscr // cmb_sffx // exp_fext + call bsa_exportMomentToFile(fname, m3mr_msh_) + endif + end block + endif + + if (allocated(m2mf_)) deallocate(m2mf_) + if (allocated(m3mf_cls_)) deallocate(m3mf_cls_) + if (allocated(m3mf_msh_)) deallocate(m3mf_msh_) + if (allocated(m2mr_)) deallocate(m2mr_) + if (allocated(m3mr_cls_)) deallocate(m3mr_cls_) + if (allocated(m3mr_msh_)) deallocate(m3mr_msh_) + if (allocated(m3mf_cls_)) deallocate(m3mf_cls_) + if (allocated(m3mr_cls_)) deallocate(m3mr_cls_) + if (allocated(m3mf_msh_)) deallocate(m3mf_msh_) + if (allocated(m3mr_msh_)) deallocate(m3mr_msh_) + + if (allocated(peak_pos_r_diag_g)) deallocate(peak_pos_r_diag_g) + if (allocated(peak_pos_r_diag_ng)) deallocate(peak_pos_r_diag_ng) + if (allocated(peak_pos_r_full_g)) deallocate(peak_pos_r_full_g) + if (allocated(peak_pos_r_full_ng)) deallocate(peak_pos_r_full_ng) + if (allocated(extr_pos_r_diag_g)) deallocate(extr_pos_r_diag_g) + if (allocated(extr_pos_r_diag_ng)) deallocate(extr_pos_r_diag_ng) + if (allocated(extr_pos_r_full_g)) deallocate(extr_pos_r_full_g) + if (allocated(extr_pos_r_full_ng)) deallocate(extr_pos_r_full_ng) + + + call releaseMemory(0) + +!========================================================================================= +!========================================================================================= +! END MAIN PROGRAM +!========================================================================================= +!========================================================================================= + + + +contains ! utility procedures + + + + + subroutine printTool() + print *, ' BSA - main program' + print *, ' Bispectral Stochastic Analysis of MDOFs systems under stationary actions.' + print * + end subroutine + + + subroutine usage() + print * + print *, ' Syntax:' + print *, ' bsa.exe [[options] file]' + print * + print *, ' options:' + print *, ' --readmode, -readmode, /readmode ' + print *, ' valid values:' + print *, ' formatted, unformatted (default)' + print * + print *, ' --force-damping, -force-damping, /force-damping ' + print *, ' If specified, uses damping for all modes.' + print *, ' For multiple values (parametric analysis), separate' + print *, ' values using semicolon, ex. val1;val2;val3;etc..' + print *, ' In such cases, BSA core is run multiple times.' + print * + print *, ' --no-append-exports, -no-append-exports, /no-append-exports' + print *, ' Overrides instead of appending to existing export files.' + print * + print *, ' --export-binary, -export-binary, /export-binary' + print *, ' Exports results using unformatted (binary) files.' + print * + print *, ' --no-export, -no-export, /no-export' + print *, ' Do not export results to files.' + print * + print *, ' --out-file, -out-file, /out-file ' + print *, ' If specified, uses as output file name.' + print * + print *, ' file: input file name.' + print *, ' If none is passed, automatically searches it into' + print *, ' the current directory (from where the program is invoked)' + + call releaseMemory(1) + end subroutine + + + + + function removeInputArgPlaceholder_(arg) result(arg_) +!DIR$ ATTRIBUTES FORCEINLINE :: removeInputArgPlaceholder_ + character(len = *), intent(in) :: arg + character(len = :), allocatable :: arg_ + character(len = *), parameter :: MINUS = '-' + + if (arg(1:1) == '/') then + + arg_ = arg(2 : len_trim(arg)) + + elseif (arg(1:1) == MINUS) then + + if (arg(2:2) == MINUS) then + arg_ = arg(3 : len_trim(arg)) + else + arg_ = arg(2 : len_trim(arg)) + endif + + else ! take it as such + + arg_ = arg(1 : len_trim(arg)) + endif + end function + + + + + + subroutine parseArgs() + !! Parse input arguments, if any. + integer :: argc + + argc = command_argument_count() + if (argc == 0) return + + block + integer :: i, currargc, istat + character(len = 64) :: arg + character(len = :), allocatable :: arg_ + + currargc = 1 + + ! main parsing loop + do + call get_command_argument(currargc, arg) + arg_ = removeInputArgPlaceholder_(arg) + + select case (arg_) + + case ('readmode') + currargc = currargc + 1 + call get_command_argument(currargc, arg, status=istat) + if (istat /= 0) call usage() + + select case (arg(1:len_trim(arg))) + case ('formatted') + l_formmode = .true. + case ('unformatted') + case default + call usage() + end select + + case ('force-damping') + currargc = currargc + 1 + call get_command_argument(currargc, arg, status=istat) + if (istat /= 0) call usage() + call getCustomXSIValues_(arg) + + + case ('no-append-exports') + i_exprt_mode_ = BSA_EXPORT_MODE_REPLACE + + case ('export-binary') + i_exprt_form_ = BSA_EXPORT_FORMAT_UNFORMATTED + + case ('no-export') + export_results_to_files_ = .false. + + + case ('out-file') + currargc = currargc + 1 + call get_command_argument(currargc, arg, status=istat) + if (istat /= 0) call usage() + call bsa_setOutFileName(arg(1 : len_trim(arg))) + + + case default ! input file + FINFILE_FNAME_ = arg_(1 : len_trim(arg_)) + + end select + + if (currargc == argc) exit ! parsing finished + + ! go to next input arg + currargc = currargc + 1 + enddo + + end block + + end subroutine parseArgs + + + + + + subroutine getCustomXSIValues_(arg) + character(len = *), intent(in) :: arg + integer :: iich, iech, lench, ixsi + ! BUG: limits to 20 xsi values. Allow infinite. + real(kind = 8) :: xsi_(20) + + lench = len_trim(arg) + if (lench == 0) goto 99 + iich = 1 + iech = 1 + ixsi = 0 + do while (iech <= lench) + if (arg(iech:iech) == ';') then + ixsi = ixsi + 1 + read(unit=arg(iich : iech-1), fmt='(f)', err=99) xsi_(ixsi) + iech = iech + 1 + iich = iech + else + iech = iech + 1 + endif + enddo + ! NOTE: treat last one (only one if no semicolon found) + ixsi = ixsi + 1 + read(unit=arg(iich : iech), fmt='(f)', err=99) xsi_(ixsi) + + ! if we get here, correctly read + use_custom_damping_ = .true. + custom_damp_val_ = xsi_(1 : ixsi) + return + + 99 print '(1x, a, a)', & + ERRMSG, 'Error while parsing damping values. Please check again.' + call usage() + end subroutine + + + + + + ! subroutine allocGlobFromLocSizes(loc, glob, n) + ! real(kind = 8), allocatable, intent(in) :: loc(:) + ! real(kind = 8), allocatable, intent(out) :: glob(:, :) + ! integer, intent(in) :: n + ! integer :: dim + + ! if (allocated(loc)) then + ! dim = size(loc) + ! allocate(glob(dim, n)) + ! endif + ! end subroutine + + + ! subroutine moveAllocToGlob(glob, loc, idx) + ! real(kind = 8), intent(out) :: glob(:, :) + ! real(kind = 8), allocatable :: loc(:) + ! integer, intent(in) :: idx + + ! if (allocated(loc)) then + ! ! is a memcpy + ! glob(:, idx) = loc + ! deallocate(loc) + ! endif + ! end subroutine + + + + + + + subroutine setup() + !! This routine collects all the + !! calls to the BsaLibrary interface routines, + !! before launch of the main computing process. + + + ! NOTE: everything before bsa_Init() does not affect global (internal) vars. + + call bsa_setExportInCurrDir() ! NOTE: this to not break plotter functioning.. + call bsa_closeUnitsAtEnd() + call bsa_setExportFileFormat(i_exprt_form_) + call bsa_setExportAppendMode(i_exprt_mode_) + + call bsa_setBRMExportDefaultMode(BSA_EXPORT_BRM_MODE_NONE) + + call bsa_setBfmMLR(.false.) + call bsa_forceBsaClsExecution(.true.) + + call bsa_setValidateDeltasPolicy(BSA_VALIDATE_DELTAS_POLICY_NONE) + + call bsa_setMaxBkgPeakRestriction(.true.) + + call bsa_setPODTruncationThreshold(100.d0) + + call bsa_Init() ! This initialises all necessary instances. + + ! SETTINGS + if (i_suban /= 0) call bsa_setSubanType(i_suban) + if (i_vers /= 0) call bsa_setVersion(i_vers) + if (i_defsc /= 0) call bsa_setScalingConv(i_defsc) + call bsa_setSpectraComputation(ipsd=i_psd, ibisp=i_bisp) + call bsa_setSpectraExtension(i_onlyd) + call bsa_setSymmetries(i_bispsym, i_3dsym) + call bsa_setTestMode(i_test) + call bsa_setupClassic(i_nfreqs, r_df) + call bsa_setupMesher(& + i_svd, i_bkgrfmt, i_bkgaext, i_genpaext, i_maxaext, i_fcov, i_dumpmod) + call bsa_setWindDirections(dirs(1 : i_ndirs), i_ndirs) + call bsa_setWindTurbComps(tc(1 : i_ntc), i_ntc) + + ! NODAL + call bsa_setTotalNOfNodes(i_nnodes) + call bsa_setNodalNOfDOFs(i_nlibs) + call bsa_setLoadedNodes(nodesl) + call bsa_setLoadedNodalDOFs(libsl) + call bsa_setNodalCoords(i_nnodes, nod_cords) + + ! WIND + call bsa_setWindVertProf(i_varu) + call bsa_setPSDType(i_su) + call bsa_setWindAltDir(i_vert) + call bsa_setWindZoneLimits(r_lims_z) + call bsa_setAirDensity(r_aird) + call bsa_setGlobalRotMatW2G(r_rotW2G) + call bsa_setWZMeanWindVel(r_UBref_z) + call bsa_setWZRefAlt(r_Zref_z) + call bsa_setTurbWindScales(r_L_z) + call bsa_setTurbWindSDT(r_std_z) + call bsa_setWindCorrCoeffs(r_corrC_z) + call bsa_setWindCorrExpnts(r_corrEx_z) + call bsa_setWZRotMatW2G(r_rotW2G_z) + call bsa_setIncidenceAngles(r_incang_z) + call bsa_setNodalVel(r_UBnod) + call bsa_setNodalWindZones(i_wzNod) + call bsa_setNodalWindAltitudes(r_wAltNod) + call bsa_setSpatialNodalCorr(r_corrNod) + + ! NOTE: in BSA, we want only LOADED NODES. + r_wfc = r_wfc(:, :, nodesl) + call bsa_setWindFCoeffs(r_wfc) + + ! MODAL + call bsa_setModalInfo(i_ndofs, i_nm, r_modm, r_natf) + call bsa_setModalMatrices(i_nm, r_Mg, r_Kg, r_Cg) + + end subroutine setup + + + + + + + subroutine errAllocVarMsg_(varname, istat, emsg) + character(len = *), intent(in) :: varname, emsg + integer, intent(in) :: istat + + print '(/ 1x, 4a, i0)', & + ERRMSG, 'Cannot allocate "', varname, '". Error code ', istat + print '(1x, 3a /)', & + MSGCONT, 'Erorr message: ', emsg(1 : len_trim(emsg)) + + call releaseMemory(2) + end subroutine + + + subroutine errDeallocVarMsg_(varname, istat, emsg) + character(len = *), intent(in) :: varname, emsg + integer, intent(in) :: istat + + print '(/ 1x, 4a, i0)', & + ERRMSG, 'Cannot de-allocate "', varname, '". Error code ', istat + print '(1x, 3a /)', & + MSGCONT, 'Erorr message: ', emsg(1 : len_trim(emsg)) + error stop + end subroutine + + + + + + + subroutine readDataFiles() + + call getFinData() + call getBsaData() + + if (.not. (bsa_data_read_ .and. fin_data_read_)) then + print '(1x, a, a)', & + ERRMSG, 'Error reading input data from files.' + call releaseMemory(5) + endif + +#ifdef __BSA_DEBUG + print '(1x, a, a)', & + INFOMSG, ' BSA data read correctly.' +#endif + end subroutine + + + + subroutine openFinelgInputFile() + integer :: istat + character(len = :), allocatable :: form_, access_ + + if (l_formmode) then + form_ = 'formatted' + access_ = 'sequential' + else + form_ = 'unformatted' + access_ = 'stream' + endif + + open(unit=IUN_FINDATA & + , file=FINFILE_FNAME_ & + , iostat=istat & + , form=form_ & + , access=access_ & + , action=IO_ACTION_READ) + + if (istat == 0) then +#ifdef _DEBUG + print '(1x, a, a)', DBGMSG, 'Input file correctly opened.' +#endif + rewind(IUN_FINDATA) + return + endif + + print * + print '(/1x, a, a, i0)', & + ERRMSG, 'Error opening input file. Error code ', istat + error stop + end subroutine + + + + subroutine getFinData() + integer :: istat, itmp + character(len = 132) :: emsg + + call openFinelgInputFile() + + if (l_formmode) then + read(IUN_FINDATA, *) i_nnodes + read(IUN_FINDATA, *) i_nlibs + read(IUN_FINDATA, *) i_nnodesl + read(IUN_FINDATA, *) i_nlibsl + else + read(IUN_FINDATA) i_nnodes + read(IUN_FINDATA) i_nlibs + read(IUN_FINDATA) i_nnodesl + read(IUN_FINDATA) i_nlibsl + endif + + allocate(nodesl(i_nnodesl), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('nodesl', istat, emsg) + + allocate(libsl(i_nlibsl), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('libsl', istat, emsg) + + allocate(nod_cords(i_nnodes, 3), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('nod_cords', istat, emsg) + + if (l_formmode) then + read(IUN_FINDATA, *) nodesl + read(IUN_FINDATA, *) libsl + read(IUN_FINDATA, *) nod_cords + else + read(IUN_FINDATA) nodesl + read(IUN_FINDATA) libsl + read(IUN_FINDATA) nod_cords + endif + nod_cords = transpose(nod_cords) + + + + if (l_formmode) then + read(IUN_FINDATA, *) i_varu + read(IUN_FINDATA, *) i_su + read(IUN_FINDATA, *) i_vert + read(IUN_FINDATA, *) i_degw + read(IUN_FINDATA, *) r_aird + read(IUN_FINDATA, *) r_rotW2G + read(IUN_FINDATA, *) i_nzones + else + read(IUN_FINDATA) i_varu + read(IUN_FINDATA) i_su + read(IUN_FINDATA) i_vert + read(IUN_FINDATA) i_degw + read(IUN_FINDATA) r_aird + read(IUN_FINDATA) r_rotW2G + read(IUN_FINDATA) i_nzones + endif + + allocate(r_Zref_z(i_nzones), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_Zref_z', istat, emsg) + allocate(r_UBref_z(i_nzones), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_UBref_z', istat, emsg) + allocate(r_alph_z(i_nzones), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_alph_z', istat, emsg) + allocate(r_L_z(3, 3, i_nzones), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_L_z', istat, emsg) + allocate(r_std_z(3, i_nzones), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_std_z', istat, emsg) + allocate(r_corrC_z(3, 3, i_nzones), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_corrC_z', istat, emsg) + allocate(r_corrEx_z(3, 3, i_nzones), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_corrEx_z', istat, emsg) + allocate(r_lims_z(i_nzones+1), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_lims_z', istat, emsg) + allocate(r_rotW2G_z(3, 3, i_nzones), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_rotW2G_z', istat, emsg) + allocate(r_incang_z(i_nzones), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_incang_z', istat, emsg) + + allocate(i_wzNod(i_nnodes), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('i_wzNod', istat, emsg) + allocate(r_wAltNod(i_nnodes), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_wAltNod', istat, emsg) + allocate(r_UBnod(i_nnodes), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_UBnod', istat, emsg) + itmp = i_nnodes * i_nnodes + itmp = (itmp + i_nnodes) / 2 + allocate(r_corrNod(itmp, 3), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_corrNod', istat, emsg) + + allocate(r_wfc(i_nlibsl, i_degw+3, i_nnodes), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_corrNod', istat, emsg) + + if (l_formmode) then + read(IUN_FINDATA, *) r_Zref_z + read(IUN_FINDATA, *) r_UBref_z + read(IUN_FINDATA, *) r_alph_z + read(IUN_FINDATA, *) r_L_z + read(IUN_FINDATA, *) r_std_z + read(IUN_FINDATA, *) r_corrC_z + read(IUN_FINDATA, *) r_corrEx_z + read(IUN_FINDATA, *) r_lims_z + read(IUN_FINDATA, *) r_rotW2G_z + read(IUN_FINDATA, *) r_incang_z + read(IUN_FINDATA, *) i_wzNod + read(IUN_FINDATA, *) r_wAltNod + read(IUN_FINDATA, *) r_UBnod + read(IUN_FINDATA, *) r_corrNod + + read(IUN_FINDATA, *) r_wfc + else + read(IUN_FINDATA) r_Zref_z + read(IUN_FINDATA) r_UBref_z + read(IUN_FINDATA) r_alph_z + read(IUN_FINDATA) r_L_z + read(IUN_FINDATA) r_std_z + read(IUN_FINDATA) r_corrC_z + read(IUN_FINDATA) r_corrEx_z + read(IUN_FINDATA) r_lims_z + read(IUN_FINDATA) r_rotW2G_z + read(IUN_FINDATA) r_incang_z + read(IUN_FINDATA) i_wzNod + read(IUN_FINDATA) r_wAltNod + read(IUN_FINDATA) r_UBnod + read(IUN_FINDATA) r_corrNod + + read(IUN_FINDATA) r_wfc + endif + + + + if (l_formmode) then + read(IUN_FINDATA, *) i_nm + read(IUN_FINDATA, *) i_ndofs + else + read(IUN_FINDATA) i_nm + read(IUN_FINDATA) i_ndofs + endif + allocate(r_natf(i_nm), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_natf', istat, emsg) + allocate(r_modm(i_ndofs, i_nm), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_modm', istat, emsg) + allocate(r_Mg(i_nm), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_Mg', istat, emsg) + allocate(r_Kg(i_nm), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_Kg', istat, emsg) + allocate(r_Cg(i_nm, i_nm), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_Cg', istat, emsg) + allocate(r_xsist(i_nm), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_xsist', istat, emsg) + allocate(r_xsiad(i_nm), stat=istat, errmsg=emsg) + if (istat /= 0) call errAllocVarMsg_('r_xsiad', istat, emsg) + if (l_formmode) then + read(IUN_FINDATA, *) r_natf + read(IUN_FINDATA, *) r_modm + read(IUN_FINDATA, *) r_Mg + read(IUN_FINDATA, *) r_Kg + read(IUN_FINDATA, *) r_Cg + read(IUN_FINDATA, *) r_xsist + read(IUN_FINDATA, *) r_xsiad + else + read(IUN_FINDATA) r_natf + read(IUN_FINDATA) r_modm + read(IUN_FINDATA) r_Mg + read(IUN_FINDATA) r_Kg + read(IUN_FINDATA) r_Cg + read(IUN_FINDATA) r_xsist + read(IUN_FINDATA) r_xsiad + endif + + fin_data_read_ = .true. + close(IUN_FINDATA) +#ifdef __BSA_DEBUG + print '(1x, a, a)', & + INFOMSG, 'FINELG data read correctly.' +#endif + end subroutine + + + + + + subroutine getBsaData() + character(len = 256) :: label + character(len = *), parameter :: fmt_a = '(a)', fmt_i = '(i)', fmt_f = '(f)' + integer :: i + + + if (.not. fin_data_read_) return + + open(unit=IUN_BSADATA & + , file='bsa.bsadata' & + , form='formatted' & + , action=IO_ACTION_READ) + + read(IUN_BSADATA, fmt_a) label + read(IUN_BSADATA, fmt_i) i_suban + read(IUN_BSADATA, fmt_i) i_vers + read(IUN_BSADATA, fmt_i) i_defsc + read(IUN_BSADATA, fmt_i) i_psd + read(IUN_BSADATA, fmt_i) i_bisp + read(IUN_BSADATA, fmt_i) i_onlyd + read(IUN_BSADATA, fmt_i) i_bispsym + read(IUN_BSADATA, fmt_i) i_3dsym + read(IUN_BSADATA, fmt_i) i_test + + read(IUN_BSADATA, fmt_a) label + read(IUN_BSADATA, fmt_i) i_nfreqs + read(IUN_BSADATA, fmt_f) r_df + + read(IUN_BSADATA, fmt_a) label + read(IUN_BSADATA, fmt_i) i_svd + read(IUN_BSADATA, fmt_i) i_bkgrfmt + read(IUN_BSADATA, fmt_i) i_bkgaext + read(IUN_BSADATA, fmt_i) i_genpaext + read(IUN_BSADATA, fmt_i) i_maxaext + read(IUN_BSADATA, fmt_i) i_fcov + read(IUN_BSADATA, fmt_i) i_dumpmod + + ! directions + read(IUN_BSADATA, fmt_a) label + read(IUN_BSADATA, fmt_i) i_ndirs + do i = 1, i_ndirs + read(IUN_BSADATA, fmt_i) dirs(i) + enddo + + ! turbulence + read(IUN_BSADATA, fmt_a) label + read(IUN_BSADATA, fmt_i) i_ntc + do i = 1, i_ntc + read(IUN_BSADATA, fmt_i) tc(i) + enddo + + ! ! nodes loaded + ! read(IUN_BSADATA, fmt_a) label + ! read(IUN_BSADATA, fmt_a) label + ! call getLoadedNodesFromString(label) + + bsa_data_read_ = .true. + end subroutine + + + + ! subroutine getLoadedNodesFromString(label) + ! !! BUG: for the moment, supports only 1 line (1 range) + ! character(len = *), intent(in) :: label + ! character(len = *), parameter :: col = ':' + ! integer :: ilen, ibl = 1, i, icount = 0, iini = 1 + ! integer :: vals(3), istat, ival + ! character(len = 132) :: emsg + + ! do while (label(ibl:ibl) == ' ') + ! ibl = ibl + 1 + ! enddo + + ! ilen = len_trim(label) + ! i = ibl + + ! if ( label(i : ilen) == 'all' ) then + + ! i_nnodesl = i_nnodes + ! nodesl = [1 : i_nnodesl] + ! goto 100 + ! end if + + ! do while (i <= ilen) + ! if (label(i:i) == col) then ! read left-side value + ! icount = icount + 1 + ! read(label(iini : i-1), fmt='(i)') vals(icount) + ! iini = i + 1 + ! endif + ! i = i + 1 + ! enddo + ! ! treat last value! + ! icount = icount + 1 + ! read(label(iini : ilen), fmt='(i)') vals(icount) + + + ! if (icount == 1) then ! only one node loaded + + ! i_nnodesl = 1 + ! if (vals(1) > i_nnodes) vals(1) = i_nnodes + ! nodesl = vals(1:1) + + ! elseif (icount == 2) then ! linspace + + ! if (vals(1) > i_nnodes) vals(1) = i_nnodes + ! if (vals(2) > i_nnodes) vals(2) = i_nnodes + + ! i_nnodesl = vals(2) - vals(1) + 1 + ! allocate(nodesl(i_nnodesl), stat=istat, errmsg=emsg) + ! if (istat /= 0) call errAllocVarMsg_('nodesl', istat, emsg) + ! ival = vals(1) - 1 + ! do i = 1, i_nnodesl + ! nodesl(i) = ival + i + ! enddo + + ! else ! ==3, range + + ! ! TODO: implement + ! error stop ERRMSG // ' IMPLEMENT ICOUNT=3' + ! endif + + ! 100 print '(1x, a, a)', & + ! INFOMSG, 'List of loaded nodes' + ! print '( 10( " ", i6) )', & + ! nodesl + ! end subroutine + + + + + + + + subroutine modalRecombination(r_Phi, m2mr, m3mr, m2o2mr) + real(kind = 8), intent(in) :: r_Phi(:, :), m2mr(:), m3mr(:) + real(kind = 8), intent(in), allocatable :: m2o2mr(:) + integer :: ndofs, nmodes, nm3 + integer :: idof, imode + integer :: imodeM1, posm2, posm3, itmp1 + logical :: is_diag + real(kind = 8) :: phi1, r_tmp + + + ndofs = size(r_Phi, 1) + nmodes = size(r_Phi, 2) + nm3 = size(m3mr) + + is_diag = nm3 == nmodes + + allocate(m2_r_diag(ndofs)) + m2_r_diag = 0 + allocate(m3_r_diag(ndofs)) + m3_r_diag = 0 + allocate(m2o2_r_diag(ndofs)) + m2o2_r_diag = 0 + + ! UNILATERAL (do it in any case) + do imode = 1, nmodes + + imodeM1 = imode - 1 + + if (is_diag) then + posm2 = imode + posm3 = imode + else + itmp1 = imodeM1 * nmodes + posm2 = itmp1 + imode + posm3 = itmp1*nmodes + posm2 + endif + + ! TODO: use do concurrent + do idof = 1, ndofs + + phi1 = r_Phi(idof, imode) + r_tmp = phi1 * phi1 + + + m2_r_diag(idof) = m2_r_diag(idof) + m2mr(posm2) * r_tmp + if (allocated(m2o2mr)) m2o2_r_diag(idof) = m2o2_r_diag(idof) + m2o2mr(posm2) * r_tmp + + r_tmp = r_tmp * phi1 + m3_r_diag(idof) = m3_r_diag(idof) + m3mr(posm3) * r_tmp + enddo ! idof + enddo ! imode + + sk_r_diag = m3_r_diag / (m2_r_diag)**(CST_3d2) + + + if (is_diag) return + + + ! CCC (Complete Cubic Combination) + allocate(m2_r_full(ndofs)) + m2_r_full = 0 + allocate(m3_r_full(ndofs)) + m3_r_full = 0 + allocate(m2o2_r_full(ndofs)) + m2o2_r_full = 0 + + block + integer :: jmode, kmode, jmodeM1, kmodeM1 + integer :: itmp12, itmp13, itmp23 + real(kind = 8), dimension(ndofs) :: phi2_, phi3_ + + do kmode = 1, nmodes + + kmodeM1 = kmode - 1 + phi3_ = r_Phi(:, kmode) + + itmp12 = kmodeM1 * nmodes + itmp13 = itmp12 * nmodes + + do jmode = 1, nmodes + + jmodeM1 = jmode - 1 + phi2_ = r_Phi(:, jmode) + itmp23 = jmodeM1 * nmodes + posm2 = itmp12 + jmode + + ! 2nd order + ! TODO: use do concurrent + do idof = 1, ndofs + + m2_r_full(idof) = m2_r_full(idof) + & + m2mr(posm2) * phi2_(idof) * phi3_(idof) + + if (allocated(m2o2mr)) & + m2o2_r_full(idof) = m2o2_r_full(idof) + & + m2o2mr(posm2) * phi2_(idof) * phi3_(idof) + enddo ! idof + + + do imode = 1, nmodes + + posm3 = itmp13 + itmp23 + imode + + ! TODO: use do concurrent + do idof = 1, ndofs + + phi1 = r_Phi(idof, imode) + + m3_r_full(idof) = m3_r_full(idof) + & + m3mr(posm3) * phi1 * phi2_(idof) * phi3_(idof) + enddo ! idof + enddo ! imode + enddo ! jmode + enddo ! kmode + + sk_r_full = m3_r_full / (m2_r_full)**(CST_3d2) + + end block + end subroutine + + + + + + subroutine releaseMemory(iexit) + integer, intent(in) :: iexit + integer :: istat + character(len = 132) :: emsg + logical :: lflag + + if (.not. bsa_isCleaned()) call bsa_Finalise() + + inquire(unit=IUN_FINDATA, opened=lflag) + if (lflag) close(IUN_FINDATA) + inquire(unit=IUN_BSADATA, opened=lflag) + if (lflag) close(IUN_BSADATA) + + istat = 0 + + if (allocated(nodesl)) deallocate(nodesl, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('nodesl', istat, emsg) + + if (allocated(libsl)) deallocate(libsl, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('libsl', istat, emsg) + + if (allocated(nod_cords)) deallocate(nod_cords, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('nod_cords', istat, emsg) + + + if (allocated(r_Zref_z)) deallocate(r_Zref_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_Zref_z', istat, emsg) + if (allocated(r_UBref_z)) deallocate(r_UBref_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_UBref_z', istat, emsg) + if (allocated(r_alph_z)) deallocate(r_alph_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_alph_z', istat, emsg) + if (allocated(r_L_z)) deallocate(r_L_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_L_z', istat, emsg) + if (allocated(r_std_z)) deallocate(r_std_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_std_z', istat, emsg) + if (allocated(r_corrC_z)) deallocate(r_corrC_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_corrC_z', istat, emsg) + if (allocated(r_corrEx_z)) deallocate(r_corrEx_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_corrEx_z', istat, emsg) + if (allocated(r_lims_z)) deallocate(r_lims_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_lims_z', istat, emsg) + if (allocated(r_rotW2G_z)) deallocate(r_rotW2G_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_rotW2G_z', istat, emsg) + if (allocated(r_incang_z)) deallocate(r_incang_z, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_incang_z', istat, emsg) + + if (allocated(i_wzNod)) deallocate(i_wzNod, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('i_wzNod', istat, emsg) + if (allocated(r_wAltNod)) deallocate(r_wAltNod, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_wAltNod', istat, emsg) + if (allocated(r_UBnod)) deallocate(r_UBnod, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_UBnod', istat, emsg) + if (allocated(r_corrNod)) deallocate(r_corrNod, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_corrNod', istat, emsg) + + if (allocated(r_wfc)) deallocate(r_wfc, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_corrNod', istat, emsg) + + + if (allocated(r_natf)) deallocate(r_natf, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_natf', istat, emsg) + if (allocated(r_modm)) deallocate(r_modm, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_modm', istat, emsg) + if (allocated(r_Mg)) deallocate(r_Mg, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_Mg', istat, emsg) + if (allocated(r_Kg)) deallocate(r_Kg, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_Kg', istat, emsg) + if (allocated(r_Cg)) deallocate(r_Cg, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_Cg', istat, emsg) + if (allocated(r_xsist)) deallocate(r_xsist, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_xsist', istat, emsg) + if (allocated(r_xsiad)) deallocate(r_xsiad, stat=istat, errmsg=emsg) + if (istat /= 0) call errDeallocVarMsg_('r_xsiad', istat, emsg) + + if (iexit == 0) then + print '(/ 1x, a, a)', INFOMSG, 'BSA terminated correctly.' + elseif (iexit > 1) then + print '(/ 1x, a, a, i0)', & + ERRMSG, 'BSA terminated with error. Exit status code ', iexit + endif + stop + end subroutine releaseMemory + + +end program \ No newline at end of file