From 3ca84c02b3505045d5469a995435aceed29505db Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Wed, 27 May 2026 17:33:10 +0200 Subject: [PATCH 01/43] GRIDEDIT-2102 Add closing point of polygon only if not already added --- tools/test_utils/src/PolygonReader.cpp | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tools/test_utils/src/PolygonReader.cpp b/tools/test_utils/src/PolygonReader.cpp index a1805fcc9..94fde5783 100644 --- a/tools/test_utils/src/PolygonReader.cpp +++ b/tools/test_utils/src/PolygonReader.cpp @@ -87,7 +87,10 @@ std::unique_ptr ReadPolygons(const std::string& fileName, points.push_back(readPoint(line)); } - points.push_back(points[currentSize]); + if (points[currentSize] != points.back ()) + { + points.push_back(points[currentSize]); + } } } } From f2420d93674e71ddcda90162cf50f0709d5aa3af Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Wed, 27 May 2026 17:43:01 +0200 Subject: [PATCH 02/43] GRIDEDIT-2102 First working version of calling the sepran triangulation from meshkernel --- libs/MeshKernel/tests/CMakeLists.txt | 7 + libs/MeshKernel/tests/src/MeshTests.cpp | 313 +++++++++++++++++++++++- 2 files changed, 309 insertions(+), 11 deletions(-) diff --git a/libs/MeshKernel/tests/CMakeLists.txt b/libs/MeshKernel/tests/CMakeLists.txt index 81cca6b35..570984d72 100644 --- a/libs/MeshKernel/tests/CMakeLists.txt +++ b/libs/MeshKernel/tests/CMakeLists.txt @@ -75,8 +75,15 @@ target_link_libraries( MeshKernelTestUtils gmock gtest_main + "/home/wcs1/SEPRAN/sepran/sepran/libsepran.a" + "-lgfortran" ) + # "-lifport" + # "-lifcore" + # "-lifcoremt" + + # Make sure that coverage information is produced when using gcc if(ENABLE_CODE_COVERAGE AND CMAKE_CXX_COMPILER_ID STREQUAL "GNU") target_compile_options( diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index 29d5c3eba..2ea24c02f 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -28,6 +28,8 @@ #include #include #include +#include +#include #include #include @@ -38,6 +40,7 @@ #include #include #include +#include TEST(Mesh, OneQuadTestConstructor) { @@ -147,24 +150,312 @@ TEST(Mesh2D, TriangulateSamplesWithSkinnyTriangle) ASSERT_EQ(4, mesh.GetEdge(5).second); } +extern "C" { + + extern void mshoce_( + const int* jnew, // Input: Reset indicator (Fortran Logical pointer) + double* coor, // Output: Flattened array of node coordinates + int* kmeshc, // Output: Connectivity/topology grid matrix + const int* inpelm, // Input: Element type identifier + const int* nbound, // Input: Number of boundary elements + double* bcord, // Input: Coordinates of boundary control nodes + + int* kbndpt, // Input: Type flags for boundary nodes + int* boundary, // Input: Edge-to-node connectivity map + const int* numcurvboun, // Input: Total count of curved boundary segments + int* npoint, // Output: Count of generated points + int* nelem, // Output: Count of generated elements + + int* holeinfo, // Input: Structural layout parameters for holes + const int* nholes, // Input: Total count of internal holes + const int* ncoar, // Input: Quantity of sizing descriptors passed + double* coar, // Input: Target element sizing arrays + int* userpoints, // Input: Fixed target internal points + + int* isurnr, // Output: Surface structural adjacency mapping register + const int* numextcurves, // Input: Auxiliary alignment curve flags + int* numnodextcurvs, // Input: Node mappings for alignment paths + + int* curvenumbers, // Input: Curve curvature flags + double* rinput, // Input: Supplementary sizing/weighting matrices + const int* nuspnt, // Input: Count of forced target control nodes + const int* ndim // Input: Domain spatial dimension identifier + ); +} + +// meshkernel::Mesh2D +meshkernel::Mesh2D generateMesh (const meshkernel::Polygons& poly [[maybe_unused]]) { + + const auto& polyline = poly.Enclosure (0).Outer ().Nodes (); + + + int nbound = static_cast(polyline.size() - 0); + int ndim = 2; + int inpelm = 3; // 3-node linear triangles + + // 1. Interleave coordinates into bcord: [x1, y1, x2, y2...] + // Flatten the boundary polygon. + std::vector bcord(2 * nbound); // TODO should be 2 * nbound + + for (int i = 0; i < nbound; ++i) { + bcord[2 * i] = polyline[i].x; + bcord[2 * i + 1] = polyline[i].y; + } + + // 2. Map kbndpt: Fortran uses 1-based indexing + std::vector kbndpt(nbound, 0); + + for (int i = 0; i < nbound; ++i) { + kbndpt[i] = i + 1; + } + + + // 3. Map boundary segments: Fortran boundary(2, numcurvboun) + // Flattened in Column-Major order: segment 1 points, then segment 2 points... + int numcurvboun = 1; + std::vector boundary(2 * numcurvboun); + + + for (int i = 0; i < numcurvboun; ++i) { + boundary[2 * i] = i + 1; + boundary[2 * i + 1] = i + 1; + } + + // 4. Compute coar array for local polyline point matching + int ncoar = 0;//nbound; + std::vector coar(1, 0.0);//3 * nbound); + + double min_coar = 1e20; + for (int i = 0; i < nbound; ++i) { + // If i == nbound - 1 then get the second point in the list, as the last one is the same as the first + int next = (i == nbound - 1) ? 1 : i + 1; + double dx = polyline[next].x - polyline[i].x; + double dy = polyline[next].y - polyline[i].y; + + min_coar = std::min (min_coar, std::sqrt(dx*dx + dy*dy)); + } + + + // 5. Dynamic Memory Allocation for Output Buffers + auto [estimated_area, centre, direction] = poly.Enclosure (0).Outer ().FaceAreaAndCenterOfMass(); // Estimate or compute dynamically via Shoelace formula + + + int estimated_elements = static_cast((estimated_area / (0.433 * min_coar * min_coar)) * 3.5); + int max_nodes = nbound + 3 * estimated_elements; + int max_elements = 2 * max_nodes; + + std::cout << " estimated size " << estimated_elements << " " << max_nodes << " "<< max_elements << std::endl; + std::cout << " estimated_area " << estimated_area << " " << min_coar << " " << estimated_elements << std::endl; + + + std::vector coor(ndim * max_nodes, 0.0); + std::vector kmeshc(inpelm * max_elements, 0); // 4 indices per element tracking matrix + + // 6. Dummies and Placeholders + int nholes = 0; + std::vector holeinfo(4, 0);// = {0, 0, 0, 0}; // 2x2 empty matrix + // int dummy_userpoint = 0; + int nuspnt = 0; + int isurnr = 1; // Initialize tracker to 0 + int numextcurves = 0; + + std::vector numnodextcurvs(1, 0); + std::vector curvenumbers(1, 0); + std::vector rinput(1, 0.0); + std::vector userpoints(1, 0); + + // 7. Make the Call + int jnew_fortran = 1; + int npoint = max_nodes; + int nelem = max_elements; + + + mshoce_(&jnew_fortran, coor.data(), kmeshc.data(), &inpelm, &nbound, bcord.data(), + kbndpt.data(), boundary.data(), &numcurvboun, &npoint, &nelem, + holeinfo.data(), &nholes, &ncoar, coar.data(), userpoints.data(), + &isurnr, &numextcurves, numnodextcurvs.data(), curvenumbers.data(), + rinput.data(), &nuspnt, &ndim); + + std::vector nodes (npoint); + + for (int i = 0; i < npoint; ++i) + { + nodes [i].x = coor [2 * i]; + nodes [i].y = coor [2 * i + 1]; + } + + // std::vector edges; + // edges.reserve (3 * nelem); + + // for (int i = 0; i < nelem; ++i) { + // int idx = 3 * i; + + // meshkernel::UInt n1 = static_cast(kmeshc [idx] - 1); + // meshkernel::UInt n2 = static_cast(kmeshc [idx+ 1] - 1); + // meshkernel::UInt n3 = static_cast(kmeshc [idx + 2] - 1); + + // meshkernel::Edge e1 = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1); + // meshkernel::Edge e2 = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2); + // meshkernel::Edge e3 = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3); + + // if (std::find(edges.begin (), edges.end (), e1) == edges.end ()) + // { + // edges.push_back (e1); + // } + + // if (std::find(edges.begin (), edges.end (), e2) == edges.end ()) + // { + // edges.push_back (e2); + // } + + // if (std::find(edges.begin (), edges.end (), e3) == edges.end ()) + // { + // edges.push_back (e3); + // } + + // } + + // Alternative + + std::vector edges (3 * nelem); + + for (int i = 0; i < nelem; ++i) { + int idx = 3 * i; + + meshkernel::UInt n1 = static_cast(kmeshc [idx] - 1); + meshkernel::UInt n2 = static_cast(kmeshc [idx+ 1] - 1); + meshkernel::UInt n3 = static_cast(kmeshc [idx + 2] - 1); + + // Which is better, reserve and push back or allocate and assign? + edges [idx] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1); + edges [idx + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2); + edges [idx + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3); + + // edges.push_back (n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1)); + // edges.push_back (n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2)); + // edges.push_back (n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3)); + } + + auto edgeLessThan = [](const meshkernel::Edge& e1, const meshkernel::Edge& e2) + { + if (e1.first < e2.first) + { + return true; + } + else if (e1.first == e2.first) + { + return e1.second < e2.second; + } + else + { + return false; + } + }; + + std::sort(std::execution::par, edges.begin (), edges.end (), edgeLessThan); + auto [first, last] = std::ranges::unique(edges); + edges.erase(first, last); + + // TODO need to pass the projection + // TODO probably need to handle the projection correctly when setting things up, + // e.g. the minimum coarseness. + return meshkernel::Mesh2D (edges, nodes, meshkernel::Projection::cartesian); +} + TEST(Mesh, TriangulateSamples) { // Prepare - std::vector nodes; - nodes.push_back({498.503152894023, 1645.82297461613}); - nodes.push_back({-5.90937355559299, 814.854361678898}); - nodes.push_back({851.30035347439, 150.079471329115}); - nodes.push_back({1411.11078745316, 1182.22995897746}); - nodes.push_back({501.418832237663, 1642.90729527249}); - nodes.push_back({498.503152894023, 1645.82297461613}); + // std::vector nodes{{0.0, 0.0}, {100.0, 0.0}, {100.0, 100.0}, {0.0, 100.0}, {0.0, 0.0} }; + // // std::vector nodes{{0.0, 0.0}, {10.0, 0.0}, {10.0, 10.0}, {0.0, 10.0}, {0.0, 0.0} }; - meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); + // // nodes.push_back({498.503152894023, 1645.82297461613}); + // // nodes.push_back({-5.90937355559299, 814.854361678898}); + // // nodes.push_back({851.30035347439, 150.079471329115}); + // // nodes.push_back({1411.11078745316, 1182.22995897746}); + // // nodes.push_back({501.418832237663, 1642.90729527249}); + // // nodes.push_back({498.503152894023, 1645.82297461613}); - // Execute - const auto generatedPoints = polygons.ComputePointsInPolygons(); + // meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); - meshkernel::Mesh2D mesh(generatedPoints[0], polygons, meshkernel::Projection::cartesian); + // nodes = polygons.RefineFirstPolygon (0, 4, 25); + // // nodes = polygons.RefineFirstPolygon (0, 4, 2.5); + // // nodes = polygons.RefineFirstPolygon (0, 1, 1.0); + // meshkernel::Polygons polygons1(nodes, meshkernel::Projection::cartesian); + + + // for (size_t i = 0; i < nodes.size (); ++i) + // { + // std::cout << " nodes " << i << " " << nodes [i].x << ", " << nodes[i].y << std::endl; + // } + + + // nodes = polygons1.RefineFirstPolygon (4, 8, 5.0); + // // nodes = polygons1.RefineFirstPolygon (4, 8, 0.5); + // // nodes = polygons1.RefineFirstPolygon (10, 11, 2.0); + // meshkernel::Polygons polygons2(nodes, meshkernel::Projection::cartesian); + + // // Execute + // const auto generatedPoints = polygons2.ComputePointsInPolygons(); + + // for (size_t i = 0; i < generatedPoints[0].size (); ++i) + // { + // std::cout << " pont " << i << " " << generatedPoints[0] [i].x << ", " << generatedPoints[0][i].y << std::endl; + // } + + + + auto polys = ReadPolygons ("/home/wcs1/MeshKernel/MeshKernel01/build_deb/northbank_001b.pol", meshkernel::Projection::cartesian); + + // std::vector nodes{{0.0, 0.0}, {2.5, 0}, {5.0, 0.0}, {7.5, 0}, {10.0, 0.0}, + // {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, + // {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, + // {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}}; + + // // std::vector nodes{{0.0, 0.0}, {5.0, 0.0}, {10.0, 0.0}, + // // {10.0, 5.0}, {10.0, 10.0}, {5.0, 10.0}, + // // {0.0, 10.0}, {0.0, 5.0}, {0.0, 0.0}}; + + // meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); + // auto polys = &polygons; + // auto mesh2 = generateMesh (polygons); + auto mesh2 = generateMesh (*polys); + + meshkernel::SaveVtk (mesh2.Nodes (), mesh2.m_facesNodes, "trianglemesh.vtu"); + + // auto polys = ReadPolygons ("/home/wcs1/MeshKernel/MeshKernel01/build_deb/northbank_001b.pol", meshkernel::Projection::cartesian); + // generateMesh (*polys); + return; + + const auto generatedPoints = polys->ComputePointsInPolygons(); + + auto pnts = polys->GatherAllEnclosureNodes (); + + for (size_t i = 0; i < pnts.size (); ++i ) + { + for (size_t j = i + 1; j < pnts.size (); ++j ) + { + + if (pnts[i] == pnts[j]) + { + std::cout << " equal points " << i << " " << j << " " << pnts[i].x << ", " << pnts[i].y << std::endl; + } + + } + } + + meshkernel::Mesh2D mesh(generatedPoints[0], *polys, meshkernel::Projection::cartesian); + + + // std::cout << std::endl; + // std::cout << std::endl; + + // for (size_t i = 0; i < mesh.Nodes ().size (); ++i) + // { + // std::cout << " pont " << i << " " << mesh.Nodes ()[i].x << ", " << mesh.Nodes ()[i].y << std::endl; + // } + + meshkernel::SaveVtk (mesh.Nodes (), mesh.m_facesNodes, "trianglemesh.vtu"); } TEST(Mesh, TwoTrianglesDuplicatedEdges) From be95e30b8c7d33453b5a1122237d07943b10c009 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Thu, 4 Jun 2026 09:44:12 +0200 Subject: [PATCH 03/43] GRIDEDIT-2102 Some testing changes (will be removed when finished, passing to other computer) --- libs/MeshKernel/tests/src/MeshTests.cpp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index 2ea24c02f..e3a9cb72d 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -186,6 +186,8 @@ extern "C" { // meshkernel::Mesh2D meshkernel::Mesh2D generateMesh (const meshkernel::Polygons& poly [[maybe_unused]]) { + // auto polyline = poly.Enclosure (0).Outer ().Nodes (); + // std::ranges::reverse(polyline); const auto& polyline = poly.Enclosure (0).Outer ().Nodes (); From b9c847d923212b06011438d893dab97ca617998a Mon Sep 17 00:00:00 2001 From: BillSenior Date: Thu, 4 Jun 2026 10:29:56 +0200 Subject: [PATCH 04/43] GRIDEDIT-2102 Added hole in mesh --- libs/MeshKernel/tests/src/MeshTests.cpp | 157 +++++++++++------------- 1 file changed, 74 insertions(+), 83 deletions(-) diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index e3a9cb72d..2f71fbd63 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -25,11 +25,11 @@ // //------------------------------------------------------------------------------ +#include #include +#include #include #include -#include -#include #include #include @@ -150,46 +150,47 @@ TEST(Mesh2D, TriangulateSamplesWithSkinnyTriangle) ASSERT_EQ(4, mesh.GetEdge(5).second); } -extern "C" { +extern "C" +{ extern void mshoce_( - const int* jnew, // Input: Reset indicator (Fortran Logical pointer) - double* coor, // Output: Flattened array of node coordinates - int* kmeshc, // Output: Connectivity/topology grid matrix - const int* inpelm, // Input: Element type identifier - const int* nbound, // Input: Number of boundary elements - double* bcord, // Input: Coordinates of boundary control nodes - - int* kbndpt, // Input: Type flags for boundary nodes - int* boundary, // Input: Edge-to-node connectivity map - const int* numcurvboun, // Input: Total count of curved boundary segments - int* npoint, // Output: Count of generated points - int* nelem, // Output: Count of generated elements - - int* holeinfo, // Input: Structural layout parameters for holes - const int* nholes, // Input: Total count of internal holes - const int* ncoar, // Input: Quantity of sizing descriptors passed - double* coar, // Input: Target element sizing arrays - int* userpoints, // Input: Fixed target internal points - - int* isurnr, // Output: Surface structural adjacency mapping register - const int* numextcurves, // Input: Auxiliary alignment curve flags - int* numnodextcurvs, // Input: Node mappings for alignment paths - - int* curvenumbers, // Input: Curve curvature flags - double* rinput, // Input: Supplementary sizing/weighting matrices - const int* nuspnt, // Input: Count of forced target control nodes - const int* ndim // Input: Domain spatial dimension identifier + const int* jnew, // Input: Reset indicator (Fortran Logical pointer) + double* coor, // Output: Flattened array of node coordinates + int* kmeshc, // Output: Connectivity/topology grid matrix + const int* inpelm, // Input: Element type identifier + const int* nbound, // Input: Number of boundary elements + double* bcord, // Input: Coordinates of boundary control nodes + + int* kbndpt, // Input: Type flags for boundary nodes + int* boundary, // Input: Edge-to-node connectivity map + const int* numcurvboun, // Input: Total count of curved boundary segments + int* npoint, // Output: Count of generated points + int* nelem, // Output: Count of generated elements + + int* holeinfo, // Input: Structural layout parameters for holes + const int* nholes, // Input: Total count of internal holes + const int* ncoar, // Input: Quantity of sizing descriptors passed + double* coar, // Input: Target element sizing arrays + int* userpoints, // Input: Fixed target internal points + + int* isurnr, // Output: Surface structural adjacency mapping register + const int* numextcurves, // Input: Auxiliary alignment curve flags + int* numnodextcurvs, // Input: Node mappings for alignment paths + + int* curvenumbers, // Input: Curve curvature flags + double* rinput, // Input: Supplementary sizing/weighting matrices + const int* nuspnt, // Input: Count of forced target control nodes + const int* ndim // Input: Domain spatial dimension identifier ); } // meshkernel::Mesh2D -meshkernel::Mesh2D generateMesh (const meshkernel::Polygons& poly [[maybe_unused]]) { +meshkernel::Mesh2D generateMesh(const meshkernel::Polygons& poly [[maybe_unused]]) +{ // auto polyline = poly.Enclosure (0).Outer ().Nodes (); // std::ranges::reverse(polyline); - const auto& polyline = poly.Enclosure (0).Outer ().Nodes (); - + const auto& polyline = poly.Enclosure(0).Outer().Nodes(); int nbound = static_cast(polyline.size() - 0); int ndim = 2; @@ -199,63 +200,62 @@ meshkernel::Mesh2D generateMesh (const meshkernel::Polygons& poly [[maybe_unused // Flatten the boundary polygon. std::vector bcord(2 * nbound); // TODO should be 2 * nbound - for (int i = 0; i < nbound; ++i) { - bcord[2 * i] = polyline[i].x; + for (int i = 0; i < nbound; ++i) + { + bcord[2 * i] = polyline[i].x; bcord[2 * i + 1] = polyline[i].y; } // 2. Map kbndpt: Fortran uses 1-based indexing std::vector kbndpt(nbound, 0); - for (int i = 0; i < nbound; ++i) { + for (int i = 0; i < nbound; ++i) + { kbndpt[i] = i + 1; } - // 3. Map boundary segments: Fortran boundary(2, numcurvboun) // Flattened in Column-Major order: segment 1 points, then segment 2 points... int numcurvboun = 1; std::vector boundary(2 * numcurvboun); - - for (int i = 0; i < numcurvboun; ++i) { - boundary[2 * i] = i + 1; - boundary[2 * i + 1] = i + 1; + for (int i = 0; i < numcurvboun; ++i) + { + boundary[2 * i] = i + 1; + boundary[2 * i + 1] = i + 1; } // 4. Compute coar array for local polyline point matching - int ncoar = 0;//nbound; - std::vector coar(1, 0.0);//3 * nbound); + int ncoar = 0; // nbound; + std::vector coar(1, 0.0); // 3 * nbound); double min_coar = 1e20; - for (int i = 0; i < nbound; ++i) { + for (int i = 0; i < nbound; ++i) + { // If i == nbound - 1 then get the second point in the list, as the last one is the same as the first int next = (i == nbound - 1) ? 1 : i + 1; double dx = polyline[next].x - polyline[i].x; double dy = polyline[next].y - polyline[i].y; - min_coar = std::min (min_coar, std::sqrt(dx*dx + dy*dy)); + min_coar = std::min(min_coar, std::sqrt(dx * dx + dy * dy)); } - // 5. Dynamic Memory Allocation for Output Buffers - auto [estimated_area, centre, direction] = poly.Enclosure (0).Outer ().FaceAreaAndCenterOfMass(); // Estimate or compute dynamically via Shoelace formula - + auto [estimated_area, centre, direction] = poly.Enclosure(0).Outer().FaceAreaAndCenterOfMass(); // Estimate or compute dynamically via Shoelace formula int estimated_elements = static_cast((estimated_area / (0.433 * min_coar * min_coar)) * 3.5); int max_nodes = nbound + 3 * estimated_elements; int max_elements = 2 * max_nodes; - std::cout << " estimated size " << estimated_elements << " " << max_nodes << " "<< max_elements << std::endl; + std::cout << " estimated size " << estimated_elements << " " << max_nodes << " " << max_elements << std::endl; std::cout << " estimated_area " << estimated_area << " " << min_coar << " " << estimated_elements << std::endl; - std::vector coor(ndim * max_nodes, 0.0); std::vector kmeshc(inpelm * max_elements, 0); // 4 indices per element tracking matrix // 6. Dummies and Placeholders int nholes = 0; - std::vector holeinfo(4, 0);// = {0, 0, 0, 0}; // 2x2 empty matrix + std::vector holeinfo(4, 0); // = {0, 0, 0, 0}; // 2x2 empty matrix // int dummy_userpoint = 0; int nuspnt = 0; int isurnr = 1; // Initialize tracker to 0 @@ -271,19 +271,18 @@ meshkernel::Mesh2D generateMesh (const meshkernel::Polygons& poly [[maybe_unused int npoint = max_nodes; int nelem = max_elements; - mshoce_(&jnew_fortran, coor.data(), kmeshc.data(), &inpelm, &nbound, bcord.data(), kbndpt.data(), boundary.data(), &numcurvboun, &npoint, &nelem, holeinfo.data(), &nholes, &ncoar, coar.data(), userpoints.data(), &isurnr, &numextcurves, numnodextcurvs.data(), curvenumbers.data(), rinput.data(), &nuspnt, &ndim); - std::vector nodes (npoint); + std::vector nodes(npoint); for (int i = 0; i < npoint; ++i) { - nodes [i].x = coor [2 * i]; - nodes [i].y = coor [2 * i + 1]; + nodes[i].x = coor[2 * i]; + nodes[i].y = coor[2 * i + 1]; } // std::vector edges; @@ -319,19 +318,20 @@ meshkernel::Mesh2D generateMesh (const meshkernel::Polygons& poly [[maybe_unused // Alternative - std::vector edges (3 * nelem); + std::vector edges(3 * nelem); - for (int i = 0; i < nelem; ++i) { + for (int i = 0; i < nelem; ++i) + { int idx = 3 * i; - meshkernel::UInt n1 = static_cast(kmeshc [idx] - 1); - meshkernel::UInt n2 = static_cast(kmeshc [idx+ 1] - 1); - meshkernel::UInt n3 = static_cast(kmeshc [idx + 2] - 1); + meshkernel::UInt n1 = static_cast(kmeshc[idx] - 1); + meshkernel::UInt n2 = static_cast(kmeshc[idx + 1] - 1); + meshkernel::UInt n3 = static_cast(kmeshc[idx + 2] - 1); // Which is better, reserve and push back or allocate and assign? - edges [idx] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1); - edges [idx + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2); - edges [idx + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3); + edges[idx] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); + edges[idx + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge(n3, n2); + edges[idx + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge(n1, n3); // edges.push_back (n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1)); // edges.push_back (n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2)); @@ -354,14 +354,14 @@ meshkernel::Mesh2D generateMesh (const meshkernel::Polygons& poly [[maybe_unused } }; - std::sort(std::execution::par, edges.begin (), edges.end (), edgeLessThan); + std::sort(std::execution::par, edges.begin(), edges.end(), edgeLessThan); auto [first, last] = std::ranges::unique(edges); edges.erase(first, last); // TODO need to pass the projection // TODO probably need to handle the projection correctly when setting things up, // e.g. the minimum coarseness. - return meshkernel::Mesh2D (edges, nodes, meshkernel::Projection::cartesian); + return meshkernel::Mesh2D(edges, nodes, meshkernel::Projection::cartesian); } TEST(Mesh, TriangulateSamples) @@ -385,13 +385,11 @@ TEST(Mesh, TriangulateSamples) // // nodes = polygons.RefineFirstPolygon (0, 1, 1.0); // meshkernel::Polygons polygons1(nodes, meshkernel::Projection::cartesian); - // for (size_t i = 0; i < nodes.size (); ++i) // { // std::cout << " nodes " << i << " " << nodes [i].x << ", " << nodes[i].y << std::endl; // } - // nodes = polygons1.RefineFirstPolygon (4, 8, 5.0); // // nodes = polygons1.RefineFirstPolygon (4, 8, 0.5); // // nodes = polygons1.RefineFirstPolygon (10, 11, 2.0); @@ -405,14 +403,9 @@ TEST(Mesh, TriangulateSamples) // std::cout << " pont " << i << " " << generatedPoints[0] [i].x << ", " << generatedPoints[0][i].y << std::endl; // } + // auto polys = ReadPolygons ("/home/wcs1/MeshKernel/MeshKernel01/build_deb/northbank_001b.pol", meshkernel::Projection::cartesian); - - auto polys = ReadPolygons ("/home/wcs1/MeshKernel/MeshKernel01/build_deb/northbank_001b.pol", meshkernel::Projection::cartesian); - - // std::vector nodes{{0.0, 0.0}, {2.5, 0}, {5.0, 0.0}, {7.5, 0}, {10.0, 0.0}, - // {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, - // {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, - // {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}}; + std::vector nodes{{0.0, 0.0}, {2.5, 0}, {5.0, 0.0}, {7.5, 0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, {-998.0, -998.0}, {3.0, 3.0}, {6.0, 3.0}, {6.0, 6.0}, {3.0, 6.0}, {3.0, 3.0}}; // // std::vector nodes{{0.0, 0.0}, {5.0, 0.0}, {10.0, 0.0}, // // {10.0, 5.0}, {10.0, 10.0}, {5.0, 10.0}, @@ -421,9 +414,9 @@ TEST(Mesh, TriangulateSamples) // meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); // auto polys = &polygons; // auto mesh2 = generateMesh (polygons); - auto mesh2 = generateMesh (*polys); + auto mesh2 = generateMesh(*polys); - meshkernel::SaveVtk (mesh2.Nodes (), mesh2.m_facesNodes, "trianglemesh.vtu"); + meshkernel::SaveVtk(mesh2.Nodes(), mesh2.m_facesNodes, "trianglemesh.vtu"); // auto polys = ReadPolygons ("/home/wcs1/MeshKernel/MeshKernel01/build_deb/northbank_001b.pol", meshkernel::Projection::cartesian); // generateMesh (*polys); @@ -431,24 +424,22 @@ TEST(Mesh, TriangulateSamples) const auto generatedPoints = polys->ComputePointsInPolygons(); - auto pnts = polys->GatherAllEnclosureNodes (); + auto pnts = polys->GatherAllEnclosureNodes(); - for (size_t i = 0; i < pnts.size (); ++i ) + for (size_t i = 0; i < pnts.size(); ++i) { - for (size_t j = i + 1; j < pnts.size (); ++j ) + for (size_t j = i + 1; j < pnts.size(); ++j) { if (pnts[i] == pnts[j]) { - std::cout << " equal points " << i << " " << j << " " << pnts[i].x << ", " << pnts[i].y << std::endl; + std::cout << " equal points " << i << " " << j << " " << pnts[i].x << ", " << pnts[i].y << std::endl; } - } } meshkernel::Mesh2D mesh(generatedPoints[0], *polys, meshkernel::Projection::cartesian); - // std::cout << std::endl; // std::cout << std::endl; @@ -457,7 +448,7 @@ TEST(Mesh, TriangulateSamples) // std::cout << " pont " << i << " " << mesh.Nodes ()[i].x << ", " << mesh.Nodes ()[i].y << std::endl; // } - meshkernel::SaveVtk (mesh.Nodes (), mesh.m_facesNodes, "trianglemesh.vtu"); + meshkernel::SaveVtk(mesh.Nodes(), mesh.m_facesNodes, "trianglemesh.vtu"); } TEST(Mesh, TwoTrianglesDuplicatedEdges) From 354130d254669ebf03c8c0c4df1c532ef075bf80 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Thu, 4 Jun 2026 11:06:47 +0200 Subject: [PATCH 05/43] GRIDEDIT-2102 Can now handle triangulation around holes --- libs/MeshKernel/tests/src/MeshTests.cpp | 525 +++++++++++++++++------- 1 file changed, 366 insertions(+), 159 deletions(-) diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index 2f71fbd63..8889ae2ac 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -184,185 +184,389 @@ extern "C" ); } -// meshkernel::Mesh2D -meshkernel::Mesh2D generateMesh(const meshkernel::Polygons& poly [[maybe_unused]]) -{ - - // auto polyline = poly.Enclosure (0).Outer ().Nodes (); - // std::ranges::reverse(polyline); - const auto& polyline = poly.Enclosure(0).Outer().Nodes(); - - int nbound = static_cast(polyline.size() - 0); - int ndim = 2; - int inpelm = 3; // 3-node linear triangles - - // 1. Interleave coordinates into bcord: [x1, y1, x2, y2...] - // Flatten the boundary polygon. - std::vector bcord(2 * nbound); // TODO should be 2 * nbound - - for (int i = 0; i < nbound; ++i) +// // meshkernel::Mesh2D +// meshkernel::Mesh2D generateMesh(const meshkernel::Polygons& poly [[maybe_unused]]) +// { + +// // auto polyline = poly.Enclosure (0).Outer ().Nodes (); +// // std::ranges::reverse(polyline); +// const auto& polyline = poly.Enclosure(0).Outer().Nodes(); + +// int nbound = static_cast(polyline.size() - 0); +// int ndim = 2; +// int inpelm = 3; // 3-node linear triangles + +// // 1. Interleave coordinates into bcord: [x1, y1, x2, y2...] +// // Flatten the boundary polygon. +// std::vector bcord(2 * nbound); // TODO should be 2 * nbound + +// for (int i = 0; i < nbound; ++i) +// { +// bcord[2 * i] = polyline[i].x; +// bcord[2 * i + 1] = polyline[i].y; +// } + +// // 2. Map kbndpt: Fortran uses 1-based indexing +// std::vector kbndpt(nbound, 0); + +// for (int i = 0; i < nbound; ++i) +// { +// kbndpt[i] = i + 1; +// } + +// // 3. Map boundary segments: Fortran boundary(2, numcurvboun) +// // Flattened in Column-Major order: segment 1 points, then segment 2 points... +// int numcurvboun = 1; +// std::vector boundary(2 * numcurvboun); + +// for (int i = 0; i < numcurvboun; ++i) +// { +// boundary[2 * i] = i + 1; +// boundary[2 * i + 1] = i + 1; +// } + +// // 4. Compute coar array for local polyline point matching +// int ncoar = 0; // nbound; +// std::vector coar(1, 0.0); // 3 * nbound); + +// double min_coar = 1e20; +// for (int i = 0; i < nbound; ++i) +// { +// // If i == nbound - 1 then get the second point in the list, as the last one is the same as the first +// int next = (i == nbound - 1) ? 1 : i + 1; +// double dx = polyline[next].x - polyline[i].x; +// double dy = polyline[next].y - polyline[i].y; + +// min_coar = std::min(min_coar, std::sqrt(dx * dx + dy * dy)); +// } + +// // 5. Dynamic Memory Allocation for Output Buffers +// auto [estimated_area, centre, direction] = poly.Enclosure(0).Outer().FaceAreaAndCenterOfMass(); // Estimate or compute dynamically via Shoelace formula + +// int estimated_elements = static_cast((estimated_area / (0.433 * min_coar * min_coar)) * 3.5); +// int max_nodes = nbound + 3 * estimated_elements; +// int max_elements = 2 * max_nodes; + +// std::cout << " estimated size " << estimated_elements << " " << max_nodes << " " << max_elements << std::endl; +// std::cout << " estimated_area " << estimated_area << " " << min_coar << " " << estimated_elements << std::endl; + +// std::vector coor(ndim * max_nodes, 0.0); +// std::vector kmeshc(inpelm * max_elements, 0); // 4 indices per element tracking matrix + +// // 6. Dummies and Placeholders +// int nholes = 0; +// std::vector holeinfo(4, 0); // = {0, 0, 0, 0}; // 2x2 empty matrix +// // int dummy_userpoint = 0; +// int nuspnt = 0; +// int isurnr = 1; // Initialize tracker to 0 +// int numextcurves = 0; + +// std::vector numnodextcurvs(1, 0); +// std::vector curvenumbers(1, 0); +// std::vector rinput(1, 0.0); +// std::vector userpoints(1, 0); + +// // 7. Make the Call +// int jnew_fortran = 1; +// int npoint = max_nodes; +// int nelem = max_elements; + +// mshoce_(&jnew_fortran, coor.data(), kmeshc.data(), &inpelm, &nbound, bcord.data(), +// kbndpt.data(), boundary.data(), &numcurvboun, &npoint, &nelem, +// holeinfo.data(), &nholes, &ncoar, coar.data(), userpoints.data(), +// &isurnr, &numextcurves, numnodextcurvs.data(), curvenumbers.data(), +// rinput.data(), &nuspnt, &ndim); + +// std::vector nodes(npoint); + +// for (int i = 0; i < npoint; ++i) +// { +// nodes[i].x = coor[2 * i]; +// nodes[i].y = coor[2 * i + 1]; +// } + +// // std::vector edges; +// // edges.reserve (3 * nelem); + +// // for (int i = 0; i < nelem; ++i) { +// // int idx = 3 * i; + +// // meshkernel::UInt n1 = static_cast(kmeshc [idx] - 1); +// // meshkernel::UInt n2 = static_cast(kmeshc [idx+ 1] - 1); +// // meshkernel::UInt n3 = static_cast(kmeshc [idx + 2] - 1); + +// // meshkernel::Edge e1 = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1); +// // meshkernel::Edge e2 = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2); +// // meshkernel::Edge e3 = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3); + +// // if (std::find(edges.begin (), edges.end (), e1) == edges.end ()) +// // { +// // edges.push_back (e1); +// // } + +// // if (std::find(edges.begin (), edges.end (), e2) == edges.end ()) +// // { +// // edges.push_back (e2); +// // } + +// // if (std::find(edges.begin (), edges.end (), e3) == edges.end ()) +// // { +// // edges.push_back (e3); +// // } + +// // } + +// // Alternative + +// std::vector edges(3 * nelem); + +// for (int i = 0; i < nelem; ++i) +// { +// int idx = 3 * i; + +// meshkernel::UInt n1 = static_cast(kmeshc[idx] - 1); +// meshkernel::UInt n2 = static_cast(kmeshc[idx + 1] - 1); +// meshkernel::UInt n3 = static_cast(kmeshc[idx + 2] - 1); + +// // Which is better, reserve and push back or allocate and assign? +// edges[idx] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); +// edges[idx + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge(n3, n2); +// edges[idx + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge(n1, n3); + +// // edges.push_back (n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1)); +// // edges.push_back (n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2)); +// // edges.push_back (n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3)); +// } + +// auto edgeLessThan = [](const meshkernel::Edge& e1, const meshkernel::Edge& e2) +// { +// if (e1.first < e2.first) +// { +// return true; +// } +// else if (e1.first == e2.first) +// { +// return e1.second < e2.second; +// } +// else +// { +// return false; +// } +// }; + +// std::sort(std::execution::par, edges.begin(), edges.end(), edgeLessThan); +// auto [first, last] = std::ranges::unique(edges); +// edges.erase(first, last); + +// // TODO need to pass the projection +// // TODO probably need to handle the projection correctly when setting things up, +// // e.g. the minimum coarseness. +// return meshkernel::Mesh2D(edges, nodes, meshkernel::Projection::cartesian); +// } + +meshkernel::Mesh2D generateMesh(const meshkernel::Polygons& poly) + { + const auto& enclosure = poly.Enclosure(0); + + std::vector> boundaryLoops; + boundaryLoops.emplace_back(enclosure.Outer()); + + for (meshkernel::UInt i = 0; i < enclosure.NumberOfInner(); ++i) { - bcord[2 * i] = polyline[i].x; - bcord[2 * i + 1] = polyline[i].y; + boundaryLoops.emplace_back(enclosure.Inner(i)); } - // 2. Map kbndpt: Fortran uses 1-based indexing - std::vector kbndpt(nbound, 0); - - for (int i = 0; i < nbound; ++i) + int nbound = 0; + for (const auto& loop : boundaryLoops) { - kbndpt[i] = i + 1; + nbound += static_cast(loop.get().Size()); } - // 3. Map boundary segments: Fortran boundary(2, numcurvboun) - // Flattened in Column-Major order: segment 1 points, then segment 2 points... - int numcurvboun = 1; - std::vector boundary(2 * numcurvboun); + int ndim = 2; + int inpelm = 3; // 3-node linear triangles + int numcurvboun = static_cast(boundaryLoops.size()); + int nholes = numcurvboun - 1; - for (int i = 0; i < numcurvboun; ++i) - { - boundary[2 * i] = i + 1; - boundary[2 * i + 1] = i + 1; - } - - // 4. Compute coar array for local polyline point matching - int ncoar = 0; // nbound; - std::vector coar(1, 0.0); // 3 * nbound); + // 1. Interleave coordinates into bcord: [x1, y1, x2, y2...] + // Flatten the outer polygon followed by each inner polygon, without separators. + std::vector bcord(2 * nbound); - double min_coar = 1e20; - for (int i = 0; i < nbound; ++i) - { - // If i == nbound - 1 then get the second point in the list, as the last one is the same as the first - int next = (i == nbound - 1) ? 1 : i + 1; - double dx = polyline[next].x - polyline[i].x; - double dy = polyline[next].y - polyline[i].y; + // 2. Map kbndpt: Fortran uses 1-based indexing + std::vector kbndpt(nbound, 0); - min_coar = std::min(min_coar, std::sqrt(dx * dx + dy * dy)); - } + // 3. Map boundary segments: Fortran boundary(2, numcurvboun) + // One curve entry per closed loop, flattened in column-major order. + std::vector boundary(2 * numcurvboun); - // 5. Dynamic Memory Allocation for Output Buffers - auto [estimated_area, centre, direction] = poly.Enclosure(0).Outer().FaceAreaAndCenterOfMass(); // Estimate or compute dynamically via Shoelace formula + // 4. Compute coar array for local polyline point matching + int ncoar = 0; // nbound; + std::vector coar(1, 0.0); // 3 * nbound); - int estimated_elements = static_cast((estimated_area / (0.433 * min_coar * min_coar)) * 3.5); - int max_nodes = nbound + 3 * estimated_elements; - int max_elements = 2 * max_nodes; + double min_coar = 1e20; + double estimated_area = 0.0; + int pointOffset = 0; - std::cout << " estimated size " << estimated_elements << " " << max_nodes << " " << max_elements << std::endl; - std::cout << " estimated_area " << estimated_area << " " << min_coar << " " << estimated_elements << std::endl; + for (int loopIndex = 0; loopIndex < numcurvboun; ++loopIndex) + { + const auto& loop = boundaryLoops[loopIndex].get().Nodes(); - std::vector coor(ndim * max_nodes, 0.0); - std::vector kmeshc(inpelm * max_elements, 0); // 4 indices per element tracking matrix + boundary[2 * loopIndex] = loopIndex + 1; + boundary[2 * loopIndex + 1] = pointOffset + 1; - // 6. Dummies and Placeholders - int nholes = 0; - std::vector holeinfo(4, 0); // = {0, 0, 0, 0}; // 2x2 empty matrix - // int dummy_userpoint = 0; - int nuspnt = 0; - int isurnr = 1; // Initialize tracker to 0 - int numextcurves = 0; - - std::vector numnodextcurvs(1, 0); - std::vector curvenumbers(1, 0); - std::vector rinput(1, 0.0); - std::vector userpoints(1, 0); + for (int i = 0; i < static_cast(loop.size()); ++i) + { + bcord[2 * (pointOffset + i)] = loop[i].x; + bcord[2 * (pointOffset + i) + 1] = loop[i].y; + kbndpt[pointOffset + i] = pointOffset + i + 1; + } - // 7. Make the Call - int jnew_fortran = 1; - int npoint = max_nodes; - int nelem = max_elements; + for (int i = 0; i + 1 < static_cast(loop.size()); ++i) + { + double dx = loop[i + 1].x - loop[i].x; + double dy = loop[i + 1].y - loop[i].y; - mshoce_(&jnew_fortran, coor.data(), kmeshc.data(), &inpelm, &nbound, bcord.data(), - kbndpt.data(), boundary.data(), &numcurvboun, &npoint, &nelem, - holeinfo.data(), &nholes, &ncoar, coar.data(), userpoints.data(), - &isurnr, &numextcurves, numnodextcurvs.data(), curvenumbers.data(), - rinput.data(), &nuspnt, &ndim); + min_coar = std::min(min_coar, std::sqrt(dx * dx + dy * dy)); + } - std::vector nodes(npoint); + auto [loopArea, centre, direction] = boundaryLoops[loopIndex].get().FaceAreaAndCenterOfMass(); + estimated_area += (loopIndex == 0 ? 1.0 : -1.0) * std::abs(loopArea); - for (int i = 0; i < npoint; ++i) - { - nodes[i].x = coor[2 * i]; - nodes[i].y = coor[2 * i + 1]; + pointOffset += static_cast(loop.size()); } - // std::vector edges; - // edges.reserve (3 * nelem); - - // for (int i = 0; i < nelem; ++i) { - // int idx = 3 * i; - - // meshkernel::UInt n1 = static_cast(kmeshc [idx] - 1); - // meshkernel::UInt n2 = static_cast(kmeshc [idx+ 1] - 1); - // meshkernel::UInt n3 = static_cast(kmeshc [idx + 2] - 1); - - // meshkernel::Edge e1 = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1); - // meshkernel::Edge e2 = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2); - // meshkernel::Edge e3 = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3); - - // if (std::find(edges.begin (), edges.end (), e1) == edges.end ()) - // { - // edges.push_back (e1); - // } - - // if (std::find(edges.begin (), edges.end (), e2) == edges.end ()) - // { - // edges.push_back (e2); - // } - - // if (std::find(edges.begin (), edges.end (), e3) == edges.end ()) - // { - // edges.push_back (e3); - // } - - // } - - // Alternative - - std::vector edges(3 * nelem); + // 5. Dynamic Memory Allocation for Output Buffers + int estimated_elements = static_cast((estimated_area / (0.433 * min_coar * min_coar)) * 3.5); + int max_nodes = nbound + 3 * estimated_elements; + int max_elements = 2 * max_nodes; - for (int i = 0; i < nelem; ++i) - { - int idx = 3 * i; + std::cout << " estimated size " << estimated_elements << " " << max_nodes << " " << max_elements << std::endl; + std::cout << " estimated_area " << estimated_area << " " << min_coar << " " << estimated_elements << std::endl; - meshkernel::UInt n1 = static_cast(kmeshc[idx] - 1); - meshkernel::UInt n2 = static_cast(kmeshc[idx + 1] - 1); - meshkernel::UInt n3 = static_cast(kmeshc[idx + 2] - 1); + std::vector coor(ndim * max_nodes, 0.0); + std::vector kmeshc(inpelm * max_elements, 0); // 4 indices per element tracking matrix - // Which is better, reserve and push back or allocate and assign? - edges[idx] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); - edges[idx + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge(n3, n2); - edges[idx + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge(n1, n3); + // 6. Dummies and Placeholders + std::vector holeinfo(2 * (nholes + 2), 0); + // int dummy_userpoint = 0; + int nuspnt = 0; + int isurnr = 1; // Initialize tracker to 0 + int numextcurves = 0; + + std::vector numnodextcurvs(1, 0); + std::vector curvenumbers(1, 0); + std::vector rinput(1, 0.0); + std::vector userpoints(1, 0); + + // 7. Make the Call + int jnew_fortran = 1; + int npoint = max_nodes; + int nelem = max_elements; + + mshoce_(&jnew_fortran, coor.data(), kmeshc.data(), &inpelm, &nbound, bcord.data(), + kbndpt.data(), boundary.data(), &numcurvboun, &npoint, &nelem, + holeinfo.data(), &nholes, &ncoar, coar.data(), userpoints.data(), + &isurnr, &numextcurves, numnodextcurvs.data(), curvenumbers.data(), + rinput.data(), &nuspnt, &ndim); + + std::vector nodes(npoint); + + for (int i = 0; i < npoint; ++i) + { + nodes[i].x = coor[2 * i]; + nodes[i].y = coor[2 * i + 1]; + } + + // std::vector edges; + // edges.reserve (3 * nelem); + + // for (int i = 0; i < nelem; ++i) { + // int idx = 3 * i; + + // meshkernel::UInt n1 = static_cast(kmeshc [idx] - 1); + // meshkernel::UInt n2 = static_cast(kmeshc [idx+ 1] - 1); + // meshkernel::UInt n3 = static_cast(kmeshc [idx + 2] - 1); + + // meshkernel::Edge e1 = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1); + // meshkernel::Edge e2 = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2); + // meshkernel::Edge e3 = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3); + + // if (std::find(edges.begin (), edges.end (), e1) == edges.end ()) + // { + // edges.push_back (e1); + // } + + // if (std::find(edges.begin (), edges.end (), e2) == edges.end ()) + // { + // edges.push_back (e2); + // } + + // if (std::find(edges.begin (), edges.end (), e3) == edges.end ()) + // { + // edges.push_back (e3); + // } + + // } + + // Alternative + + std::vector edges(3 * nelem); + + std::vector> faceNodes(nelem); + std::vector numFaceNodes(nelem, 0); + + + for (int i = 0; i < nelem; ++i) + { + int idx = 3 * i; + + meshkernel::UInt n1 = static_cast(kmeshc[idx] - 1); + meshkernel::UInt n2 = static_cast(kmeshc[idx + 1] - 1); + meshkernel::UInt n3 = static_cast(kmeshc[idx + 2] - 1); + + // Which is better, reserve and push back or allocate and assign? + edges[idx] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); + edges[idx + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge(n3, n2); + edges[idx + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge(n1, n3); + + faceNodes[i].resize (3); + faceNodes[i][0] = n1; + faceNodes[i][1] = n2; + faceNodes[i][2] = n3; + + numFaceNodes[i] = 3; + + // edges.push_back (n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1)); + // edges.push_back (n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2)); + // edges.push_back (n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3)); + } + + auto edgeLessThan = [](const meshkernel::Edge& e1, const meshkernel::Edge& e2) + { + if (e1.first < e2.first) + { + return true; + } + else if (e1.first == e2.first) + { + return e1.second < e2.second; + } + else + { + return false; + } + }; + + std::sort(std::execution::par, edges.begin(), edges.end(), edgeLessThan); + auto [first, last] = std::ranges::unique(edges); + edges.erase(first, last); + + // TODO need to pass the projection + // TODO probably need to handle the projection correctly when setting things up, + // e.g. the minimum coarseness. + return meshkernel::Mesh2D(edges, nodes, faceNodes, numFaceNodes, meshkernel::Projection::cartesian); + // return meshkernel::Mesh2D(edges, nodes, meshkernel::Projection::cartesian); + } - // edges.push_back (n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1)); - // edges.push_back (n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2)); - // edges.push_back (n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3)); - } - - auto edgeLessThan = [](const meshkernel::Edge& e1, const meshkernel::Edge& e2) - { - if (e1.first < e2.first) - { - return true; - } - else if (e1.first == e2.first) - { - return e1.second < e2.second; - } - else - { - return false; - } - }; - - std::sort(std::execution::par, edges.begin(), edges.end(), edgeLessThan); - auto [first, last] = std::ranges::unique(edges); - edges.erase(first, last); - - // TODO need to pass the projection - // TODO probably need to handle the projection correctly when setting things up, - // e.g. the minimum coarseness. - return meshkernel::Mesh2D(edges, nodes, meshkernel::Projection::cartesian); -} TEST(Mesh, TriangulateSamples) { @@ -405,16 +609,19 @@ TEST(Mesh, TriangulateSamples) // auto polys = ReadPolygons ("/home/wcs1/MeshKernel/MeshKernel01/build_deb/northbank_001b.pol", meshkernel::Projection::cartesian); - std::vector nodes{{0.0, 0.0}, {2.5, 0}, {5.0, 0.0}, {7.5, 0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, {-998.0, -998.0}, {3.0, 3.0}, {6.0, 3.0}, {6.0, 6.0}, {3.0, 6.0}, {3.0, 3.0}}; + + std::vector nodes{{0.0, 0.0}, {2.5, 0}, {5.0, 0.0}, {7.5, 0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, {-998.0, -998.0}, + {2.0, 2.0}, {5.0, 2.0}, {5.0, 5.0}, {2.0, 5.0}, {2.0, 2.0}, {-998.0, -998.0}, + {6.0, 6.0}, {8.0, 6.0}, {8.0, 8.0}, {6.0, 8.0}, {6.0, 6.0}}; // // std::vector nodes{{0.0, 0.0}, {5.0, 0.0}, {10.0, 0.0}, // // {10.0, 5.0}, {10.0, 10.0}, {5.0, 10.0}, // // {0.0, 10.0}, {0.0, 5.0}, {0.0, 0.0}}; - // meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); - // auto polys = &polygons; + meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); + auto polys = &polygons; // auto mesh2 = generateMesh (polygons); - auto mesh2 = generateMesh(*polys); + auto mesh2 = generateMesh(polygons); meshkernel::SaveVtk(mesh2.Nodes(), mesh2.m_facesNodes, "trianglemesh.vtu"); From 222b6f95715388c1df2c29d8d8ec2505f66c1f97 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Thu, 4 Jun 2026 16:34:46 +0200 Subject: [PATCH 06/43] GRIDEDIT-2102 Added the SEPRAN triangulation library --- extern/sepran/chsort.for | 131 ++ extern/sepran/msh401.for | 909 +++++++++++ extern/sepran/msh402.for | 251 +++ extern/sepran/msh403.for | 173 ++ extern/sepran/msh406.for | 88 + extern/sepran/msh416.for | 93 ++ extern/sepran/mshchkstapl.for | 165 ++ extern/sepran/mshconstants.f90 | 17 + extern/sepran/mshcopyboun.for | 259 +++ extern/sepran/mshcrossline.for | 162 ++ extern/sepran/mshcrossline1.for | 127 ++ extern/sepran/mshcurvinters.for | 156 ++ extern/sepran/mshcurvinters1.for | 194 +++ extern/sepran/mshcurvinters2.for | 183 +++ extern/sepran/mshdummymethods.f90 | 121 ++ extern/sepran/msho01.for | 216 +++ extern/sepran/msho02.for | 135 ++ extern/sepran/msho03.for | 88 + extern/sepran/msho04.for | 112 ++ extern/sepran/msho05.for | 105 ++ extern/sepran/msho06.for | 608 +++++++ extern/sepran/msho07.for | 145 ++ extern/sepran/msho08.for | 383 +++++ extern/sepran/msho09.for | 109 ++ extern/sepran/msho10.for | 182 +++ extern/sepran/msho11.for | 142 ++ extern/sepran/msho12.for | 194 +++ extern/sepran/msho13.for | 354 ++++ extern/sepran/msho14.for | 113 ++ extern/sepran/msho15.for | 117 ++ extern/sepran/msho16.for | 156 ++ extern/sepran/msho17.for | 96 ++ extern/sepran/msho18.for | 284 ++++ extern/sepran/msho19.for | 93 ++ extern/sepran/msho20.for | 96 ++ extern/sepran/msho21.for | 88 + extern/sepran/msho22.for | 114 ++ extern/sepran/msho24.for | 226 +++ extern/sepran/msho25.for | 148 ++ extern/sepran/msho26.for | 115 ++ extern/sepran/msho27.for | 147 ++ extern/sepran/msho28.for | 174 ++ extern/sepran/msho29.for | 294 ++++ extern/sepran/msho2d.for | 2481 +++++++++++++++++++++++++++++ extern/sepran/msho30.for | 266 ++++ extern/sepran/msho31.for | 413 +++++ extern/sepran/msho32.for | 98 ++ extern/sepran/msho33.for | 126 ++ extern/sepran/msho34.for | 270 ++++ extern/sepran/msho35.for | 477 ++++++ extern/sepran/msho36.for | 356 +++++ extern/sepran/msho38.for | 587 +++++++ extern/sepran/msho39.for | 116 ++ extern/sepran/msho40.for | 257 +++ extern/sepran/msho41.for | 106 ++ extern/sepran/msho42.for | 96 ++ extern/sepran/msho75.for | 295 ++++ extern/sepran/mshoce.for | 458 ++++++ extern/sepran/mshtrans2dsur.for | 218 +++ 59 files changed, 14683 insertions(+) create mode 100755 extern/sepran/chsort.for create mode 100644 extern/sepran/msh401.for create mode 100644 extern/sepran/msh402.for create mode 100644 extern/sepran/msh403.for create mode 100644 extern/sepran/msh406.for create mode 100644 extern/sepran/msh416.for create mode 100755 extern/sepran/mshchkstapl.for create mode 100644 extern/sepran/mshconstants.f90 create mode 100644 extern/sepran/mshcopyboun.for create mode 100644 extern/sepran/mshcrossline.for create mode 100644 extern/sepran/mshcrossline1.for create mode 100644 extern/sepran/mshcurvinters.for create mode 100644 extern/sepran/mshcurvinters1.for create mode 100644 extern/sepran/mshcurvinters2.for create mode 100644 extern/sepran/mshdummymethods.f90 create mode 100644 extern/sepran/msho01.for create mode 100644 extern/sepran/msho02.for create mode 100644 extern/sepran/msho03.for create mode 100644 extern/sepran/msho04.for create mode 100644 extern/sepran/msho05.for create mode 100644 extern/sepran/msho06.for create mode 100644 extern/sepran/msho07.for create mode 100644 extern/sepran/msho08.for create mode 100644 extern/sepran/msho09.for create mode 100644 extern/sepran/msho10.for create mode 100644 extern/sepran/msho11.for create mode 100644 extern/sepran/msho12.for create mode 100644 extern/sepran/msho13.for create mode 100644 extern/sepran/msho14.for create mode 100644 extern/sepran/msho15.for create mode 100644 extern/sepran/msho16.for create mode 100644 extern/sepran/msho17.for create mode 100644 extern/sepran/msho18.for create mode 100644 extern/sepran/msho19.for create mode 100644 extern/sepran/msho20.for create mode 100644 extern/sepran/msho21.for create mode 100644 extern/sepran/msho22.for create mode 100644 extern/sepran/msho24.for create mode 100644 extern/sepran/msho25.for create mode 100644 extern/sepran/msho26.for create mode 100644 extern/sepran/msho27.for create mode 100644 extern/sepran/msho28.for create mode 100644 extern/sepran/msho29.for create mode 100644 extern/sepran/msho2d.for create mode 100644 extern/sepran/msho30.for create mode 100644 extern/sepran/msho31.for create mode 100644 extern/sepran/msho32.for create mode 100755 extern/sepran/msho33.for create mode 100755 extern/sepran/msho34.for create mode 100644 extern/sepran/msho35.for create mode 100644 extern/sepran/msho36.for create mode 100644 extern/sepran/msho38.for create mode 100644 extern/sepran/msho39.for create mode 100755 extern/sepran/msho40.for create mode 100755 extern/sepran/msho41.for create mode 100755 extern/sepran/msho42.for create mode 100644 extern/sepran/msho75.for create mode 100644 extern/sepran/mshoce.for create mode 100755 extern/sepran/mshtrans2dsur.for diff --git a/extern/sepran/chsort.for b/extern/sepran/chsort.for new file mode 100755 index 000000000..86a3271f9 --- /dev/null +++ b/extern/sepran/chsort.for @@ -0,0 +1,131 @@ + subroutine chsort ( keysrt, kgrad, npoint ) +! ====================================================================== +! +! programmer Jos van Kan/Onno Hoitinga +! version 3.1 date 26-12-1998 Remove continues +! version 3.0 date 25-01-1995 Complete new subroutine, programmed +! by Onno Hoitinga +! version 2.3 date 20-06-1994 Adaptation comments +! version 2.2 date 03-02-1994 New comments +! version 2.1 date 22-11-1990 Change declarations to prevent errors +! version 2.0 date 12-05-1989 Complete revision, with extra parameters +! version 1.0 date 21-06-1987 +! +! +! copyright (c) 1987-1998 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! This routine gets as input array keysrt of length npoint +! on output array kgrad contains the indices to sort array keysrt +! The Heap sort algorithm is used +! ********************************************************************** +! +! KEYWORDS +! +! sort +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + implicit none + integer npoint, keysrt(npoint), kgrad(npoint) + +! keysrt i sortkey (integer) on array to be sorted. +! kgrad o contains permutation index that sorts keysrt +! in ascending order on output. +! npoint i number of entries in keysrt & kgrad +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer i, j, l, ir, kgradt, q + +! i Counting variable +! ir ? +! j Counting variable +! kgradt ? +! l General loop variable +! q ? +! ********************************************************************** +! +! I/O +! +! none +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! This routine originates from Numerical Recipes (fortran edition) +! Cambridge University Press 1989 +! ********************************************************************** +! +! MODULES USED +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + do j = 1, npoint + kgrad(j) = j + end do + if ( npoint.le.1 ) go to 1000 + l = npoint/2+1 + ir = npoint + +200 if ( l.gt.1 ) then + l = l-1 + kgradt = kgrad(l) + q = keysrt(kgradt) + else + kgradt = kgrad(ir) + q = keysrt(kgradt) + kgrad(ir) = kgrad(1) + ir = ir-1 + if ( ir.eq.1 ) then + kgrad(1) = kgradt + go to 1000 + end if + end if + i = l + j = l+l +300 if ( j.le.ir ) then + if ( j.lt.ir ) then + if ( keysrt(kgrad(j)).lt.keysrt(kgrad(j+1)) ) j = j+1 + end if + if ( q.lt.keysrt(kgrad(j)) ) then + kgrad(i) = kgrad(j) + i = j + j = j+j + else + j = ir+1 + end if + go to 300 + end if + kgrad(i) = kgradt + go to 200 + +1000 end diff --git a/extern/sepran/msh401.for b/extern/sepran/msh401.for new file mode 100644 index 000000000..2549c99a0 --- /dev/null +++ b/extern/sepran/msh401.for @@ -0,0 +1,909 @@ + subroutine msh401 ( npoint, kmeshc , nelem , istart, ibrp, + + ibrpnt, kelemh, ishape, inpelm, niedge, + + nisurf, nivolm ) +! ====================================================================== +! +! programmer Niek Praagman +! version 5.7 date 18-11-2000 Include connection elements +! version 5.6 date 18-04-1997 Extension with interface elements +! version 5.5 date 05-04-1995 add niedge, nisurf and nivolm to indi- +! cate whether lines, surfaces and volu- +! mes are included or not) +! version 5.4 date 15-02-1995 add npoint for call of MSH402 +! version 5.3 date 22-10-1993 extra parameter inpelm for ishape=-199 +! version 5.2 date 02-02-1993 new requirements layout etc +! version 5.1 date 22-08-1991 Zdenek: no dimension, cdc, ce +! version 5.0 date 10-09-1990 variable number IBRP of neighbours +! Deletion of inpelm +! version 4.0 date 14-03-1989 2D and 3D elements +! +! copyright (c) 1986-2000 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Fill neighbour arrays (istart and ibrpnt) for refinement +! In istart the addresses where the neighbours of point i are +! stored in array ibrpnt are stored. In this routine it is assumed +! that each point has ibrp neighbours. Neighbours of point i are +! stored from position istart(i) to istart(i+1)-1 . In the final +! form only the neighbours with nodal numbers smaller than point i +! are stored , together with the new points . If a point has more +! than ibrp neighbours, the extra neighbours are temporarily stored +! in array kelemh. Arrays istart and ibrpnt are adjusted according- +! ly in subroutine msh400. +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! refine +! neighbour +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use msherror + use mshdummymethods + + implicit none + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer npoint, kmeshc(*), istart(*), ibrpnt(*), kelemh(*), nelem, + + ibrp, ishape, inpelm, niedge, nisurf, nivolm + +! ibrp i number of assumed neighbours +! ibrpnt o neighbour array +! inpelm i number of nodes in element ishape +! ishape i type of elements to be considered (see SEPRAN +! PROGRAMMERS GUIDE) +! istart o array containing the start positions of +! array ibrpnt +! kelemh o helparray for extra neighbours +! kmeshc i array containing the elements +! nelem i number of elements +! niedge i number of nodes to be placed on edges +! nisurf i number of nodes to be placed on faces +! nivolm i number of nodes to be placed in volumes +! npoint i number of nodes in mesh originally +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer i(27), ie, ielem, it, j, jelem + + +! i node numbers of element +! ie first node of diagonal +! ielem loop variable elements +! it second node of diagonal +! j loop variable +! jelem helppointer +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Deconcatenate name of subroutine from string +! EROPEN Concatenate name to string of calling subroutines +! ERRINT Fills integer in error message +! ERRSUB Produces error message +! INSTOP Stop SEPRAN execution +! MSH402 Place neighbour in neighbour array +! MSH416 Determine correct order in nodenumbers +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! 531 REFINE or TRANSF not yet available for this type of element +! ********************************************************************** +! +! PSEUDO CODE +! +! PSEUDO CODE +! Run through all elements of this group +! Fill node array for each element +! Place lines, surfaces and/or volumes in neighbour array +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + character(len=260) localName + localName = 'msh401' + call eropen( localName ) + +! --- Run through all elements of this group + + if ( ishape.eq.-9 ) then + +! --- Special line element containing all points of one side + + do j = 1 , inpelm-1 + + i(1) = kmeshc( j ) + i(2) = kmeshc( j+1 ) + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + + end do + + else if ( ishape.eq.1 ) then + +! --- inpelm = 2 + + do ielem = 1, nelem + + jelem = 2 * ( ielem - 1 ) + + do j = 1 , 2 + + i(j) = kmeshc( jelem + j ) + + end do + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + + end do + + else if ( ishape.eq.2 ) then + +! --- inpelm = 3 + + do ielem = 1, nelem + + jelem = 3 * ( ielem - 1 ) + + do j = 1 , 3 + + i(j) = kmeshc( jelem + j ) + + end do + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + + end do + + else if ( ishape.eq.3 ) then + +! --- inpelm = 3 + + do ielem = 1, nelem + + jelem = 3 * ( ielem - 1 ) + + do j = 1 , 3 + + i(j) = kmeshc( jelem + j ) + + end do + + if ( niedge.gt.0 ) then + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(1), + + kelemh ) + + end if + +! --- Place surface later in array ibrpnt (see MSH443) ! + + end do + + else if ( ishape.eq.4 ) then + +! --- inpelm = 6 + + do ielem = 1, nelem + + jelem = 6 * ( ielem - 1 ) + + do j = 1 , 6 + + i(j) = kmeshc( jelem + j ) + + end do + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(5), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(1), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(6), + + kelemh ) + + end do + + else if ( ishape.eq.5 ) then + +! --- inpelm = 4 + + do ielem = 1, nelem + + jelem = 4 * ( ielem - 1 ) + + do j = 1 , 4 + + i(j) = kmeshc( jelem + j ) + + end do + + if ( niedge.gt.0 ) then + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(1), + + kelemh ) + + end if + + if ( nisurf.gt. 0 .or. + + nisurf.eq.-1 .and. niedge.gt.0 ) then + +! --- One extra for new middlepoint + + call msh416( i(1), i(2), i(3), i(4), ie, it ) + + it = it * npoint + + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + end if + + end do + + else if ( ishape.eq.6 ) then + +! --- inpelm = 9 + + do ielem = 1, nelem + + jelem = 9 * ( ielem - 1 ) + + do j = 1 , 9 + + i(j) = kmeshc( jelem + j ) + + end do + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(8), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(5), + + kelemh ) + + call msh416( i(1), i(2), i(9), i(8), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + call msh416( i(2), i(3), i(4), i(9), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + call msh416( i(8), i(9), i(6), i(7), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + call msh416( i(9), i(4), i(5), i(6), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + end do + + else if ( ishape.eq.7 ) then + +! --- inpelm = 7 + + do ielem = 1, nelem + + jelem = 7 * ( ielem - 1 ) + + do j = 1 , 7 + + i(j) = kmeshc( jelem + j ) + + end do + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(5), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(1), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(2), + + kelemh ) + + end do + + else if ( ishape.eq.11 ) then + +! --- inpelm = 4 + + do ielem = 1, nelem + + jelem = 4 * ( ielem - 1 ) + + do j = 1 , 4 + + i(j) = kmeshc( jelem + j ) + + end do + + if ( niedge.gt.0 ) then + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), + + kelemh ) + + end if + +! --- Place the four surfaces later in the neighbour arrays ! +! (Use routine MSH443) + + end do + + else if ( ishape.eq.12 ) then + +! --- inpelm = 10 + + do ielem = 1, nelem + + jelem = 10 * ( ielem - 1 ) + + do j = 1 , 10 + + i(j) = kmeshc( jelem + j ) + + end do + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(8), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(8), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(5), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(8), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(8), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(8), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(10), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(10), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(9), i(10), + + kelemh ) + + end do + + else if ( ishape.eq.13 ) then + +! --- inpelm = 8 + + do ielem = 1, nelem + + jelem = 8 * ( ielem - 1 ) + + do j = 1 , 8 + + i(j) = kmeshc( jelem + j ) + + end do + + if ( niedge.gt.0 ) then + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(1), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(5), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(8), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(7), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(8), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(5), + + kelemh ) + + end if + + if ( nisurf.gt. 0 .or. + + nisurf.eq.-1 .and. niedge.gt.0 ) then + +! --- Store the six faces + + call msh416( i(1), i(2), i(3), i(4), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + call msh416( i(1), i(2), i(6), i(5), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + call msh416( i(2), i(3), i(7), i(6), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + call msh416( i(3), i(4), i(8), i(7), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + call msh416( i(1), i(4), i(8), i(5), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + call msh416( i(5), i(6), i(7), i(8), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + end if + + if ( nivolm.gt. 0 .or. + + nivolm.eq.-1 .and. niedge.gt.0 ) then + + ie = min( i(1), i(7) ) + it = max( i(1), i(7) ) + + it = npoint * ( npoint + 1 ) + it + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + + end if + + end do + + else if ( ishape.eq.14 ) then + +! --- inpelm = 27 + + do ielem = 1, nelem + + jelem = 27 * ( ielem - 1 ) + + do j = 1 , 27 + + i(j) = kmeshc( jelem + j ) + + end do + +! --- determine new points in "first plane" + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(4), + + kelemh ) + call msh416( i(1), i(2), i(5), i(4), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(5), + + kelemh ) + call msh416( i(2), i(3), i(6), i(5), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(5), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(7), + + kelemh ) + call msh416( i(4), i(5), i(8), i(7), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(8), + + kelemh ) + call msh416( i(5), i(6), i(9), i(8), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(9), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(8), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(9), + + kelemh ) + +! --- "second plane" + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(10), + + kelemh ) + call msh416( i(1), i(2), i(11), i(10), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(11), + + kelemh ) + call msh416( i(2), i(3), i(12), i(11), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(12), + + kelemh ) + call msh416( i(1), i(4), i(13), i(10), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(14), + + kelemh ) + call msh416( i(3), i(6), i(15), i(12), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(13), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(15), + + kelemh ) + call msh416( i(4), i(7), i(16), i(13), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(9), i(14), + + kelemh ) + call msh416( i(6), i(9), i(18), i(15), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(16), + + kelemh ) + call msh416( i(7), i(8), i(17), i(16), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(17), + + kelemh ) + call msh416( i(8), i(9), i(18), i(17), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(9), i(18), + + kelemh ) + +! --- "third plane" + + call msh402( npoint, ibrp, ibrpnt, istart, i(10), i(11), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(11), i(12), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(10), i(13), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(10), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(11), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(12), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(12), i(15), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(13), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(14), i(15), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(13), i(16), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(14), i(16), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(14), i(17), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(14), i(18), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(15), i(18), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(16), i(17), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(17), i(18), + + kelemh ) + +! --- "fourth plane" + + call msh402( npoint, ibrp, ibrpnt, istart, i(10), i(19), + + kelemh ) + call msh416( i(10), i(11), i(20), i(19), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(11), i(20), + + kelemh ) + call msh416( i(11), i(12), i(21), i(20), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(12), i(21), + + kelemh ) + call msh416( i(10), i(13), i(22), i(19), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(19), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(20), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(21), i(14), + + kelemh ) + call msh416( i(12), i(15), i(24), i(21), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(22), i(13), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(22), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(23), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(24), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(24), i(15), + + kelemh ) + call msh416( i(13), i(16), i(25), i(22), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(25), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(26), i(14), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(27), i(14), + + kelemh ) + call msh416( i(15), i(18), i(27), i(24), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(25), i(16), + + kelemh ) + call msh416( i(16), i(17), i(26), i(25), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(26), i(17), + + kelemh ) + call msh416( i(17), i(18), i(27), i(26), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(27), i(18), + + kelemh ) + +! --- "fifth plane" + + call msh402( npoint, ibrp, ibrpnt, istart, i(19), i(20), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(20), i(21), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(19), i(22), + + kelemh ) + call msh416( i(19), i(20), i(23), i(22), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(20), i(23), + + kelemh ) + call msh416( i(20), i(21), i(24), i(23), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(21), i(24), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(22), i(23), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(23), i(24), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(22), i(25), + + kelemh ) + call msh416( i(22), i(23), i(26), i(25), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(23), i(26), + + kelemh ) + call msh416( i(23), i(24), i(27), i(26), ie, it ) + it = it * npoint + call msh402( npoint, ibrp, ibrpnt, istart, ie, it, + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(24), i(27), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(25), i(26), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(26), i(27), + + kelemh ) + + end do + + else if ( ishape.eq.50 ) then + +! --- inpelm = 50 + + do ielem = 1, nelem + + jelem = 4 * ( ielem - 1 ) + + do j = 1, 4 + + i(j) = kmeshc( jelem + j ) + + end do + + if ( niedge.gt.0 ) then + + call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(3), + + kelemh ) + call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), + + kelemh ) + + end if + +! --- Place surface later in array ibrpnt (see MSH443) ! + + end do + + else + +! --- not yet available + + call errint ( ishape, 1 ) + call errsub ( 531, 1, 0, 0 ) + go to 1000 + + end if + +1000 call erclos('msh401') + + end + diff --git a/extern/sepran/msh402.for b/extern/sepran/msh402.for new file mode 100644 index 000000000..51423aa65 --- /dev/null +++ b/extern/sepran/msh402.for @@ -0,0 +1,251 @@ + subroutine msh402( npoint, ibrp, ibrpnt, istart, i1, i2, kelemh ) +! ====================================================================== +! +! programmer Niek Praagman +! version 2.5 date 14-02-1995 use alternative of neighbours +! and npoint +! version 2.4 date 03-03-1993 layout adjustments, new norms +! version 2.3 date 18-08-1992 iabs==>abs +! version 2.2 date 22-08-1991 Zdenek: no dimension, cdc, ce +! version 2.1 date 10-09-1990 variable length for IBRPNT +! version 2.0 date 01-03-1989 +! +! +! +! copyright (c) 1986-1995 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard or soft copy granted only by written license obtained +! from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system (e.g. , in memory, disk or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! +! ********************************************************************** +! +! DESCRIPTION +! +! Fill the nodal point numbers in the right positions of array ibrpnt +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! neighbour +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + use mshdummymethods + + implicit none + integer npoint, ibrpnt(*), i1, i2, ibrp, istart(*), kelemh(*) + +! i1 i first node number to be considered +! i2 i second node number to be considred +! ibrp i number of places available in IBRPNT for each +! point +! ibrpnt i,o array containing sequentially the neighbour- +! points +! istart i array of startposition for each nodal point +! in ibrpnt +! kelemh o array to store extra neighbours if a point has +! more than ibrp neighbours +! npoint i number of nodes before operation +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer idif, ih, ihigh, il, ilow, j, ja, jstart, jstend + +! idif difference +! ih number of neighbour +! ihigh highest node number of i1,i2 +! il loop variable +! ilow lowest node number of i1,i2 +! j loop variable +! ja local indicator which storage system is used +! jstart startposition in ibrpnt +! jstend endposition in ibrpnt +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Deconcatenate name from string of calling subroutines +! EROPEN Concatenate name to string of calling subroutines +! ERRSUB Produce error message +! INSTOP Stop SEPRAN execution +! ********************************************************************** +! +! ERROR MESSAGES +! +! 1274 No place left for neighbour +! ********************************************************************** +! +! PSEUDO CODE +! +! Check whether special situation (i1 < 0) +! +! If special situation ja = 1 else ja = 0 +! +! Determine lowest and highest node number if both are smaller +! than npoint else change roles +! +! Store : ilow is neighbour of ihigh +! +! Determine places in array with neighbours +! +! If ja=1 than start situation else rearranged situation +! +! Check whether new point +! +! If new than place number in array of neighbours +! +! ********************************************************************** +! +! MODULES USED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + character(len=260) localName + localName = 'msh402' + call eropen( localName ) + + if ( i1.lt.0 ) then + + ja = 0 + i1 = -i1 + + else + + ja = 1 + + end if + +! --- Determine ilow and ihigh + + if ( i1.gt.i2 ) then + +! --- Check for npoint + + if ( i1.gt.npoint ) then + + ilow = i1 + ihigh = i2 + + else + + ilow = i2 + ihigh = i1 + + end if + + else + +! --- Check for npoint + + if ( i2.gt.npoint ) then + + ilow = i2 + ihigh = i1 + + else + + ilow = i1 + ihigh = i2 + + end if + + end if + +! --- ilow is neighbour of ihigh + + if ( ja.eq.1 ) then + + jstart = ibrp * ( ihigh - 1 ) + 1 + jstend = jstart + ibrp - 1 + + else + + jstart = istart( ihigh ) + jstend = istart( ihigh + 1 ) - 1 + + end if + +! --- Run through available positions + +100 ih = ibrpnt( jstart ) + + if ( ih.eq.0 ) then + + ibrpnt( jstart ) = ilow + istart( ihigh ) = istart( ihigh ) + ja + +! --- Ready + + goto 1000 + + else if ( ih.eq.ilow ) then + +! --- Line already stored + + goto 1000 + + end if + + jstart = jstart + 1 + + if ( jstart.gt.jstend ) then + + if ( ja.eq.0 ) then + + call errsub ( 1274, 0, 0, 0 ) + + end if + + j = kelemh(1) + +! --- Check whether this line is already in kelemh + + do il = 1 , j + + idif = abs ( kelemh(2*il ) - ihigh ) + + + abs ( kelemh(2*il+1) - ilow ) + + if ( idif.eq.0 ) goto 1000 + + end do + +! --- Place in kelemh + + kelemh( 2 * j + 2 ) = ihigh + kelemh( 2 * j + 3 ) = ilow + kelemh( 1 ) = j + 1 + istart( ihigh ) = istart( ihigh ) + 1 + +! --- Ready + + goto 1000 + + end if + + goto 100 + +1000 call erclos('msh402') + + end + diff --git a/extern/sepran/msh403.for b/extern/sepran/msh403.for new file mode 100644 index 000000000..5307fe26e --- /dev/null +++ b/extern/sepran/msh403.for @@ -0,0 +1,173 @@ + subroutine msh403( npoint, i1, i3, ibrpnt, istart, i2 ) +! ====================================================================== +! +! programmer niek praagman +! version 2.1 date 22-07-1998 Layout +! version 2.0 date 14-02-1995 npoint added; other storage of +! neighbour nodes +! version 1.3 date 08-04-1994 initialize i2 +! version 1.2 date 03-03-1993 adjustment layout and error 949 +! version 1.1 date 22-08-1991 Zdenek: no dimension, cdc, ce +! version 1.0 date 01-02-1986 +! +! +! +! copyright (c) 1986-1998 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard or soft copy granted only by written license obtained +! from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system (e.g. , in memory, disk or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! +! ********************************************************************** +! +! DESCRIPTION +! +! Determine the nodal point number i2 of a new point between the nodes +! i1 and i3 as stored in array ibrpnt +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! neighbour +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + use mshdummymethods + + implicit none + integer i1, i2, i3, ibrpnt(*), istart(*), npoint + +! i1 i first node number to be considered +! i2 o node number of intermediate point +! i3 i last node number of line to be considered +! ibrpnt i array containing the neighbours of the +! nodes sequentially +! istart i array containing the startaddresses for +! each original nodal point +! npoint i number of nodes in original mesh +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer ihelp, ihigh, ilow, jstart, jstend + +! ihelp place to store node number temporarily +! ihigh highest node number +! ilow lowest node number +! jstart start position neighbour points +! jstend last position neighbour points +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Deconcatenate name from string of calling subroutines +! EROPEN Concatenate name to string of calling subroutines +! ERRSUB Produce error message +! ********************************************************************** +! +! ERROR MESSAGES +! +! 949 No intermediate neighbour found +! ********************************************************************** +! +! PSEUDO CODE +! +! Determine position taking the value of npoint into account +! +! Check new neighbour number +! +! If no point is found, error ! +! +! ********************************************************************** +! +! MODULES USED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + character(len=260) localName + localName = 'msh403' + call eropen( localName ) + + i2 = 0 + +! --- determine place + + if ( i1.gt.i3 ) then + +! --- Check for npoint + + if ( i1.gt.npoint ) then + + ilow = i1 + ihigh = i3 + + else + + ilow = i3 + ihigh = i1 + + end if + + else + +! --- Check for npoint + + if ( i3.gt.npoint ) then + + ilow = i3 + ihigh = i1 + + else + + ilow = i1 + ihigh = i3 + + end if + + end if + + jstart = istart( ihigh ) + jstend = istart( ihigh + 1 ) - 1 + +100 ihelp = ibrpnt(jstart) + + if ( ihelp.eq.ilow ) then + +! --- Point found + + i2 = ibrpnt( jstart + 1 ) + + goto 1000 + + end if + + jstart = jstart + 2 + + if ( jstart.le.jstend ) goto 100 + +! --- Error, no point number found + + call errsub ( 949, 0, 0, 0 ) + +1000 call erclos('msh403') + + end + diff --git a/extern/sepran/msh406.for b/extern/sepran/msh406.for new file mode 100644 index 000000000..0fff8b98e --- /dev/null +++ b/extern/sepran/msh406.for @@ -0,0 +1,88 @@ + subroutine msh406( kelem, j, i1, i2, i3, i4, i5, i6 ) + +! ======================================================================= +! +! +! programmer niek praagman +! +! version 2.0 date 03-03-1993 adjustment layout +! version 1.1 date 22-08-1991 Zdenek: no dimension, cdc, ce +! version 1 date 19-5-1986 +! +! +! +! copyright (c) 1986-1993 "ingenieursbureau sepra" +! permission to copy or distribute this software or documentation +! in hard or soft copy granted only by written license obtained +! from "ingenieursbureau sepra". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system (e.g. , in memory, disk or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! +! *********************************************************************** +! +! DESCRIPTION +! +! Subroutine to place nodes in element array in case of a quadratic +! triangle +! +! *********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! quadratic +! triangle +! +! *********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + implicit none + + integer i1, i2, i3, i4, i5, i6, j, kelem( 6,j ) + +! i1 first node +! i2 second node +! i3 third node +! i4 fourth node +! i5 fifth node +! i6 sixth node +! j triangle number to be considered +! kelem element array +! +! *********************************************************************** +! +! COMMON BLOCKS +! +! *********************************************************************** +! +! LOCAL PARAMETERS +! +! *********************************************************************** +! +! SUBROUTINES CALLED +! +! *********************************************************************** +! +! ERROR MESSAGES +! +! *********************************************************************** +! +! METHOD +! +! PSEUDO CODE +! +! ======================================================================= + + kelem( 1,j ) = i1 + kelem( 2,j ) = i2 + kelem( 3,j ) = i3 + kelem( 4,j ) = i4 + kelem( 5,j ) = i5 + kelem( 6,j ) = i6 + + end + diff --git a/extern/sepran/msh416.for b/extern/sepran/msh416.for new file mode 100644 index 000000000..dfa52c803 --- /dev/null +++ b/extern/sepran/msh416.for @@ -0,0 +1,93 @@ + subroutine msh416( i1, i2, i3, i4, ie, it ) +! ======================================================================= +! +! +! programmer niek praagman +! version 1.3 date 06-04-1995 ie is min, it is max +! version 1.2 date 04-02-1993 New norms +! version 1.1 date 23-02-1989 +! +! +! +! copyright (c) 1989 - 1995 "ingenieursbureau sepra" +! permission to copy or distribute this software or documentation +! in hard or soft copy granted only by written license obtained +! from "ingenieursbureau sepra". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system (e.g. , in memory, disk or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! +! *********************************************************************** +! +! DESCRIPTION +! +! Determine begin and endpoint of (main-)diagonal in quadrilateral +! +! *********************************************************************** +! +! KEYWORDS +! +! quadrilateral +! diagonal +! +! *********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + implicit none + + integer i1, i2, i3, i4, ie, it + +! i1 first node of quadrilateral +! i2 second +! i3 third +! i4 fourth +! ie first node of chosen diagonal +! it second node of chosen diagonal +! +! *********************************************************************** +! +! COMMON BLOCKS +! +! *********************************************************************** +! +! LOCAL PARAMETERS +! + integer im + +! im smallest node value of quadrilateral +! +! *********************************************************************** +! +! SUBROUTINES CALLED +! +! +! *********************************************************************** +! +! ERROR MESSAGES +! +! *********************************************************************** +! +! METHOD +! +! PSEUDO CODE +! +! ======================================================================= + + im = min (i1,i2,i3,i4) + + if ( im.eq.i1 .or. im.eq.i3 ) then + + ie = min( i1, i3 ) + it = max( i1, i3 ) + + else + + ie = min( i2, i4 ) + it = max( i2, i4 ) + + end if + + end diff --git a/extern/sepran/mshchkstapl.for b/extern/sepran/mshchkstapl.for new file mode 100755 index 000000000..72e76e9e5 --- /dev/null +++ b/extern/sepran/mshchkstapl.for @@ -0,0 +1,165 @@ + subroutine mshchkstapl ( kstapl, lenkstapl, text ) +! ====================================================================== +! +! programmer Guus Segal +! version 1.0 date 10-02-2003 +! +! copyright (c) 2003-2003 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Check the contents of array kstapl +! It is checked if a node that is on the left-hand side is also the +! right-hand side +! ********************************************************************** +! +! KEYWORDS +! +! mesh +! check +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +!AvD include 'SPcommon/cmcdpi' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer kstapl(2,*), lenkstapl + character *(*) text + +! kstapl i Array containing the actual boundary build by +! pairs of nodes +! lenkstapl i Number of pairs in kstapl +! text i String variable containing some text to be +! printed as part of the debugging +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer i, j, iseq1(lenkstapl), iseq2(lenkstapl), + + iwork(lenkstapl), ihelp(lenkstapl) + logical debug, found + +! debug If true debug statements are carried out otherwise +! they are not +! found If true an error has been found +! i Counting variable +! ihelp integer work array to be used for the sorting +! iseq1 Array containing the nodes of the left-hand side +! of the pairs after sorting +! iseq2 Array containing the node after sortings of the right-hand +! side of the pairs +! iwork integer work array to store the nodes of either the +! left-hand side or the right-hand side of the pairs +! j Counting variable +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! CHSORT Sort integer array for increasing sequence +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! INSTOP Stop the program +! PRININ1 print 2d integer array +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen ( 'mshchkstapl' ) + debug = .false. + + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'Debug information from mshchkstapl' + + end if + if ( lenkstapl.eq.0 ) go to 1000 + +! --- Check array by sorting each row of pairs + + do i = 1, lenkstapl + iwork(i) = kstapl(1,i) + end do + call chsort ( iwork, ihelp, lenkstapl ) + do i = 1, lenkstapl + iseq1(i) = iwork(ihelp(i)) + end do + + do i = 1, lenkstapl + iwork(i) = kstapl(2,i) + end do + call chsort ( iwork, ihelp, lenkstapl ) + do i = 1, lenkstapl + iseq2(i) = iwork(ihelp(i)) + end do + + found = .false. + do i = 1, lenkstapl + if ( iseq1(i).ne.iseq2(i) ) then + +! --- first point found in second column + + found = .true. + j = i + go to 100 + + end if + + end do + +100 if ( found ) then + +! --- Both rows do not contain the same node numbers + + write(irefwr,*) text + write(irefwr,*) 'Both columns of kstapl do not contain the ', + + 'same node numbers' + write(irefwr,*) 'The ', j, '-th nodes are different' + do i = 1, lenkstapl + write(irefwr,110) i, iseq1(i), iseq2(i) +110 format ( i5, ': ', 2i6 ) + end do + call prinin1 ( kstapl, lenkstapl, 2, 'kstapl' ) + !AvD: call instop + + end if + +1000 call erclos ( 'mshchkstapl' ) + if ( debug ) write(irefwr,*) 'End mshchkstapl' + + end diff --git a/extern/sepran/mshconstants.f90 b/extern/sepran/mshconstants.f90 new file mode 100644 index 000000000..2a05c2725 --- /dev/null +++ b/extern/sepran/mshconstants.f90 @@ -0,0 +1,17 @@ +module mshconstants + +double precision, parameter :: EPSMAC = 1.0d-15 +double precision, parameter :: SQREPS = 1.0d-15 +double precision, parameter :: RINFIN = 1.0d77 +integer, parameter :: IREFWR = 66 +integer :: ITIME = 1 +integer :: IGOBS = 1 +integer :: JTIMES = 1 + +end module + +module msherror + +integer :: IERROR = 0 + +end module diff --git a/extern/sepran/mshcopyboun.for b/extern/sepran/mshcopyboun.for new file mode 100644 index 000000000..e4631e13d --- /dev/null +++ b/extern/sepran/mshcopyboun.for @@ -0,0 +1,259 @@ + subroutine mshcopyboun ( jpnt, nbound, bcord, coor, kbndpt, + + kbound, inside, nbn, fillkbound) +! ====================================================================== +! +! programmer Guus Segal +! version 2.0 date 08-02-2001 Extra parameter ihelp +! version 1.0 date 03-04-1999 +! +! copyright (c) 1999-2001 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Fill the arrays kbndpt, kbound and coor with information concerning +! the nodes on the boundary +! kbndpt and kbound are only filled if fillkbound is true +! ********************************************************************** +! +! KEYWORDS +! +! boundary +! copy +! mesh +! ********************************************************************** +! +! MODULES USED +! + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer jpnt, nbound, kbndpt(*), kbound(*), inside, nbn!, +! + ihelp(0:*) + double precision bcord(2,*), coor(2,*) + logical fillkbound + +! bcord i array containing the coordinates of the boundaries +! coor o array of length ndim x npoint containing the +! co-ordinates of the nodal points with respect to the +! global numbering +! In this subroutine only the boundary is filled. +! It is supposed that the points on the boundary are +! also the first points in coor +! fillkbound i if true the array kbndpt and kbound must be filled +! ihelp integer work array of length nparts+1, where nparts +! is the number of closed boundaries +! ihelp(0) = 0 +! ihelp(j) is the last relative number of part j with +! respect to kbndpt +! inside o indicator how many internal regions have to be +! considered +! jpnt o last point number used +! kbndpt o array containing the nodal point numbers of the +! boundary +! kbound o help array for boundary lines, length 2*npunt +! nbn o number of boundary points +! nbound i number of points in bcord +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision, allocatable, dimension(:) :: ihelp + + double precision dx, dy, ref, xst, yst, xp, yp, ds + integer i, j, jst, ifirst, ilast, nparts + logical finished + +! ds distance +! dx x-distance +! dy y-distance +! finished Indicates if the loop has been finished (true) or not +! (false) +! i Counting variable +! ifirst First node in part +! ilast Last node in part +! j Counting variable +! jst nodal point number of first point of local boundary +! nparts number of closed parts the boundary consists of +! ref reference length +! xp x-coordinate of point +! xst x-coordinate of first point +! yp y-coordinate of point +! yst y-coordinate of first point +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! initialize parameters +! Compute reference distance +! Detect the number of parts the boundary consists of and store information +! in ihelp +! +! For all points in the boundary do +! if ( first point on a new part of the boundary ) then +! raise node number +! Copy coor +! Fill kbndpt if necessary +! else ( next point on the boundary ) +! Fill kbound +! If ( last point of closed boundary ) then +! reset j +! Fill kbndpt if necessary +! Fill kbound if necessary +! else ( not last point of closed boundary ) +! Fill kbndpt if necessary +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- initialize parameters + + nbn = 0 + jpnt = 0 + inside = -1 + +! --- Allocate helparrays: + + ! Worst-case estimate of nr of closed boundary polygons + nparts = 1+.5*nbound + allocate( ihelp ( 0:nparts ) ) + +! --- Compute reference distance + + dx = bcord(1,2) - bcord(1,1) + dy = bcord(2,2) - bcord(2,1) + + ref = 1d-5 * sqrt( dx*dx + dy*dy ) + j = 0 + +! --- Detect number of closed parts the boundary consists of and store in +! ihelp + + ihelp(0) = 0 + finished = .false. + nparts = 0 + ifirst = 1 + do while ( .not. finished ) + +! --- Not all parts have been found +! Store starting node +! ilast is last point in closed boundary + + xst = bcord(1,ifirst) + yst = bcord(2,ifirst) + +! --- Find last point that coincides with starting point + + ilast = nbound + do i = ifirst+1, nbound + + xp = bcord(1,i) + yp = bcord(2,i) + dx = xp - xst + dy = yp - yst + ds = sqrt( dx*dx + dy*dy ) + if ( ds.le.ref ) ilast = i + + end do + +! --- Raise nparts + + nparts = nparts+1 + ihelp(nparts) = ilast + if ( ilast.eq.nbound ) finished = .true. + ifirst = ilast+1 + + end do + +! --- Loop over all parts + + do j = 1, nparts + ifirst = ihelp(j-1)+1 + ilast = ihelp(j) + do i = ifirst, ilast + xp = bcord(1,i) + yp = bcord(2,i) + + if ( i.eq.ihelp(j-1)+1 ) then + +! --- first point on a new part of the boundary + + if ( inside.lt.1 ) inside = inside + 1 + jst = jpnt+1 + jpnt = jpnt + 1 + coor(1,jpnt) = xp + coor(2,jpnt) = yp + if ( fillkbound ) kbndpt(i) = jpnt + + else + +! --- next point on the boundary + + if ( fillkbound ) then + +! --- fill kbound + + nbn = nbn + 1 + kbound(2*nbn-1) = jpnt + kbound(2*nbn ) = jpnt + 1 + + end if + + if ( i.eq.ihelp(j) ) then + +! --- end point of a closed boundary found + + if ( fillkbound ) then + kbound(2*nbn) = jst + kbndpt(i) = jst + end if + + else + +! --- not end point of a closed boundary + + jpnt = jpnt + 1 + coor(1,jpnt) = xp + coor(2,jpnt) = yp + if ( fillkbound ) kbndpt(i) = jpnt + + end if + + end if + + end do + + end do + + deallocate( ihelp ) + + + end diff --git a/extern/sepran/mshcrossline.for b/extern/sepran/mshcrossline.for new file mode 100644 index 000000000..c228705cc --- /dev/null +++ b/extern/sepran/mshcrossline.for @@ -0,0 +1,162 @@ + subroutine mshcrossline ( x1, x2, x3, x4, fact1, fact2, eps ) +! ====================================================================== +! +! programmer Guus Segal +! version 1.2 date 16-07-2008 adaptation for zero determinant +! version 1.1 date 29-06-2006 Debug statements +! version 1.0 date 30-11-2000 +! +! copyright (c) 2000-2008 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Find the intersection of the lines x1-x2 and x3-x4 +! The result is the parameter fact, where the intersection point is defined +! as x1 + fact*(x2-x1) +! If no intersection point is found fact gets the value -infinity +! Two-dimensions only +! ********************************************************************** +! +! KEYWORDS +! +! 2d +! intersection +! line +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use msherror + use mshdummymethods + + implicit none + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision x1(2), x2(2), x3(2), x4(2), fact1, fact2, eps + +! eps i local accuracy +! fact1 o Defines the factor for the intersection point +! The intersection point on the face is defined by +! x1 + fact1 * (x2-x1) +! fact2 o Defines the factor for the intersection point +! The intersection point on the face is defined by +! x3 + fact2 * (x4-x3) +! x1 i Contains the coordinates of the point x1 +! x2 i Contains the coordinates of the point x2 +! x3 i Contains the coordinates of the point x3 +! x4 i Contains the coordinates of the point x4 +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision det, amax + logical debug + +! amax maximum value of coordinates +! debug If true debug statements are carried out otherwise +! they are not +! det determinant of system of equations to be solved +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! PRINRL Print 1d real vector +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! The line through x1-x2 is defined as +! x = x1 + fact1 * (x2-x1) +! The line through x3-x4 is defined as +! x = x3 + fact2 * (x4-x3) +! If an intersection is present then +! x1 + fact * (x2-x1) = x3 + alpha1 * (x4-x3) +! Hence: +! [ (x2-x1) (x4-x3) ] [fact -alpha1]^T = x3-x1 +! This system can be solved if det( [ (x2-x1) (x4-x3) ] ) # 0 +! The solution is: +! +! [fact1 -fact2]^T = [ (x2-x1) (x4-x3) ]^(-1) (x3-x1) +! +! or: +! +! det = (x2-x1)*(y4-y3)-(x4-x3)*(y2-y1) +! fact1 = ((y4-y3)*(x3-x1)+(x3-x4)*(y3-y1))/det +! fact2 = -((y1-y2)*(x3-x1)+(x2-x1)*(y3-y1))/det +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + character(len=260) localName + localName = 'mshcrossline' + call eropen( localName ) + + debug = .false. + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'Debug information from mshcrossline' + 2 format ( a, 1x, (5d12.4) ) +! call prinrl ( x1, 2, 'x1' ) +! call prinrl ( x2, 2, 'x2' ) +! call prinrl ( x3, 2, 'x3' ) +! call prinrl ( x4, 2, 'x4' ) + + end if ! ( debug ) + if ( ierror/=0 ) go to 1000 + + det = (x2(1)-x1(1))*(x4(2)-x3(2))-(x4(1)-x3(1))*(x2(2)-x1(2)) + amax = max(abs(x1(1)), abs(x1(2)), abs(x2(1)), abs(x2(2)), + + abs(x3(1)), abs(x3(2)), abs(x4(1)), abs(x4(2)) ) + if ( debug ) write(irefwr,2) 'det', det + if ( abs(det)<=epsmac*amax*100d0 ) then + fact1 = -rinfin + fact2 = -rinfin + else + fact1 = ((x4(2)-x3(2))*(x3(1)-x1(1))+ + + (x3(1)-x4(1))*(x3(2)-x1(2)))/det + if ( fact1>=-eps .and. fact1<=1d0+eps ) then + fact2 = -((x1(2)-x2(2))*(x3(1)-x1(1))+ + + (x2(1)-x1(1))*(x3(2)-x1(2)))/det + else + fact2 = -rinfin + end if + end if + +1000 call erclos ( 'mshcrossline' ) + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'End mshcrossline' + write(irefwr,2) 'fact1, fact2', fact1, fact2 + + end if ! ( debug ) + + end diff --git a/extern/sepran/mshcrossline1.for b/extern/sepran/mshcrossline1.for new file mode 100644 index 000000000..0ede43e91 --- /dev/null +++ b/extern/sepran/mshcrossline1.for @@ -0,0 +1,127 @@ + subroutine mshcrossline1 ( x1, x2, x3, x4, fact1, fact2, eps ) +! ====================================================================== +! +! programmer Guus Segal +! version 1.0 date 26-11-2003 +! +! copyright (c) 2000-2003 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Find the intersection of the lines x1-x2 and x3-x4 +! The result is the parameter fact, where the intersection point is defined +! as x1 + fact*(x2-x1) +! If no intersection point is found fact gets the value -infinity +! Two-dimenions only +! First it is checked if the rectangles around both lines intersect +! ********************************************************************** +! +! KEYWORDS +! +! 2d +! intersection +! line +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + + implicit none +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision x1(2), x2(2), x3(2), x4(2), fact1, fact2, eps + +! eps i local accuracy +! fact1 o Defines the factor for the intersection point +! The intersection point on the face is defined by +! x1 + fact1 * (x2-x1) +! fact2 o Defines the factor for the intersection point +! The intersection point on the face is defined by +! x3 + fact2 * (x4-x3) +! x1 i Contains the coordinates of the point x1 +! x2 i Contains the coordinates of the point x2 +! x3 i Contains the coordinates of the point x3 +! x4 i Contains the coordinates of the point x4 +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision xmin1, xmin2, ymin1, ymin2, xmax1, xmax2, + + ymax1, ymax2 + +! xmax1 maximum x-coordinate of first edge +! xmax2 maximum x-coordinate of second edge +! xmin1 maximum y-coordinate of first edge +! xmin2 maximum y-coordinate of second edge +! ymax1 maximum x-coordinate of third edge +! ymax2 maximum x-coordinate of fourth edge +! ymin1 maximum y-coordinate of third edge +! ymin2 maximum y-coordinate of fourth edge +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! MSHCROSSLINE Computes the intersection of two lines +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! The line through x1-x2 is defined as +! x = x1 + fact1 * (x2-x1) +! The line through x3-x4 is defined as +! x = x3 + fact2 * (x4-x3) +! If an intersection is present then +! x1 + fact * (x2-x1) = x3 + alpha1 * (x4-x3) +! Hence: +! [ (x2-x1) (x4-x3) ] [fact -alpha1]^T = x3-x1 +! This system can be solved if det( [ (x2-x1) (x4-x3) ] ) # 0 +! The solution is: +! +! [fact1 -fact2]^T = [ (x2-x1) (x4-x3) ]^(-1) (x3-x1) +! +! or: +! +! det = (x2-x1)*(y4-y3)-(x4-x3)*(y2-y1) +! fact1 = ((y4-y3)*(x3-x1)+(x3-x4)*(y3-y1))/det +! fact2 = -((y1-y2)*(x3-x1)+(x2-x1)*(y3-y1))/det +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + fact1 = -rinfin + fact2 = -rinfin + xmin1 = min(x1(1),x2(1)) + xmax1 = max(x1(1),x2(1)) + ymin1 = min(x1(2),x2(2)) + ymax1 = max(x1(2),x2(2)) + xmin2 = min(x3(1),x4(1)) + xmax2 = max(x3(1),x4(1)) + ymin2 = min(x3(2),x4(2)) + ymax2 = max(x3(2),x4(2)) + if ( xmax1.lt.xmin2-eps .or. xmin1.gt.xmax2+eps .or. + + ymax1.lt.ymin2-eps .or. ymin1.gt.ymax2+eps ) go to 1000 + call mshcrossline ( x1, x2, x3, x4, fact1, fact2, eps ) +1000 end + diff --git a/extern/sepran/mshcurvinters.for b/extern/sepran/mshcurvinters.for new file mode 100644 index 000000000..8b1da9525 --- /dev/null +++ b/extern/sepran/mshcurvinters.for @@ -0,0 +1,156 @@ + subroutine mshcurvinters ( ncurvs, iwork, xbox, icurvs, curves ) +! ====================================================================== +! +! programmer Guus Segal +! version 1.0 date 28-11-2005 +! +! copyright (c) 2005-2005 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Give an error if two curves intersect +! At this moment 2d only +! ********************************************************************** +! +! KEYWORDS +! +! intersection +! curve +! 2d +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use msherror + + implicit none +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer ncurvs, iwork(*), icurvs(*) + double precision xbox(2,ncurvs,2), curves(2,*) + +! curves i array containing the coordinates of the curves +! icurvs i array containing the number of points in the curves +! accumulated +! iwork i integer work array of length ncurvs +! iwork(i) = -1: curve is empty +! iwork(i) = 0: curve is single +! iwork(i) = 1: curve is compound +! ncurvs i Number of curves in mesh +! xbox i Is used to store the minimum and maximum coordinates +! of all curves +! xbox(i,j,1) minimum i^th coordinate of curve j +! xbox(i,j,2) maximum i^th coordinate of curve j +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer icurnr, jcurnr + logical debug + +! debug If true debug statements are carried out otherwise +! they are not +! icurnr Curve sequence number +! jcurnr Curve sequence number +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! MSHCURVINTERS1 Give an error if 2 curves intersect +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! For all single curves icurnr do +! for all single curve with sequence number>icurnr do +! If ( possible intersection ) then +! if ( subparts of curve intersect ) then +! give error message +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen ( 'mshcurvinters' ) + debug = .false. + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'Debug information from mshcurvinters' + + end if + if ( ierror/=0 ) go to 1000 + +! --- For all single curves icurnr do + + do icurnr = 1, ncurvs + + if ( iwork(icurnr)==0 ) then + +! --- single non-empty curve found +! for all single curve with sequence number>icurnr do + + do jcurnr = icurnr+1, ncurvs + + if ( iwork(jcurnr)==0 ) then + +! --- single non-empty curve found +! If ( possible intersection ) then +! xminixbox(1,jcurnr,2) ) go to 200 + if ( xbox(1,jcurnr,1)>xbox(1,icurnr,2) ) go to 200 + +! --- yminixbox(2,jcurnr,2) ) go to 200 + if ( xbox(2,jcurnr,1)>xbox(2,icurnr,2) ) go to 200 + +! --- if ( subparts of curve intersect ) then +! give error message + + call mshcurvinters1 ( icurnr, jcurnr, icurvs, curves ) + + end if ! ( iwork(jcurnr)==0 ) + +200 end do ! jcurnr = icurnr+1, ncurvs + + end if ! ( iwork(i)==0 ) + + end do ! icurnr = 1, ncurvs + +1000 call erclos ( 'mshcurvinters' ) + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'End mshcurvinters' + + end if + + end + diff --git a/extern/sepran/mshcurvinters1.for b/extern/sepran/mshcurvinters1.for new file mode 100644 index 000000000..c9744a3aa --- /dev/null +++ b/extern/sepran/mshcurvinters1.for @@ -0,0 +1,194 @@ + subroutine mshcurvinters1 ( icurnr, jcurnr, icurvs, curves ) +! ====================================================================== +! +! programmer Guus Segal +! version 1.0 date 28-11-2005 +! +! copyright (c) 2005-2005 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Give an error if 2 curves intersect +! 2d only +! ********************************************************************** +! +! KEYWORDS +! +! intersection +! curve +! 2d +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use msherror + + implicit none + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer icurnr, jcurnr, icurvs(*) + double precision curves(2,*) + +! curves i array containing the coordinates of the curves +! icurnr i Curve sequence number of first curve +! icurvs i array containing the number of points in the curves +! accumulated +! jcurnr i Curve sequence number of second curve +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer k, j, istart, jstart, inodes, jnodes + double precision x1(2), x2(2), x3(2), x4(2), eps, fact1, fact2 + logical debug + +! debug If true debug statements are carried out otherwise +! they are not +! eps Local accuracy +! fact1 multiplication factor +! fact2 multiplication factor +! inodes number of nodes on icurnr +! istart Last position used at icurnr +! j Counting variable +! jnodes number of nodes on jcurnr +! jstart Last position used at jcurnr +! k Counting variable +! x1 coordinates of first point of edge in icurnr +! x2 coordinates of last point of edge in icurnr +! x3 coordinates of first point of edge in jcurnr +! x4 coordinates of last point of edge in jcurnr +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! ERREAL Put real in error message +! ERRINT Put integer in error message +! ERRWAR Warnings +! MSHCROSSLINE1 Find the intersection of the lines x1-x2 and x3-x4 +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! 2787 curves intersect +! ********************************************************************** +! +! PSEUDO CODE +! +! for all edges on curve 1 do +! for all edges on curve 2 do +! if edges intersect give error message +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen ( 'mshcurvinters1' ) + debug = .false. + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'Debug information from mshcurvinters1' + write(irefwr,100) 'icurnr, jcurnr', icurnr, jcurnr +100 format ( a, 1x, (10i6) ) +110 format ( a, 1x, (5d12.4) ) + + end if + if ( ierror/=0 ) go to 1000 + eps = sqreps + +! --- for all edges on curve 1 do + + if ( icurnr==1 ) then + istart = 0 + else + istart = icurvs(icurnr-1) + end if ! ( icurnr==1 ) + inodes = icurvs(icurnr)-istart + x1(1) = curves(1,istart+1) ! first node of edge + x1(2) = curves(2,istart+1) + + do j = 2, inodes + + x2(1) = curves(1,istart+j) ! last node of edge + x2(2) = curves(2,istart+j) + +! --- for all edges on curve 2 do + + if ( jcurnr==1 ) then + jstart = 0 + else + jstart = icurvs(jcurnr-1) + end if ! ( icurnr==1 ) + jnodes = icurvs(jcurnr)-jstart + x3(1) = curves(1,jstart+1) ! first node of edge + x3(2) = curves(2,jstart+1) + + do k = 2, jnodes + + x4(1) = curves(1,jstart+k) ! last node of edge + x4(2) = curves(2,jstart+k) + +! --- if edges intersect give error message + + call mshcrossline1 ( x1, x2, x3, x4, fact1, fact2, eps ) + if ( debug ) then + write(irefwr,100) 'j, k', j, k + write(irefwr,110) 'x1, x2', x1, x2 + write(irefwr,110) 'x3, x4', x3, x4 + write(irefwr,110) 'fact1, fact2', fact1, fact2 + end if ! ( debug ) + + if ( fact1>sqreps .and. fact1<1d0-sqreps .and. + + fact2>sqreps .and. fact2<1d0-sqreps ) then + +! --- curves intersect, give error message and leave subroutine + + call errint ( icurnr, 1 ) + call errint ( jcurnr, 2 ) + call erreal ( x1(1) + fact1 * (x2(1)-x1(1)), 1 ) + call erreal ( x1(2) + fact1 * (x2(2)-x1(2)), 2 ) + call errwar ( 2787, 2, 2, 0 ) + go to 1000 + + end if ! ( fact1>sqreps .and. fact1<1d0-sqreps ... ) + x3(1) = x4(1) + x3(2) = x4(2) + + end do ! k = 2, jnodes + x1(1) = x2(1) + x1(2) = x2(2) + + end do ! j = 1, nnodes-1 + +1000 call erclos ( 'mshcurvinters1' ) + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'End mshcurvinters1' + + end if + + end + diff --git a/extern/sepran/mshcurvinters2.for b/extern/sepran/mshcurvinters2.for new file mode 100644 index 000000000..ebe7cb013 --- /dev/null +++ b/extern/sepran/mshcurvinters2.for @@ -0,0 +1,183 @@ + subroutine mshcurvinters2 ( kbound, nbound, coor, isurnr ) +! ====================================================================== +! +! programmer Guus Segal +! version 1.0 date 30-11-2005 +! +! copyright (c) 2005-2005 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Check if edges in boundary of surface do not intersect +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh +! surface +! boundary +! check +! intersection +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use msherror + use mshdummymethods + + implicit none + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer kbound(2,*), nbound, isurnr + double precision coor(2,*) + +! coor i contains the coordinates of the nodes on the boundary +! isurnr i Surface sequence number +! kbound i Contains the node numbers of the boundary edges +! kbound(1,i) first node of edge i +! kbound(2,i) last node of edge i +! nbound i Number of edges on the boundary +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer i, j + double precision eps, fact1, fact2, x1(2), x2(2), x3(2), x4(2) + logical debug + +! debug If true debug statements are carried out otherwise +! they are not +! eps Local accuracy +! fact1 multiplication factor +! fact2 multiplication factor +! i Counting variable +! j Counting variable +! x1 coordinates of first point of edge in icurnr +! x2 coordinates of last point of edge in icurnr +! x3 coordinates of first point of edge in jcurnr +! x4 coordinates of last point of edge in jcurnr +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! ERREAL Put real in error message +! ERRINT Put integer in error message +! ERRSUB Error messages +! MSHCROSSLINE1 Find the intersection of the lines x1-x2 and x3-x4 +! PRININ1 print 2d integer array +! PRINRL1 Print 2d real vector +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! 2788 boundary intersects itself +! ********************************************************************** +! +! PSEUDO CODE +! +! for all edges on boundary do +! for all edges with higher number on boundary do +! if edges intersect give error message +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + character(len=260) localName + localName = 'mshcurvinters2' + call eropen( localName ) + + debug = .false. + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'Debug information from mshcurvinters2' + write(irefwr,100) 'isurnr', isurnr +100 format ( a, 1x, (10i6) ) +110 format ( a, 1x, (5d15.7) ) + + end if + if ( ierror/=0 ) go to 1000 + eps = 1d-3 + +! --- for all edges on boundary do + + do i = 1, nbound-1 + + x1(1) = coor(1,kbound(1,i)) ! first node of edge + x1(2) = coor(2,kbound(1,i)) + x2(1) = coor(1,kbound(2,i)) ! last node of edge + x2(2) = coor(2,kbound(2,i)) + +! --- for all edges with higher number on boundary do + + do j = i+1, nbound + + x3(1) = coor(1,kbound(1,j)) ! first node of edge + x3(2) = coor(2,kbound(1,j)) + x4(1) = coor(1,kbound(2,j)) ! last node of edge + x4(2) = coor(2,kbound(2,j)) + +! --- if edges intersect give error message + + call mshcrossline1 ( x1, x2, x3, x4, fact1, fact2, eps ) + if ( debug ) then + write(irefwr,100) 'i, j', i, j + write(irefwr,100) 'kbound(i)', kbound(1,i), kbound(2,i) + write(irefwr,100) 'kbound(j)', kbound(1,j), kbound(2,j) + write(irefwr,110) 'x1, x2', x1, x2 + write(irefwr,110) 'x3, x4', x3, x4 + write(irefwr,110) 'fact1, fact2', fact1, fact2 + end if ! ( debug ) + + if ( fact1>eps .and. fact1<1d0-eps .and. + + fact2>eps .and. fact2<1d0-eps ) then + +! --- curves intersect, give error message and leave subroutine + + call errint ( isurnr, 1 ) + call errint ( i, 2 ) + call errint ( j, 3 ) + call erreal ( x1(1) + fact1 * (x2(1)-x1(1)), 1 ) + call erreal ( x1(2) + fact1 * (x2(2)-x1(2)), 2 ) + call errsub ( 2788, 3, 2, 0 ) + + end if ! ( fact1>sqreps .and. fact1<1d0-sqreps ... ) + + end do ! j = i+1, nbound + + end do ! i = 1, nbound-1 + +1000 call erclos ( 'mshcurvinters2' ) + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'End mshcurvinters2' + + end if + + end + diff --git a/extern/sepran/mshdummymethods.f90 b/extern/sepran/mshdummymethods.f90 new file mode 100644 index 000000000..095868f61 --- /dev/null +++ b/extern/sepran/mshdummymethods.f90 @@ -0,0 +1,121 @@ +module mshdummymethods + +implicit none + +private + +public eropen +public ersettime +public erclos +public errsub +public errint +public errchr +public erreal +public prinrl1 +public prinin +public prinin1 +public eralloc +public erdealloc +public printtime + +!=============================================================================== +contains +! +!------------------------------------------------------------------------------ +subroutine eropen(aErrorString) + character(len=*) :: aErrorString + +end subroutine + +subroutine ersettime(aErrorTime) + doubleprecision :: aErrorTime + integer i + i = 1 +end subroutine + +subroutine erclos(aErrorString) + character :: aErrorString + integer i + i = 1 +end subroutine + +subroutine errsub(aError1, aError2, aError3, aError4) +use msherror + integer :: aError1 + integer :: aError2 + integer :: aError3 + integer :: aError4 + integer i + + ierror = 1 +end subroutine + +subroutine errint(aError1, aError2) + integer :: aError1 + integer :: aError2 + integer i + i = 1 +end subroutine + +subroutine errchr(aErrorString, aErrorNumber) + character :: aErrorString + integer :: aErrorNumber + integer i + i = 1 + +end subroutine + +subroutine erreal(aErrorValue, aErrorNumber) + doubleprecision :: aErrorValue + integer :: aErrorNumber + integer i + i = 1 +end subroutine + +subroutine prinrl1( rarr, n1, n2, name) + double precision, intent(in) :: rarr(*) + integer, intent(in) :: n1, n2 + character(len=*), intent(in) :: name + + write (*,*) 'prinrl1 not implemented yet' +end subroutine + +subroutine prinin( iarr, n1, name) + integer, intent(in) :: iarr(*) + integer, intent(in) :: n1 + character(len=*), intent(in) :: name + + write (*,*) 'prinin not implemented yet' +end subroutine + +subroutine prinin1( iarr, n1, n2, name) + integer, intent(in) :: iarr(*) + integer, intent(in) :: n1, n2 + character(len=*), intent(in) :: name + + write (*,*) 'prinin1 not implemented yet' +end subroutine + +subroutine eralloc ( ierror, numel, name) + integer, intent(in) :: ierror + integer, intent(in) :: numel + character(len=*), intent(in) :: name + + write (*,*) 'eralloc not implemented yet' +end subroutine + +subroutine erdealloc ( ierror, name) + integer, intent(in) :: ierror + character(len=*), intent(in) :: name + + write (*,*) 'erdealloc not implemented yet' +end subroutine + +subroutine printtime(text, time) + character(len=*), intent(in) :: text + double precision, intent(in) :: time + + write (*,*) 'printtime not implemented yet' +end subroutine + +end module \ No newline at end of file diff --git a/extern/sepran/msho01.for b/extern/sepran/msho01.for new file mode 100644 index 000000000..a5c7702c5 --- /dev/null +++ b/extern/sepran/msho01.for @@ -0,0 +1,216 @@ + subroutine msho01( kbound, nbound, istart, ibuur, coarse, + + coor, npoint, coarsemin, coarsemax, coar, + + ncoar ) +! ====================================================================== +! +! programmer Niek Praagman +! version 4.1 date 29-08-2008 No coarseness 0 allowed +! version 4.0 date 26-01-2005 Extra parameters coar and ncoar +! version 3.0 date 08-03-2003 Extra parameters coarsemin, coarsemax +! version 2.1 date 08-02-2001 Layout +! version 2.0 date 03-02-1994 New norms +! version 1.1 date 07-11-1990 New error message +! version 0.1 date 12-04-1989 +! +! copyright (c) 1989-2008 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Subroutine to check whether the boundary-elements of the area +! considered are correct and to fill in array coarse for each point +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! coarseness +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + + implicit none +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision coarse(*), coor(*), coarsemin, coarsemax, + + coar(3,*) + integer kbound(*), nbound, istart(*), ibuur(*), npoint, ncoar + +! coar i/o array containing coordinates and coarseness of +! special points to be used in later calculations: +! positions of these points are fixed! +! In ths subroutine the coarseness may be changed +! coarse o array for coarsenesses of each point +! coarsemax o Maximum coarseness at the boundary +! coarsemin o Minimum coarseness at the boundary +! coor i coordinate array ( Standard SEPRAN ) +! ibuur o array with neighbours +! istart o array containing the starting addresses of +! the neighbours in ibuur +! kbound i array with boundary elements (lines) +! nbound i number of lines in kbound +! ncoar i Number of internal points in surface +! npoint i number of points already created +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision afstan, afst, xp, yp, coarsemean + integer itotal, i, jknoop, k, i1, i2, no, ni, ntal, ierror + +! afst distance between two points +! afstan sum of distances for point considered +! coarsemean Average coarseness at the boundary +! i loop variable +! i1 node number +! i2 node number +! ierror count for errors +! itotal local length of istart +! jknoop local node number +! k loop variable +! ni address in neighbour array +! no address in neighbour array +! ntal number of neighbours of point considered +! xp x-coordinate +! yp y-coordinate +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Deconcatenate name from string of calling subroutines +! EROPEN Concatenate name to string of calling subroutines +! ERREAL Place real value in error array +! ERRSUB Submit error message +! MSHO02 Place neighbour points in array of neighbours +! MSHO03 Compute Euclidian distance +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! 905 Number of neighbours of a boundary point is other than +! zero or two ! +! ********************************************************************** +! +! PSEUDO CODE +! +! Count all neighbours by running through array KBOUND and check +! the final values +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen( 'msho01' ) + +! --- Initialize coarsemin and coarsemax + + coarsemin = rinfin + coarsemax = -rinfin + +! --- Fill istart + + do i = 1, npoint + istart(i) = 0 + end do + do i = 1, nbound + i1 = kbound(2*i-1) + i2 = kbound(2*i ) + istart(i1) = istart(i1) + 1 + istart(i2) = istart(i2) + 1 + end do + +! --- Check and rearrange + + itotal = 0 + do i = 1, npoint + itotal = itotal + istart(i) + istart(i) = itotal + end do + +! --- Clear and fill array ibuur + + itotal = istart(npoint) + do i = 1, itotal + ibuur(i) = 0 + end do + do i = 1, nbound + i1 = kbound(2*i-1) + i2 = kbound(2*i ) + call msho02( istart, ibuur, i1, i2 ) + call msho02( istart, ibuur, i2, i1 ) + end do + +! --- Check ibuur + + ierror = 0 + no = 0 + do i = 1, npoint + ni = istart(i) + +! --- ntal is number of neighbours + + ntal = ni - no + +! --- check number of neighbours + + if ( ntal==0 .or. ntal==2 ) then + +! --- Right number of neighbours ! + + else + +! --- Error in number of neighbours + + xp = coor(2*i-1) + yp = coor(2*i ) + call erreal( xp, 1 ) + call erreal( yp, 2 ) + call errsub ( 905, 0, 2, 0 ) + ierror = ierror + 1 + end if + afstan = 0d0 + if ( ntal>0 ) then + do k = no + 1, no + ntal + jknoop = ibuur(k) + if ( jknoop>0 ) then + call msho03( i, jknoop, coor, afst ) + afstan = afstan + afst + end if + end do + coarse(i) = afstan / ntal + coarsemin = min(coarsemin,coarse(i)) + coarsemax = max(coarsemax,coarse(i)) + else + coarse(i) = 0 + end if + no = ni + end do + +! --- Fill coarseness in coar in case this has not been filled + + coarsemean = 0.5d0*(coarsemin+coarsemax) + do i = 1, ncoar + if ( coar(3,i)<=1d-6 ) coar(3,i) = coarsemean + end do ! i = 1, ncoar + + call erclos( 'msho01' ) + end diff --git a/extern/sepran/msho02.for b/extern/sepran/msho02.for new file mode 100644 index 000000000..deee4b01f --- /dev/null +++ b/extern/sepran/msho02.for @@ -0,0 +1,135 @@ + subroutine msho02( istart, ibuur, i, j) +! ====================================================================== +! +! programmer Niek Praagman +! version 2.1 date 17-08-1997 Check coincidence of double +! Plaxis lines +! version 2.0 date 03-02-1994 New norms +! version 1.0 date 12-04-1989 +! +! +! +! copyright (c) 1989-1997 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard or soft copy granted only by written license obtained +! from "ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system (e.g. , in memory, disk or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! +! ********************************************************************** +! +! DESCRIPTION +! +! Subroutine to fill array of neighbour points +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! neighbour +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + use mshdummymethods + + implicit none + integer istart(*), ibuur(*), i, j + +! i i first node of segment to be considered +! ibuur o neighbour array +! istart i array with startaddresses for neighbours of +! each point +! j i second node of line to be considered +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer ist, kn, ien, ib + +! ib node number of neighbour +! ien end address of neighbours in array IBUUR +! ist starting address of neighbours in array IBUUR +! kn loop variable +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Deconcatenate name from string of calling subroutines +! EROPEN Concatenate name to string of calling subroutines +! ERRSUB Submit error message +! INSTOP Stop execution of SEPRAN +! ********************************************************************** +! +! ERROR MESSAGES +! +! 906 Double line in the boundary +! ********************************************************************** +! +! PSEUDO CODE +! +! find starting position for neighbours of point i +! +! run through all points; if node=0 then place new point, else +! if node = j give error message +! +! ********************************************************************** +! +! MODULES USED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen( 'msho02' ) + +! --- Consider line i - j + + if ( i.eq.1 ) then + ist = 1 + else + ist = istart(i-1) + 1 + end if + + ien = istart(i) + + do kn = ist, ien + + ib = ibuur(kn) + + if ( ib.eq.0 ) then + + ibuur(kn) = j + +! --- Ready, point has been placed + + goto 1000 + + else if ( ib.eq.j ) then + +! --- Double line found, do nothing more + + go to 1000 + + end if + + end do + +1000 call erclos( 'msho02' ) + + end diff --git a/extern/sepran/msho03.for b/extern/sepran/msho03.for new file mode 100644 index 000000000..daad91209 --- /dev/null +++ b/extern/sepran/msho03.for @@ -0,0 +1,88 @@ + subroutine msho03( i, j, coor, afst) + +! ======================================================================= +! +! +! +! programmer niek praagman +! +! version 2.0 date 03-02-1994 New norms +! version 1.0 date 12-04-1989 +! +! +! +! copyright (c) 1989-1994 "ingenieursbureau sepra" +! permission to copy or distribute this software or documentation +! in hard or soft copy granted only by written license obtained +! from "ingenieursbureau sepra". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system (e.g. , in memory, disk or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! +! *********************************************************************** +! +! DESCRIPTION +! +! Subroutine to compute the Euclidian distance of two nodes +! +! *********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! distance +! +! *********************************************************************** +! +! +! INPUT / OUTPUT PARAMETERS +! + implicit none + double precision afst, coor(2,*) + integer i, j + +! afst o Euclidian distance +! coor i coordinate array ( Standard SEPRAN ) +! i i first node to be considered +! j i second node to be considered +! +! *********************************************************************** +! +! COMMON BLOCKS +! +! *********************************************************************** +! +! LOCAL PARAMETERS +! + double precision dx, dy + +! dx difference in x-coordinates of i and j +! dy difference in y-coordinates of i and j +! +! *********************************************************************** +! +! SUBROUTINES CALLED +! +! *********************************************************************** +! +! ERROR MESSAGES +! +! *********************************************************************** +! +! METHOD +! +! trivial +! +! ======================================================================= + +! Compute distance + + dx = coor( 1,i ) - coor( 1,j ) + dy = coor( 2,i ) - coor( 2,j ) + + afst = sqrt( dx*dx + dy*dy ) + + end diff --git a/extern/sepran/msho04.for b/extern/sepran/msho04.for new file mode 100644 index 000000000..c4d64e437 --- /dev/null +++ b/extern/sepran/msho04.for @@ -0,0 +1,112 @@ + subroutine msho04 ( coor, npoint, xmin, xmax, ymin, ymax ) +! ====================================================================== +! +! programmer niek praagman +! version 3.0 date 11-02-2005 New for min and max determination +! version 2.0 date 03-02-1994 New norms +! version 1.0 date 12-04-1989 +! +! copyright (c) 1989-2005 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Subroutine to determine extreme values of region considered +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! extreme +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpr' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision coor(2,*), xmin, xmax, ymin, ymax + integer npoint + +! coor i coordinate array ( Standard SEPRAN ) +! npoint i number of points in coor +! xmax o max x-coordinate +! xmin o min x-coordinate +! ymax o max y-coordinate +! ymin o min y-coordinate +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer i + double precision x, y + +! i loop variable +! x x-coordinate +! y y-coordinate +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Run through all points and compare with temporary extreme +! values; if necessary replace values by better new extremes +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Set starting values + + xmax = -rinfin + ymax = -rinfin + + xmin = -xmax + ymin = -ymax + +! --- Run through all npoint points and compute + + do i = 1, npoint + + x = coor( 1,i ) + y = coor( 2,i ) + + xmin = min( xmin, x) + xmax = max( xmax, x) + ymin = min( ymin, y) + ymax = max( ymax, y) + + end do + + end diff --git a/extern/sepran/msho05.for b/extern/sepran/msho05.for new file mode 100644 index 000000000..39c495d3b --- /dev/null +++ b/extern/sepran/msho05.for @@ -0,0 +1,105 @@ + subroutine msho05 ( dist, npoint, dismin, dismax ) +! ====================================================================== +! +! programmer niek praagman +! version 3.0 date 11-02-2005 Update min, max determination +! version 2.0 date 03-02-1994 New norms +! version 1.1 date 04-01-1990 Quadratic case added +! version 1.1 date 12-04-1989 +! +! copyright (c) 1989-2005 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Subroutine to determine the extreme coarsenesses of the points on +! the boundary of the area given +! ********************************************************************** +! +! KEYWORDS +! +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpr' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision dist(*), dismin, dismax + integer npoint + +! dismax o largest distance +! dismin o smallest distance +! dist i array containing the representative distances +! for the surface-points +! npoint i number of points in boundary elements +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision dis, eps + integer i + +! dis coarseness of node considered +! eps accuracy +! i loop variable +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Compute extreme coarseness values +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + eps = 10 * epsmac + + dismin = rinfin + dismax = -rinfin + + do i = 1, npoint + + dis = dist(i) + + if ( dis>eps ) then + + dismin = min( dismin, dis) + dismax = max( dismax, dis) + + end if + + end do + + end diff --git a/extern/sepran/msho06.for b/extern/sepran/msho06.for new file mode 100644 index 000000000..4d995c2f3 --- /dev/null +++ b/extern/sepran/msho06.for @@ -0,0 +1,608 @@ + subroutine msho06( npoint, coor , dist , xstart, ystart, + + nx, ny, icube , chelp , cube , jcube , + + kbound, nbound, coar , ncoar , ncurvs, + + curves, cocurvs ) +! ====================================================================== +! +! programmer niek praagman +! version 4.1 date 07-01-2011 Tuning improved again +! version 4.0 date 10-11-2009 New tuning of several parameters +! version 3.4 date 30-06-2009 other values for xstart and ystart +! version 3.3 date 10-03-2009 Use smoothing of and do not enlarge +! coarseness finally +! version 3.2 date 28-08-2008 Use also nodes of internal curves +! version 3.1 date 02-06-2008 Smooth interpolation coarseness of +! cubes (quadrilaterals) +! version 3.0 date 11-01-2005 Extra coarseness points, different +! computation coarsenesses blocks +! version 2.1 date 20-09-2004 Correction upper bound loop +! version 2.0 date 03-02-1994 New norms +! version 1.0 date 13-04-1989 +! +! copyright (c) 1989-2011 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Subroutine to determine for each standard quadrilateral the coarse- +! ness and for all the boundary points in which quadrilateral they are +! situated. +! Also the type of each quadrilateral is determined. +! At the end of the routine: +! 0 : no points in common with boundary lines +! 1 : belongs partially to inside part +! 2 : belongs totally to inside part +! Determine (if specified) special inside coarsness points +! ********************************************************************** +! +! KEYWORDS +! +! mesh +! mesh_generation +! 2d +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpr' +! include 'SPcommon/cmcdpi' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer npoint, nx, ny, icube(npoint), jcube(*), ncoar, ncurvs, + + nbound, curves(ncurvs), kbound(2,nbound) + double precision coor(2,*), dist, xstart, ystart, chelp(*), + + cube(nx*ny) , coar(3,ncoar), cocurvs(2,*) + +! chelp i array with coarsenesses of each point +! coar i array with x,y coordinates points and their +! coarseness +! cocurvs i array with coordinates internal lines +! coor i coordinate array +! cube i array with coarsenesses of each quadrilateral +! curves i array with number of nodes for each internal curve +! dist i mean distance of two neighbour points in +! the contour +! icube i array with for each node quadrilateral that node +! belongs to +! jcube i array with indication whether quadrilateral is +! completely outside, completely inside or a +! boundary quadrilateral +! kbound i array with boundary pieces +! nbound i number of boundary pieces +! ncoar i number of extra coarseness points +! ncurvs i number of internal curves +! npoint i number of points in line elements of contour +! nx i number of quadrilaterals in x-direction +! ny i number of quadrilaterals in y-direction +! considered +! xstart i smallest x-coordinate of enveloping quadrilateral +! ystart i smallest y-coordinate of enveloping quadrilateral +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision afst, eps, xp, yp, coarse, coxmin, coxmax, + + coymin, coymax, cgem, alpha, deel, cox, coy, coa, + + val1, val2, val3, val4, valmax, valmin + integer i, i1, i2, j, ik, kub, n1, n1i1, n1i2, n1min, n1max, + + n2, n2i1, n2i2, n2min, n2max, + + nc, ntal, nrkube, nnodes, + + ikxmin, ikxmax, ikymin, ikymax, jblok + logical debug + +! afst local distance between sequential nodes +! alpha helpvalue for interpolation +! cgem helpvalue to store mean value +! coa smallest coarseness value point +! coarse coarseness of points resp cube +! cox interpolation value coarseness x-direction +! coxmax ending coarseness x-direction +! coxmin starting coarseness x-direction +! coy interpolation value coarseness y-direction +! coymax ending coarseness y-direction +! coymin starting coarseness y-direction +! debug indicator for debugging +! deel check variable to see in which direction values +! have been used +! eps accuracy +! i loop variable +! ik loop variable +! ikxmax maximum value where x-line stops +! ikxmin minimum value where x-line starts +! ikymax maximum value where x-line stops +! ikymin see ikxmin, now for y +! j loop variable +! jblok help value for block +! kub help for starting address in loop +! n1 help variable to determine ref number of node +! n2 help variable to determine reference number of node +! nc reference number +! nnodes number of nodes in internal lines +! nrkube cube number +! ntal number of steps +! val1 coarseness value in cube 1 +! val2 coarseness value in cube 2 +! val3 coarseness value in cube 3 +! val4 coarseness value in cube 4 +! valmax max value surrounding coarsenesses +! valmin min value surrounding coarsenesses +! xp x-coordinate +! yp y-coordinate +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Run through all boundary points and determine the number of the +! quadrilateral point belongs to +! Run through all quadrilaterals and check for each quadrilateral +! whether a coarseness-value is given +! Determine for all empty quadrilaterals which are inside the area +! also a value for the coarseness by interpolation +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Set debug + debug = .false. + + eps = 10 * epsmac + + coa = rinfin + +! --- Determine for all boundary points the cube-numbers + do i = 1, npoint + + xp = coor( 1,i ) + yp = coor( 2,i ) + +! --- Find number of quadrilateral + + n1 = int ( (xp-xstart)/dist ) + n2 = int ( (yp-ystart)/dist ) + +! --- Determine smallest coarseness value + + if ( chelp(i)>eps .and. chelp(i)eps ) then + nc = icube(ik) + if ( nc==i ) then + ntal = ntal + 1 + coarse = coarse + chelp(ik) + end if + end if + end do + if ( ntal>0 ) then + coarse = coarse / ntal + cube(i) = coarse + jcube(i) = 1 + end if + end do + + if ( debug ) then + write(irefwr,*) 'Check: cubes and cubevalues, dist =',dist + do j=1, ny + yp = ystart + (j-0.5)*dist + do i=1, nx + nc = i + (j-1)*nx + xp = xstart + (i-0.5) * dist + write(irefwr,*) 'Cube, i=',i,'j= ',j,'nc =',nc + write(irefwr,*) 'Center of cube',xp,yp,'coarse',cube(nc) + end do + end do + end if + +! --- Fill empty places along boundary contour: + do i=1, nbound + + i1 = kbound(1,i) + i2 = kbound(2,i) + + cgem = ( chelp(i1)+chelp(i2) ) / 2d0 + + xp = coor(1,i1) + yp = coor(2,i1) + + n1i1 = int( (xp-xstart) / dist ) + n2i1 = int( (yp-ystart) / dist ) + + xp = coor(1,i2) + yp = coor(2,i2) + + n1i2 = int( (xp-xstart) / dist ) + n2i2 = int( (yp-ystart) / dist ) + + n1min = min( n1i1, n1i2 ) + n1max = max( n1i1, n1i2 ) + + n2min = min( n2i1, n2i2 ) + n2max = max( n2i1, n2i2 ) + + do n1 = n1min, n1max + do n2 = n2min, n2max + + nc = 1 + n1 + n2 * nx + + if ( cube(nc)0 ) then + + nnodes = 0 + + do i=1, ncurvs +! --- Run through line: + + do j= nnodes + 1, nnodes + curves(i) - 1 +! --- Determine start and endpoint + + val1 = cocurvs(1,j+1) - cocurvs(1,j) + val2 = cocurvs(2,j+1) - cocurvs(2,j) + + afst = sqrt(val1*val1+val2*val2) + + xp = ( cocurvs(1,j+1) + cocurvs(1,j) ) / 2d0 + yp = ( cocurvs(2,j+1) + cocurvs(2,j) ) / 2d0 + + n1 = int ( (xp-xstart)/dist ) + n2 = int ( (yp-ystart)/dist ) + +! --- This point belongs to quadrilateral with number + nc = 1 + n1 + n2*nx + +! --- Set values of coarseness and type + if ( jcube(nc)==0 ) then + cube (nc) = afst + jcube(nc) = 1 + else if ( jcube(nc)>0 ) then + cube(nc) = ( cube(nc) + afst ) /2d0 + end if + end do + nnodes = nnodes + curves(i) + end do + end if + + if ( debug ) then + write(irefwr,*) 'Second cube-test' + do i=1, nx * ny + write(irefwr,*) i,jcube(i),cube(i) + end do + end if + +! --- Place extra coarse values for internal points: + do i = 1, ncoar + + xp = coar( 1, i ) + yp = coar( 2, i ) + + n1 = int ( (xp-xstart)/dist ) + n2 = int ( (yp-ystart)/dist ) + +! --- This point belongs to quadrilateral with number + nc = 1 + n1 + n2*nx + +! --- Set values of coarseness and type + cube (nc) = coar( 3, i ) + jcube(nc) = 1 + + end do + +! --- All prescribed cubes have now indication: jcube(nc) == 1 + if ( debug ) then + write(irefwr,*) 'third cube-test, nx=',nx,'ny=',ny + do i=1, nx * ny + write(irefwr,*) i,jcube(i),cube(i) + end do + end if + +! --- Determine for all empty quadrilaterals which are inside the area +! also a value for the coarseness + do i = 1, nx + do j = 1, ny + + nrkube = i + (j-1)*nx + + if ( jcube(nrkube)==0 .and. cube(nrkube)0 ) then +! --- Exponential: + alpha = (coxmax/coxmin)**(1d0/(ikxmax-ikxmin)) + cox = coxmin*(alpha **(1d0*(nrkube-ikxmin))) + else +! --- Linear: + alpha = (nrkube - ikxmin)*(1D0/(ikxmax-ikxmin)) + cox = coxmin + alpha * (coxmax-coxmin) + end if + deel = deel + 1d0 + cube(nrkube) = cox + end if + + jblok = ikymax * ikymin + + if ( jblok/=0 ) then +! --- Make choice (exponential or linear) + if ( jblok>0 ) then +! --- Exponential: + alpha = (coymax/coymin)**(1d0/(1d0*(ikymax-ikymin)/nx)) + coy = coymin*(alpha **(1d0*(nrkube-ikymin)/nx)) + else +! --- Linear: + alpha = (nrkube - ikymin)*(1D0/(ikymax-ikymin)) + coy = coymin + alpha * (coymax-coymin) + end if + deel = deel + 1d0 + cube(nrkube) = (cube(nrkube) + coy) / deel + end if + +! --- Set type of this node: + if ( deel>0.5d0 ) jcube(nrkube) = 2 + + end if + end do + end do + + if ( debug ) then + do i = 1, nx + do j = 1, ny + nrkube = i + (j-1)*nx + write(irefwr,*) 'Cube ',nrkube,' i= ',i,'j= ',j + write(irefwr,*) 'type',jcube(nrkube),'value ',cube(nrkube) + end do + end do + end if + +! --- Fill all quadrilaterals with a minimum value if no value +! was found + valmin = rinfin + valmax = 0d0 + +! --- Determine smallest and largest cubecoarseness value + do i = 1, nx * ny + if ( cube(i)>eps .and. cube(i)eps .and. cube(i)>valmax ) valmax = cube(i) + end do + + coa = ( valmax + 3 * valmin ) / 4d0 +! --- Set value coa in all "empty" cubes + do i = 1, nx * ny + if ( cube(i)2 .and. ny>2 .and. 0>1 ) then + + do ik = 1, 5 + +! --- 5 times smoothing should be enough to get "smooth" values + + do i = nx-1, 2, -1 + do j = ny-1, 2, -1 + + nrkube = i + (j-1)*nx + + if ( jcube(nrkube)==2 ) then + +! --- Internal cube: + + val1 = cube(nrkube-nx) + val2 = cube(nrkube- 1) + val3 = cube(nrkube+ 1) + val4 = cube(nrkube+nx) + + valmin = min( val1, val2, val3, val4 ) + valmax = max( val1, val2, val3, val4 ) + + if (valmincube(nrkube)) then + +! --- Adjust value: + + cube(nrkube)= (2*valmin+val1+val2+val3+val4)/6d0 + end if + + end if + + end do + end do + + end do + + end if + + if ( debug ) then + write(irefwr,*) 'Fifth cube-test' + do i=1, nx * ny + write(irefwr,*) i,jcube(i),cube(i) + end do + end if + +! --- Adjust values (not too large differences in neighbouring +! cubes) + + ik = 1 + + do while ( ik==1 .and. nx>2 .and. ny>2 ) + + ik = 0 + + do i = nx-1, 2, -1 + do j = ny-1, 2, -1 + + nrkube = i + (j-1)*nx + + if ( jcube(nrkube)==2 ) then + +! --- Internal cube: + + val1 = cube(nrkube-nx) + val2 = cube(nrkube- 1) + val3 = cube(nrkube+ 1) + val4 = cube(nrkube+nx) + + valmin = min( val1, val2, val3, val4 ) + + if ( cube(nrkube)>2.75d0*valmin ) then + +! --- Adjust value: + + cube(nrkube)=2.75d0*valmin + ik = 1 + end if + + end if + + end do + end do + + end do + +! --- Check in case of debugging + + if ( debug ) then + write(irefwr,*) 'Values nx = ',nx,' ny = ',ny + write(irefwr,*) 'dist = ',dist + do j = 1, ny + do i = 1, nx + + nrkube = i + (j-1)*nx + write(irefwr,*) + + nrkube,'type',jcube(nrkube),'value ',cube(nrkube) + end do + end do + write(irefwr,*) 'End routine msho06' + end if + + end diff --git a/extern/sepran/msho07.for b/extern/sepran/msho07.for new file mode 100644 index 000000000..4721be71a --- /dev/null +++ b/extern/sepran/msho07.for @@ -0,0 +1,145 @@ + subroutine msho07 ( xcub, ycub, xmini, coor, kbound, nbound, ja ) +! ====================================================================== +! +! programmer niek praagman +! version 2.2 date 09-01-2008 Replace mshg03 by msho75 +! version 2.1 date 26-01-2005 Layout +! version 2.0 date 03-04-1994 new norms +! version 1.1 date 10-10-1990 msho23 replaced by mshg03 +! version 1.0 date 13-04-1989 +! +! copyright (c) 1989-2008 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Subroutine to determine whether point (xcub,ycub) belongs to +! the region given by kbound. +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! ********************************************************************** +! +! MODULES USED +! + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision xcub, ycub, xmini, coor(2,*) + integer kbound(*), nbound, ja + +! coor i coordinate array +! ja o output parameter +! if point belongs to area ( ja = 1 ) +! else ( ja = 0 ) +! kbound i boundary element array +! nbound i number of boundary elements +! xcub i x-coordinate of point considered +! xmini i smallest x-coordinate of all nodes +! ycub i y-coordinate of point considered +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision xleft, yleft, xmin, ymin, ymax, x1, y1, x2, y2 + integer i, isnij, ih, i1, i2 + +! i loop variable +! i1 first node boundary segment +! i2 second node boundary segment +! ih help indicator for crossing point +! isnij number of crossings with boundary segments +! x1 x-coordinate of node i1 +! x2 x-coordinate of node i2 +! xleft reference x-coordinate (far away) +! xmin min value of x-values of boundary line +! y1 y-coordinate of node i1 +! y2 y-coordinate of node i2 +! yleft reference y-coordinate +! ymax max value of y-values of boundary line +! ymin min value of y-values of boundary line +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! MSHO75 Check whether two line segments have a point in common +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Suppose that a line is drawn from point (xcub,ycub) to reference +! point (xleft,yleft). Count all crossings of this line with boundary +! lines (i1,i2) from array KBOUND. If the number of crossings is odd +! than point (xcub,ycub) belongs to area given by KBOUND. +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + xleft = xmini - 10d0 + yleft = ycub + + isnij = 0 + ja = 0 + + do i = 1, nbound + + i1 = kbound(2*i-1) + i2 = kbound(2*i ) + + x1 = coor( 1,i1 ) + y1 = coor( 2,i1 ) + + x2 = coor( 1,i2 ) + y2 = coor( 2,i2 ) + + xmin = min(x1,x2) + + ymin = min(y1,y2) + ymax = max(y1,y2) + + if ( xcubymax ) goto 100 + +! --- Potential point + + call msho75( x1, y1, x2, y2, xleft, yleft, xcub, ycub, ih ) + + if ( ih==1 ) goto 100 + +! --- Real intersection point + + isnij = isnij + 1 + +100 end do + + if ( (isnij - (isnij/2) * 2)/=0 ) ja = 1 + + end diff --git a/extern/sepran/msho08.for b/extern/sepran/msho08.for new file mode 100644 index 000000000..b26a77e6c --- /dev/null +++ b/extern/sepran/msho08.for @@ -0,0 +1,383 @@ + subroutine msho08 ( kstapl, kstap, coor, xstart, dismin, + + holeinfo, nholes, check ) +! ====================================================================== +! +! programmer Niek Praagman +! version 5.2 date 24-03-2009 Extra debug facilities +! version 5.1 date 25-11-2008 Check for double lines +! and counterclockwise +! version 5.0 date 17-02-2005 Accuracy improvement +! version 4.0 date 24-02-2003 Extra parameter check +! version 3.0 date 05-04-2002 Extra parameters +! version 2.0 date 14-02-1994 New norms +! version 1.0 date 12-04-1989 +! +! copyright (c) 1989-2009 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Check whether all boundary elements are given in the right direction. +! If not then reverse direction of boundary element. +! If element is double determine direction by sequencing +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! check +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpi' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer kstap, kstapl(*), nholes, holeinfo(2,0:nholes+1) + double precision coor(2,*), xstart, dismin + logical check + +! check i Indicates if this is the first call of msho08, where +! possibly the boundary must be reversed (false) or +! that the call is just for checking (true) +! coor i coordinate array +! dismin i smallest distance in boundary polygon +! holeinfo i Integer array of size 2 x (nholes+2) +! Contains information about holes in surfaces and where +! a new part of the boundary starts +! Pos (1,i-1) contains the local sequence number of the +! first curve of part i provided with a sign +! If the sign is positive the boundary is +! created counter clockwise, otherwise clockwise +! Pos (2,i-1) contains the local sequence number of the +! first node of of part i +! Pos (1,nholes+1) contains the number of curves of the +! boundary +! kstap i number of elements in array kstapl +! kstapl i/o array with boundary elements +! nholes i Number of holes in the boundary of a surface +! xstart i smallest x-value of reference quadrangles +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer i, i1, i2, ichange, ih1, ih2, j, j1, j2, ja, icount, + + iloop + double precision eps, e1, e2, xn, yn, xm, ym + logical debug + +! debug parameter to indicate whether debug actions need +! to be taken +! e1 first component of unity vector +! e2 second component of unity vector +! eps accuracy parameter +! i loop variable +! i1 first node of boundary line +! i2 second node of boundary line +! ichange indicator whether changings have been made +! icount Counter +! ih1 helpvariable for first node +! ih2 helpvariable for second node +! iloop helpvariable to count +! j loop variable +! j1 helpnode +! j2 helpnode +! ja help indicator +! xm x-coordinate midpoint +! xn x-coordinate extra point +! ym y-coordinate midpoint +! yn y-coordinate extra point +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! ERRINT Put integer in error message +! ERRSUB Error messages +! MSHCHKSTAPL Check the contents of array kstapl +! MSHO07 Check whether point belongs to given area +! MSHO09 Compute midpoint line and the normal vector +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! 1274 internal error +! 2434 Internal error in triangle +! ********************************************************************** +! +! PSEUDO CODE +! +! The check is to consider the nodes i1 and i2 of the boundary element +! together with an extra point which should be in the interior of the +! area given by KBOUND. Here it is assumed that the area is closed. +! Set accuracy (here relative to 1) +! Run through all boundary elements +! Compute midpoint and "inside" pointing unity normal +! Compute point that should be inside +! Check whether point belongs to area +! If point does not belong to area reverse direction +! of boundary element +! Check whether all pieces are simple. If pieces are double check +! the correct direction and adjust eventually. +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen( 'msho08' ) + + debug = .false. + +! --- Set accuracy + + eps = 1d-5 + + icount = 0 + + do i = 1, kstap + + i1 = kstapl( 2*i - 1 ) + i2 = kstapl( 2*i ) + + kstapl(2*kstap+i) = 0 + +! --- Compute midpoint line and normal vector ("counterclockwise") + + call msho09 ( coor, i1, i2, e1, e2, xm, ym ) + +! --- Determine extra point for checking + + xn = xm + eps * e1 * dismin + yn = ym + eps * e2 * dismin + +! --- Check whether point belongs to area + + ja = 0 + + call msho07( xn, yn, xstart, coor, kstapl, kstap, ja ) + +! --- If not inside direction is reversed + + if ( ja==0 ) then + +! --- ja = 0, reverse or give error message + + if ( check ) then + +! --- check is true, error + + call errint ( i1, 1 ) + call errint ( i2, 2 ) + call errsub ( 2434, 2, 0, 0 ) + + else + +! --- check is false, start of procedure + + if ( debug) + + write(irefwr,*) 'Interchange',i1,'and',i2 + kstapl( 2*i-1 ) = i2 + kstapl( 2*i ) = i1 + + end if + + end if + + if ( holeinfo(2,icount)==i1 ) then + +! --- New part of boundary found + + if ( ja==0 ) holeinfo(1,icount) = -holeinfo(1,icount) + if ( icount0 ) then + +! --- Piece has a problem with connections: + + if ( debug ) then + write(irefwr,*) 'Piece',i + if ( ih1>0 ) write(*,*) 'No connection',i1 + if ( ih2>0 ) write(*,*) 'No connection',i2 + end if + +! --- Run through all "doubles" and make connection + + do j = 1 , kstap + +! --- Check for all "double" pieces: + + if ( kstapl(2*kstap+j)==1 ) then + +! --- Candidate + + j1 = kstapl(2*j-1) + j2 = kstapl(2*j ) + + if ( j1==i2 .and. ih2>0 .or. + + j2==i1 .and. ih1>0 ) then + +! --- "Double" piece is connected + + kstapl(2 * kstap+j) = 0 + ih1 = 0 + ih2 = 0 + + else if ( j1==i1 .and. ih1>0 .or. + + j2==i2 .and. ih2>0 ) then + +! --- "Double" piece is connected, but direction has +! to be changed: + + kstapl(2 * kstap+j) = 0 + kstapl(2 * j - 1 ) = j2 + kstapl(2 * j ) = j1 + + ichange = 1 + + ih1 = 0 + ih2 = 0 + + end if + + end if + + end do + + end if + + end if + + end do + + if ( debug .and. ih1+ih2>0 ) then + write(irefwr,*) 'element',i1,i2,' has no connection ' + end if + + iloop = iloop + 1 + + if ( iloop>1000 ) then + call errsub (1274, 0, 0, 0 ) + go to 1000 + end if + + end do + + call mshchkstapl( kstapl, kstap, 'Final check in msho08') + +1000 call erclos( 'msho08' ) + + if ( debug ) then + write(irefwr,*) 'kstapl at the end of msho08' + do i=1, kstap + write(irefwr,*) i,kstapl(2*i-1),kstapl(2*i) + end do + end if + + end diff --git a/extern/sepran/msho09.for b/extern/sepran/msho09.for new file mode 100644 index 000000000..b98c28551 --- /dev/null +++ b/extern/sepran/msho09.for @@ -0,0 +1,109 @@ + subroutine msho09( coor, i, j, e1, e2, xm, ym ) +! ====================================================================== +! +! programmer niek praagman +! version 2.0 date 14-02-1994 New norms +! version 1.0 date 13-04-1989 +! +! copyright (c) 1989-2009 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Determine the vector ( e1, e2 ) which is perpendicular to the line +! of the points i-j. Also point (xm,ym) in the middle of line i-j is +! computed +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! perpendicular +! ********************************************************************** +! +! MODULES USED +! + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer i, j + double precision coor(2,*), e1, e2, xm, ym + +! coor i coordinate array +! e1 o first coordinate vector perpendicular to line +! e2 o second coordinate vector perpendicular to line +! i i first node of line +! j i second node of line +! xm o first coordinate midpoint of line +! ym o second coordinate midpoint of line +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision xi, yi, xj, yj, eleng + +! eleng normalisation parameter +! xi x-coordinate point i +! xj x-coordinate point j +! yi y-coordinate point i +! yj y-coordinate point j +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Determine coordinates two line endpoints +! Compute normalizing length and the unit vector +! Compute mid point +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Determine coordinates + + xi = coor( 1, i ) + yi = coor( 2, i ) + xj = coor( 1, j ) + yj = coor( 2, j ) + e1 = - ( yj - yi ) + e2 = ( xj - xi ) + +! --- Normalize + + eleng = sqrt( e1*e1 + e2*e2 ) + e1 = e1 / eleng + e2 = e2 / eleng + +! --- Mid point + + xm = 0.5000001234 * xi + 0.4999998766 * xj + ym = 0.5000001234 * yi + 0.4999998766 * yj + end diff --git a/extern/sepran/msho10.for b/extern/sepran/msho10.for new file mode 100644 index 000000000..c057f9142 --- /dev/null +++ b/extern/sepran/msho10.for @@ -0,0 +1,182 @@ + subroutine msho10 ( kelem, nelem, i1, i2, jpn, kstapl, + + kstap, itri ) +! ====================================================================== +! +! programmer niek praagman +! version 2.1 date 21-02-2003 Layout +! version 2.0 date 14-02-1994 New norms +! version 1.0 date 13-04-1989 +! +! copyright (c) 1989-2003 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Fill new element in array KELEM and adjust arrays KSTAPL and ITRI +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! element +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpi' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer kelem(3,*), nelem, i1, i2, jpn, kstapl(2,*), kstap, + + itri(*) + +! i1 i first node of new element +! i2 i second node of new element +! itri i,o array indicating whether a node n is on the boundary +! itri(n) = 2 or not : itri(n) = 0 +! jpn i third node of element just created +! kelem i,o element array +! kstap i,o number of elements in kstapl +! kstapl i,o array containing the actual boundary +! nelem i,o actual number of elements +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer idrie, ieen, itwe, ks, ia, ib + logical debug + +! debug If true debug statements are carried out otherwise +! they are not +! ia node of boundary element +! ib node of boundary element +! idrie countvariable for new number of elements in kstapl +! ieen check for line i2 - jpn +! itwe check for line jpn - i1 +! ks loop variable +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! PRININ1 print 2d integer array +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Fill new created element in in array kelem +! Adjust kstapl and itri +! Run through all elements of kstapl +! if element is one of the sides of the new element : cancel +! Check which elements of the three sides have already been cancelled +! If sides are left place them in kstapl +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen ( 'msho10' ) + debug = .false. + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'Debug information from msho10' + write(irefwr,*) 'nelem, i1, i2, jpn ', nelem, i1, i2, jpn + + end if + +! --- Fill new created element in in array kelem + + nelem = nelem + 1 + kelem( 1, nelem ) = i1 + kelem( 2, nelem ) = i2 + kelem( 3, nelem ) = jpn + +! --- Adjust kstapl and itri + + idrie = 0 + ieen = 1 + itwe = 1 + do ks = 2, kstap + ia = kstapl(1,ks) + ib = kstapl(2,ks) + if ( ia.eq.i2 .and. ib.eq.jpn ) then + ieen = 0 + else if ( ia.eq.jpn .and. ib.eq.i1 ) then + itwe = 0 + else + idrie = idrie + 1 + kstapl(1,idrie) = ia + kstapl(2,idrie) = ib + end if + end do + if ( debug ) + + write(irefwr,*) 'ieen, itwe, idrie ',ieen, itwe, idrie + +! --- Check which elements have already been used + + if ( ieen.eq.1 ) then + idrie = idrie + 1 + kstapl(1,idrie) = jpn + kstapl(2,idrie) = i2 + itri(i2 ) = itri(i2 ) + 1 + itri(jpn) = itri(jpn) + 1 + else + itri(i2 ) = itri(i2 ) - 1 + itri(jpn) = itri(jpn) - 1 + end if + + if ( itwe.eq.1 ) then + idrie = idrie + 1 + kstapl(1,idrie) = i1 + kstapl(2,idrie) = jpn + itri(jpn) = itri(jpn) + 1 + itri(i1 ) = itri(i1 ) + 1 + else + itri(jpn) = itri(jpn) - 1 + itri(i1 ) = itri(i1 ) - 1 + end if + kstap = idrie + + call erclos ( 'msho10' ) + + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'End msho10' + + end if + + end diff --git a/extern/sepran/msho11.for b/extern/sepran/msho11.for new file mode 100644 index 000000000..b26b40855 --- /dev/null +++ b/extern/sepran/msho11.for @@ -0,0 +1,142 @@ + subroutine msho11 ( i1, i2, i3, coor, angle ) +! ====================================================================== +! +! programmer niek praagman +! version 3.0 date 11-02-2005 Alternative accuracy treatment +! version 2.1 date 28-02-1997 Improvements +! version 2.0 date 14-02-1994 New norms +! version 1.0 date 13-04-1989 +! +! copyright (c) 1989-2005 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Compute the angle between line i1 - i2 and line i2 - i3 using the +! dot product +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! angle +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpr' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer i1, i2, i3 + double precision coor(2,*), angle + +! angle o cosine of angle between lines 1-2 and 2-3 +! coor i coordinate array +! i1 i first node +! i2 i second node +! i3 i third node +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision x1, y1, x2, y2, x3, y3, e1, e2, e3, e4, eleng, + + h1, h2, hnorm + +! e1 first component direction line 3-2 +! e2 second component direction line 3-2 +! e3 first component direction line 1-2 +! e4 second component direction line 1-2 +! eleng scaling parameter +! h1 helpvariable for coincidences +! h2 helpvariable for coincidences +! hnorm norm of helpvariables +! x1 x-coordinate node 1 +! x2 x-coordinate node 2 +! x3 x-coordinate node 3 +! y1 y-coordinate node 1 +! y2 y-coordinate node 2 +! y3 y-coordinate node 3 +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS deconcatenate name subroutine from calling string +! EROPEN concatenate name subroutine to calling string +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen( 'msho11' ) + x1 = coor(1,i1) + y1 = coor(2,i1) + x2 = coor(1,i2) + y2 = coor(2,i2) + x3 = coor(1,i3) + y3 = coor(2,i3) + e1 = x3 - x2 + e2 = y3 - y2 + eleng = sqrt ( e1*e1 + e2*e2 ) + h1 = ( x2 + x3 ) / 2d0 + h2 = ( y2 + y3 ) / 2d0 + hnorm = sqrt( h1*h1 + h2*h2 ) + if ( eleng<1.d2 * epsmac * hnorm ) then + +! --- Points coincide, skip this possibility + + angle = -1.5d0 + goto 1000 + end if + e1 = e1 / eleng + e2 = e2 / eleng + e3 = x1 - x2 + e4 = y1 - y2 + eleng = sqrt ( e3*e3 + e4*e4 ) + h1 = ( x1 + x2 ) / 2d0 + h2 = ( y1 + y2 ) / 2d0 + hnorm = sqrt( h1*h1 + h2*h2 ) + if ( eleng<1.d2 * epsmac * hnorm ) then + +! --- Points coincide, skip this possibility + + angle = -1.5d0 + goto 1000 + end if + e3 = e3 / eleng + e4 = e4 / eleng + angle = e1*e3 + e2*e4 +1000 call erclos( 'msho11' ) + end diff --git a/extern/sepran/msho12.for b/extern/sepran/msho12.for new file mode 100644 index 000000000..1b44d9cac --- /dev/null +++ b/extern/sepran/msho12.for @@ -0,0 +1,194 @@ + subroutine msho12 ( coor, kstapl, kstap, i1, i2, iex1, iex2, + + angle1, angle2 ) +! ====================================================================== +! +! programmer Niek Praagman +! version 3.3 date 14-02-2010 Higher accuracy +! version 3.2 date 26-01-2005 Layout +! version 3.1 date 21-02-2003 Layout +! version 3.0 date 14-02-1994 New norms +! version 2.0 date 01-02-1990 only real neighbours ! +! version 1.0 date 14-04-1989 +! +! copyright (c) 1989-2010 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Determine for line i1 - i2 the other lines where i1 resp i2 are +! nodes off and compute the angles between these lines and the original +! line +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! neighbour +! angle +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpi' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer kstap, kstapl(2,kstap), i1, i2, iex1, iex2 + double precision coor(*), angle1, angle2 + +! angle1 o angle between basis line and iex1 line +! angle2 o angle between basis line and iex2 line +! coor i coordinate array +! i1 i first node segment to be considered +! i2 i second node segment to be considered +! iex1 o node of line adjacent to i1 +! iex2 o node of line adjacent to i2 +! kstap i number of line-elements in kstapl +! kstapl i boundary array +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer ii1, ii2, i + double precision angle, surf + logical debug + +! angle help variable to determine angle +! debug If true debug statements are carried out otherwise +! they are not +! i loop variable +! ii1 node number +! ii2 node number +! surf help variable for determination of surface +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! ERRINT Put integer in error message +! ERRSUB Error messages +! MSHO11 compute angle +! MSHO19 Compute area of triangle +! PRININ1 print 2d integer array +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! 2433 Internal error in triangle +! ********************************************************************** +! +! PSEUDO CODE +! +! trivial +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen ( 'msho12' ) + + debug = .false. + + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'Debug information from msho12' + + end if + + iex1 = 0 + iex2 = 0 + +! --- Initialize angle values + + angle1 = -1.2d0 + angle2 = -1.2d0 + + do i = 1 , kstap + + ii1 = kstapl(1,i) + ii2 = kstapl(2,i) + + if ( i1==ii2 ) then + +! --- Compute surface of area + + call msho19( coor, ii1, i1, i2, surf ) + + if ( surf<=0 ) then + angle = -1.1d0 + else + +! --- Compute angle ii1-i1-i2 + + call msho11( ii1, i1, i2, coor, angle ) + end if + if ( angle>angle1 ) then + iex1 = ii1 + angle1 = angle + end if + end if + + if ( i2==ii1 ) then + +! --- Compute surface of area + + call msho19( coor, i1, i2, ii2, surf ) + if ( surf<=0 ) then + angle = -1.1d0 + else + +! --- Compute angle i1-i2-ii2 + + call msho11( i1, i2, ii2, coor, angle ) + end if + if ( angle>angle2 ) then + iex2 = ii2 + angle2 = angle + end if + end if + end do + + call erclos ( 'msho12' ) + + if ( debug ) write(irefwr,*) 'End msho12' + + if ( iex1==0 .or. iex2==0 ) then + +! --- Problem in msho12 + + call errint ( i1, 1 ) + call errint ( i2, 2 ) + call errint ( iex1, 3 ) + call errint ( iex2, 4 ) + call errsub ( 2433, 4, 0, 0 ) + + end if + + end diff --git a/extern/sepran/msho13.for b/extern/sepran/msho13.for new file mode 100644 index 000000000..0a2db78a4 --- /dev/null +++ b/extern/sepran/msho13.for @@ -0,0 +1,354 @@ + subroutine msho13 ( coor, i1, i2, kdrie, kstapl, kstap, xn, yn ) +! ====================================================================== +! +! programmer niek praagman +! version 2.2 date 14-02-2010 Checks adjusted (crossing and double) +! version 2.1 date 27-08-2009 Adjust accuracy for double points +! version 2.0 date 14-02-2005 Update +! version 1.4 date 21-02-2003 Layout +! version 1.3 date 21-02-1997 Adjust for "double" points +! version 1.2 date 16-02-1994 New norms +! version 1.1 date 10-10-1990 msho23 replaced by mshg03 +! version 1.0 date 14-04-1989 +! +! copyright (c) 1989-2010 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Determine whether lines from i1 and i2 to new point (xn,yn) do or +! do not cross boundary lines +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! intersection +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpr' +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer i1, i2, kdrie, kstapl(2,*), kstap + double precision coor(2,*), xn, yn + +! coor i coordinate array +! i1 i node of basis element +! i2 i node of basis element +! kdrie o number of line that lines to new point +! crosses. 0 means no crossing ! +! kstap i number of elements in kstapl +! kstapl i current boundary elements array +! xn i x-coordinate new point +! yn i y-coordinate new point +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision xi1, yi1, xi2, yi2, xmin, xmax, ymin, ymax, + + x1, y1, x2, y2, xmi, xma, ymi, yma, xh, yh, + + xpn1, xpn2, ypn1, ypn2, + + dis1, dis2, eps, h1, h2 + integer i, ii1, ii2, ipn1, ipn2, ih + +! dis1 helpdistance +! dis2 helpdistance +! eps accuracy parameter +! h1 helpvariable for distance +! h2 helpvariable for distance +! i loop variable +! ih help indicator +! ii1 first node of boundary line +! ii2 second node of boundary line +! ipn1 node number +! ipn2 node number +! x1 x-coordinate point ii1 +! x2 x-coordinate point ii2 +! xh x-coordinate helppoint +! xi1 x-coordinate first basis point +! xi2 x-coordinate second basis point +! xma extreme x-value quadrangular envelope boundary line +! xmax extreme x-value quadrangular envelope basis line +! xmi extreme x-value quadrangular envelope boundary line +! xmin extreme x-value quadrangular envelope basis line +! xpn1 x-coordinate point ipn1 +! xpn2 x-coordinate point ipn2 +! y1 y-coordinate point ii1 +! y2 y-coordinate point ii2 +! yh y-coordinate helppoint +! yi1 y-coordinate first basis point +! yi2 y-coordinate second basis point +! yma extreme y-value quadrangular envelope boundary line +! ymax extreme y-value quadrangular envelope basis line +! ymi extreme y-value quadrangular envelope boundary line +! ymin extreme y-value quadrangular envelope basis line +! ypn1 y-coordinate point ipn1 +! ypn2 y-coordinate point ipn2 +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! MSHO75 Check whether two linesegments have an internal point +! in common +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Compute coordinates line nodes +! Determine extreme values of line i1-i2 and new point xn,yn +! Run through all boundary elements ii1-ii2 and check whether +! "new" lines i1-n and i2-n intersect line ii1-ii2. Check also +! whether line midpoint-n intersects line ii1-ii2. +! Return with number of line that is crossing. Check for double +! crossings. If it seems to be a double line leave the routine with +! kdrie = -1. In the other case take the "nearest" line kdrie. +! If result is kdrie = 0 then no intersection has been found +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Check whether new point is allowed + call eropen( 'msho13' ) + + eps = 1d4 * epsmac + + xi1 = coor( 1, i1 ) + yi1 = coor( 2, i1 ) + xi2 = coor( 1, i2 ) + yi2 = coor( 2, i2 ) + +! --- Determine extreme values line i1-i2 and new point + + xmin = min( xi1, xi2, xn ) + xmax = max( xi1, xi2, xn ) + ymin = min( yi1, yi2, yn ) + ymax = max( yi1, yi2, yn ) + + kdrie = 0 + +! --- Run through all boundary elements and check whether lines intersect +! each other + + do i = 2, kstap + + ii1 = kstapl( 1, i ) + ii2 = kstapl( 2, i ) + + x1 = coor( 1, ii1 ) + y1 = coor( 2, ii1 ) + + x2 = coor( 1, ii2 ) + y2 = coor( 2, ii2 ) + + xmi = min(x1,x2) + xma = max(x1,x2) + ymi = min(y1,y2) + yma = max(y1,y2) + + if ( xmi<=xmax .and. + + xma>=xmin .and. + + ymi<=ymax .and. + + yma>=ymin ) then +! --- Potential line i: + +! --- Check for point i1 + if ( i1/=ii1 .and. i1/=ii2 ) then +! --- Check for distance and coincidence of points + + dis1 = abs(xi1-x1)+abs(yi1-y1) + dis2 = abs(xi1-x2)+abs(yi1-y2) + + h1 = abs(xi1)+abs(x1)+abs(yi1)+abs(y1) + h2 = abs(xi1)+abs(x2)+abs(yi1)+abs(y2) + + if ( dis1>eps*h1 .and. dis2>eps*h2 ) then + + call msho75( xi1, yi1, xn, yn, x1, y1, x2, y2, ih ) + + if ( ih==0 ) then + if ( kdrie == 0 ) then +! --- First crossing line: + kdrie = i + else if ( kdrie>0 .and. kdrie/=i ) then +! --- Double crossing: +! -Compute distance to midpoint kdrie + ipn1 = kstapl( 1, kdrie ) + ipn2 = kstapl( 2, kdrie ) + +! -Coordinates midpoint piece kdrie: + xpn1 = (coor(1,ipn1)+coor(1,ipn2))/2d0 + ypn1 = (coor(2,ipn1)+coor(2,ipn2))/2d0 + +! -Coordinates midpoint piece i1 - i2: + xpn2 = (xi1+xi2)/2d0 + ypn2 = (yi1+yi2)/2d0 + + dis1 = (xpn1-xpn2)*(xpn1-xpn2)+ + + (ypn1-ypn2)*(ypn1-ypn2) + +! -Coordinates midpoint piece i: + xpn1 = ( x1 + x2 ) / 2d0 + ypn1 = ( y1 + y2 ) / 2d0 + + dis2 = (xpn1-xpn2)*(xpn1-xpn2)+ + + (ypn1-ypn2)*(ypn1-ypn2) + + if ( dis2<(1d0-eps)*dis1 ) then +! --- Take new one i.e. i: + kdrie = i + else if ( dis2<(1d0+eps)*dis1 ) then +! --- Problems: return + kdrie = -1 + goto 1000 + else +! --- Use old value do not change kdrie + end if + + end if + end if + end if + end if +! --- Check for point i2 + if ( i2/=ii1 .and. i2/=ii2 ) then +! --- Check for distance and coincidence of points + dis1 = abs(xi2-x1)+abs(yi2-y1) + dis2 = abs(xi2-x2)+abs(yi2-y2) +! --- Helpaccuracy: + h1 = abs(xi2)+abs(x1)+abs(yi2)+abs(y1) + h2 = abs(xi2)+abs(x2)+abs(yi2)+abs(y2) +! --- If no coïncidence: + if ( dis1>eps*h1 .and. dis2>eps*h2 ) then + call msho75( xi2, yi2, xn, yn, x1, y1, x2, y2, ih ) + + if ( ih == 0 ) then + if ( kdrie == 0 ) then +! --- First crossing line: + kdrie = i + else if ( kdrie>0 .and. kdrie/=i ) then +! --- Double crossing: +! -Compute distance to midpoint kdrie + ipn1 = kstapl( 1, kdrie ) + ipn2 = kstapl( 2, kdrie ) + +! -Coordinates midpoint piece kdrie: + xpn1 = (coor(1,ipn1)+coor(1,ipn2))/2d0 + ypn1 = (coor(2,ipn1)+coor(2,ipn2))/2d0 + +! -Coordinates midpoint piece i1 - i2: + xpn2 = (xi1+xi2)/2d0 + ypn2 = (yi1+yi2)/2d0 + + dis1 = (xpn1-xpn2)*(xpn1-xpn2)+ + + (ypn1-ypn2)*(ypn1-ypn2) + +! -Coordinates midpoint piece i: + xpn1 = ( x1 + x2 ) / 2d0 + ypn1 = ( y1 + y2 ) / 2d0 + + dis2 = (xpn1-xpn2)*(xpn1-xpn2)+ + + (ypn1-ypn2)*(ypn1-ypn2) + + if ( dis2<(1d0-eps)*dis1 ) then +! --- Take new one i.e. i: + kdrie = i + else if ( dis2<(1d0+eps)*dis1 ) then +! --- Problems: return + kdrie = -1 + goto 1000 + else +! --- Use old value do not change kdrie + end if + end if + end if + end if + end if +! --- Finally check for middle point + xh = ( xi1 + xi2 ) / 2d0 + yh = ( yi1 + yi2 ) / 2d0 + + xh = ( eps * xn + (1d0-eps) * xh ) + yh = ( eps * yn + (1d0-eps) * yh ) + + call msho75(xh,yh,xn,yn,x1,y1,x2,y2,ih) + + if ( ih == 0 ) then + if ( kdrie == 0 ) then +! --- First crossing line: + kdrie = i + else if ( kdrie>0 .and. kdrie/=i ) then +! --- Double crossing: +! -Compute distance to midpoint kdrie + ipn1 = kstapl( 1, kdrie ) + ipn2 = kstapl( 2, kdrie ) + +! -Coordinates midpoint piece kdrie: + xpn1 = (coor(1,ipn1)+coor(1,ipn2))/2d0 + ypn1 = (coor(2,ipn1)+coor(2,ipn2))/2d0 + +! -Coordinates midpoint piece i1 - i2: + xpn2 = (xi1+xi2)/2d0 + ypn2 = (yi1+yi2)/2d0 + + dis1 = (xpn1-xpn2)*(xpn1-xpn2)+ + + (ypn1-ypn2)*(ypn1-ypn2) + +! -Coordinates midpoint piece i: + xpn1 = ( x1 + x2 ) / 2d0 + ypn1 = ( y1 + y2 ) / 2d0 + + dis2 = (xpn1-xpn2)*(xpn1-xpn2)+ + + (ypn1-ypn2)*(ypn1-ypn2) + + if ( dis2<(1d0-eps)*dis1 ) then +! --- Take new one i.e. i: + kdrie = i + else if ( dis2<(1d0+eps)*dis1 ) then +! --- Problems: return + kdrie = -1 + goto 1000 + else +! --- Use old value do not change kdrie + end if + + end if + end if + end if + end do + +! --- Checking is ready +1000 call erclos( 'msho13' ) + + end diff --git a/extern/sepran/msho14.for b/extern/sepran/msho14.for new file mode 100644 index 000000000..1924e8662 --- /dev/null +++ b/extern/sepran/msho14.for @@ -0,0 +1,113 @@ + subroutine msho14 ( coor, jpn, npoint, itri, i1, i2, + + xn, yn, dista ) +! ====================================================================== +! +! programmer niek praagman +! version 3.0 date 14-02-2005 Update +! version 2.0 date 16-02-1994 New norms +! version 1.0 date 14-04-1989 +! +! copyright (c) 1989-2005 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Determine nearest boundary point to proposed new point. +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! neighbour +! distance +! ********************************************************************** +! +! MODULES USED +! + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer i1, i2, itri(*), jpn, npoint + double precision coor(2,*), xn, yn, dista + +! coor i coordinate array +! dista o distance new point to boundary point +! i1 i first node basis line +! i2 i second node basis line +! itri i array with for each point number of times +! that point appears in present boundary +! jpn o node number of nearest point +! npoint i actual number of points in mesh +! xn i x-coordinate new point +! yn i y-coordinate new point +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer ih + double precision xi, yi, dx, dy, dist + +! dist Euclidian distance +! dx first component distance vector +! dy second component distance vector +! ih loop variable +! xi x-coordinate boundary point +! yi y-coordinate boundary point +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Run through all points +! If point in boundary and not one of the basis points then +! compute distance new point - boundary point +! if distance smaller then reference value adjust +! reference value and node number +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + jpn = 0 + do ih = 1 , npoint + if ( ih/=i1 .and. ih/=i2 .and. itri(ih)/=0 ) then + xi = coor( 1, ih ) + yi = coor( 2, ih ) + dx = xn - xi + dy = yn - yi + dist = sqrt ( dx*dx + dy*dy ) + if ( distleng ) then + +! --- Declared length too small + + call errsub ( 903, 0, 0, 0 ) + end if + +! --- Clear ibuurp + + do i = 1, isum + ibuurp(i) = 0 + end do + leng = isum + +! --- Fill array ibuurp + + do i = 1 , nelem + is = 3*(i-1) + i1 = kelem(is+1) + i2 = kelem(is+2) + i3 = kelem(is+3) + call msho17(ibuurp,iwork,i1,i2) + call msho17(ibuurp,iwork,i1,i3) + call msho17(ibuurp,iwork,i2,i1) + call msho17(ibuurp,iwork,i2,i3) + call msho17(ibuurp,iwork,i3,i1) + call msho17(ibuurp,iwork,i3,i2) + end do + call erclos( 'msho16' ) + end diff --git a/extern/sepran/msho17.for b/extern/sepran/msho17.for new file mode 100644 index 000000000..5cec4fe5a --- /dev/null +++ b/extern/sepran/msho17.for @@ -0,0 +1,96 @@ + subroutine msho17( ibuurp, iwork, ih, ij ) + +! ======================================================================= +! +! +! programmer niek praagman +! +! version 2.0 date 21-02-1994 New norms +! version 1.0 date 14-04-1989 +! +! +! +! copyright (c) 1989-1994 "ingenieursbureau sepra" +! permission to copy or distribute this software or documentation +! in hard or soft copy granted only by written license obtained +! from "ingenieursbureau sepra". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system (e.g. , in memory, disk or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! +! *********************************************************************** +! +! DESCRIPTION +! +! Fill nodal point number ij in right position of array ibuurp +! +! *********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! neighbour +! *********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + implicit none + integer ibuurp(*),iwork(*),ih,ij + +! ibuurp i,o array containing the nodal point numbers of +! the neighbours +! ih i nodal point number to be considered +! ij i nodal point number of neighbour +! iwork i pointer array +! +! *********************************************************************** +! +! COMMON BLOCKS +! +! *********************************************************************** +! +! LOCAL PARAMETERS +! + integer jstart +! +! jstart startaddress for present point ih in array IBUURP +! +! *********************************************************************** +! +! SUBROUTINES CALLED +! +! *********************************************************************** +! +! ERROR MESSAGES +! +! *********************************************************************** +! +! PSEUDO CODE +! +! trivial +! +! ======================================================================= + + jstart=0 + + if ( ih.ne.1 ) jstart = iwork(ih-1) + +100 jstart = jstart + 1 + +! If point is already placed then return + + if ( ibuurp ( jstart ).eq.ij ) goto 200 + +! If not yet last neighbour, then check next + + if ( ibuurp ( jstart ).ne. 0 ) goto 100 + +! Position is empty, place new neighbour + + ibuurp ( jstart ) = ij + +200 continue + + end diff --git a/extern/sepran/msho18.for b/extern/sepran/msho18.for new file mode 100644 index 000000000..2c3d29721 --- /dev/null +++ b/extern/sepran/msho18.for @@ -0,0 +1,284 @@ + subroutine msho18 ( kelem, nelem, coor, npoint, nipnt, iwork, + + ibuurp, coars ) +! ====================================================================== +! +! programmer niek praagman +! version 2.4 date 07-12-2010 New method Laplace +! version 2.3 date 27-08-2009 Enlarge stopvalue of repositioning +! version 2.2 date 24-03-2009 Check eventually correctness Laplacian +! repositioning (Plaxis) +! +! copyright (c) 1989-2010 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Perform a Laplacian repositioning of the nodes +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! repositioning +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpi' +! include 'SPcommon/cmcdpr' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision coor(2,*), coars + integer nelem, npoint, nipnt, iwork(*), ibuurp(*), kelem(3,nelem) + +! coars i coarseness, reference length +! coor i/o coordinate array +! ibuurp i array with nodal point numbers of neighbour points +! for each point +! iwork i helparray with startaddresses of IBUURP +! kelem i element array +! nelem i number of elements in mesh +! nipnt i number of boundary points +! npoint i total number of points in the mesh +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision afstnd, xz, yz, xh, yh, xn, yn, af, + + surf, surf1, surfre + integer jr, ikn, jstart, jeind, nbuur, i, jkn, + + iallow, i1, i2, i3 + logical debug, finished + +! af extreme value for distances +! afstnd distance between old and new position of point +! debug if true debug statements are carried out otherwise +! they are not +! finished logical to indicate whether loop is finished or not +! i loop variable +! iallow allowance indicator +! ikn loop variable +! jeind endaddress neighbours +! jkn local node number +! jr loop variable +! jstart startaddress neighbours +! nbuur number of neighbours +! surf surface of all elements containing specified node +! surf1 surface one special element +! surfre reflection value for surface +! xh old x-coordinate +! xz new x-coordinate +! yh old y-coordinate +! yz new y-coordinate +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Compute stop value for coarseness +! while not finished do +! compute max repositioning distance +! check whether distance small enough +! if so finished else reposition again +! end while +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Compute stop value for coarseness + + debug = .false. + coars = 0.02 * coars + finished = .false. + jr = 1 + do while ( .not. finished ) + jr = jr + 1 + afstnd = 0d0 + do ikn = nipnt + 1 , npoint + +! --- Node ikn, compute surface + + surf = 0d0 + surf1 = 0d0 + +! --- Start values for ikn: + + xh = coor(1,ikn) + yh = coor(2,ikn) + +! --- Add surf of all elements ikn is node of: + + do i = 1, nelem + i1 = kelem( 1,i ) + i2 = kelem( 2,i ) + i3 = kelem( 3,i ) + +! --- Check triangle and add surface: + + if ( i1==ikn.or.i2==ikn.or.i3==ikn ) then + call msho19(coor,i1,i2,i3,surf1) + surf = surf + surf1 + end if + end do + +! --- Set reference value for surface + + surfre = surf + +! --- Run through all neighbours and compute (xz,yz): + + jstart = 0 + if ( ikn/=1 ) jstart = iwork( ikn - 1 ) + jstart = jstart + 1 + jeind = iwork( ikn ) + if ( jstart<=jeind ) then + +! --- jstart<=jeind, there are neighbours, initialize: + + xz = 0d0 + yz = 0d0 + +! --- Set number of neighbours: + + nbuur = jeind - jstart + 1 + +! --- Run through all neighbours and compute barycenter: + + do i = jstart , jeind + jkn = ibuurp(i) + if ( jkn>0 ) then + xz = xz + coor(1,jkn) + yz = yz + coor(2,jkn) + else + nbuur = nbuur - 1 + end if + end do + +! --- New(?) coordinates + + xz = xz / nbuur + yz = yz / nbuur + +! --- Two possibilities: No relaxation or Overrelaxation: + + xn = xh + 1.62 * ( xz - xh ) + yn = yh + 1.62 * ( yz - yh ) + +! --- Try overrelaxation: Set coordinates: + + coor(1,ikn) = xn + coor(2,ikn) = yn + +! --- Check surface: + + surf = 0d0 + +! --- Run through all elements: + + do i = 1, nelem + i1 = kelem( 1,i ) + i2 = kelem( 2,i ) + i3 = kelem( 3,i ) + +! --- Check triangle and add surface: + + if ( i1==ikn.or.i2==ikn.or.i3==ikn ) then + call msho19(coor,i1,i2,i3,surf1) + surf = surf + abs(surf1) + end if + end do + iallow = 0 + if ( abs(surf - surfre)<100 * epsmac ) iallow = 2 + +! --- Allowed? Then ready: + + if ( iallow/=2 ) then + +! --- Not allowed: Check for barycenter: + + coor(1,ikn) = xz + coor(2,ikn) = yz + +! --- Check surface: + + surf = 0d0 + +! --- Run through all elements: + + do i = 1, nelem + i1 = kelem( 1,i ) + i2 = kelem( 2,i ) + i3 = kelem( 3,i ) + +! --- Check triangle and add surface: + + if ( i1==ikn.or.i2==ikn.or.i3==ikn ) then + call msho19(coor,i1,i2,i3,surf1) + surf = surf + surf1 + end if + end do + if ( abs(surf - surfre)<100 * epsmac ) iallow = 1 + +! --- Allowed? Then ready: + + if ( iallow==0 ) then + +! --- Nothing allowed use old values: + + coor(1,ikn) = xh + coor(2,ikn) = yh + end if + end if + +! --- Check whether "new" point is different from "old" point: + + xz = coor(1,ikn) + yz = coor(2,ikn) + +! --- Compute distance: + + af = (xh-xz)*(xh-xz)+(yh-yz)*(yh-yz) ! squared distance + if ( af>afstnd ) afstnd=af + end if ! ( jstart<=jeind ) + end do + +! --- Check whether wanted accuracy is found: + + if ( debug ) + + write(irefwr,*) 'jr =',jr,'afstand=',afstnd,'coars=',coars + if ( jr>2 .and. sqrt(afstnd) 90 degrees +! Indicate which side it concerns. +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! angle +! ********************************************************************** +! +! MODULES USED +! + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision a, b, c + integer icase + +! a i length of first side of triangle +! b i length of second side of triangle +! c i length of third side of triangle +! icase o indicator if (>0) an angle and which angle is too large +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision angle1, angle2, angle3, aa, bb, cc, q + +! aa length of side one squared +! angle1 first angle +! angle2 second angle +! angle3 third angle +! bb length of side two squared +! cc length of side three squared +! q constant +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Trivial +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Square the three sides + + aa = a * a + bb = b * b + cc = c * c + +! --- Use cosine rule to compute the cosine of each of the three angles + + angle1 = ( cc + aa - bb ) / ( 2 * c * a ) + angle2 = ( aa + bb - cc ) / ( 2 * a * b ) + angle3 = ( bb + cc - aa ) / ( 2 * b * c ) + + q = -0.01d0 + +! --- Suppose that all angles are < 90 degrees: + icase = 0 + +! --- Next check whether this is correct: + if ( angle1.lt.q ) then + icase = 1 + else if ( angle2.lt.q ) then + icase = 2 + else if ( angle3.lt.q ) then + icase = 3 + end if + + end diff --git a/extern/sepran/msho24.for b/extern/sepran/msho24.for new file mode 100644 index 000000000..9c20e5112 --- /dev/null +++ b/extern/sepran/msho24.for @@ -0,0 +1,226 @@ + subroutine msho24 ( kstapl, kstap, coor, i1, i2, icheck ) +! ====================================================================== +! +! programmer Niek Praagman +! version 3.1 date 23-02-2010 Adjustment for plaxis pnts, use +! MSHO75 in stead of MSHG03 +! version 3.0 date 14-02-2005 Update +! version 2.2 date 25-06-1999 For savety leave routine if second point +! is plaxis +! version 2.1 date 26-05-1997 Check coincidence of double +! Plaxis points +! version 2.0 date 21-02-1994 New norms +! version 1.1 date 14-10-1990 use routine MSHG03 +! version 1.0 date 17-04-1989 +! +! copyright (c) 1989-2010 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Check whether line i1 - i2 has a common point with one of the +! boundary lines +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! crossing_point +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpr' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision coor(2,*) + integer kstap, kstapl(2,kstap), i1, i2, icheck + +! coor i coordinate array +! i1 i first node of line to be considered +! i2 i second node of line to be considered +! icheck o if a line crosses the new element then +! icheck # 0 and equal to number of line +! if no point is "inside" the new element then +! icheck = -1 else icheck is nodenumber of point +! inside +! kstap i number of lines in kstapl +! kstapl i actual array with boundary lines +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision x1, y1, x2, y2, xmin, xmax, ymin, ymax, xa, ya, + + xb, yb, xlm, ylm, eps, dis + integer ia, ib, ih, il + +! dis distance +! eps accuracy +! ia node number +! ib node number +! ih indicator +! il loop variable +! x1 x-coordinate +! x2 x-coordinate +! xa x-coordinate +! xb x-coordinate +! xlm extreme x-value +! xmax extreme x-value +! xmin extreme x-value +! y1 y-coordinate +! y2 y-coordinate +! ya y-coordinate +! yb y-coordinate +! ylm extreme y-value +! ymax extreme y-value +! ymin extreme y-value +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! MSHO75 check whether two line segments have a common point +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen( 'msho24' ) + + eps = 10 * epsmac + + icheck = -1 + + x1 = coor(1,i1) + y1 = coor(2,i1) + + x2 = coor(1,i2) + y2 = coor(2,i2) + + xmin = min(x1,x2) + xmax = max(x1,x2) + ymin = min(y1,y2) + ymax = max(y1,y2) + +! --- Check whether line i1 - i2 has point in common +! with old boundary lines. + + do il = 1 , kstap + + ia = kstapl(1,il) + ib = kstapl(2,il) + +! --- First check whether node numbers of boundary element +! are either equal i1 or i2 + + if ( ia==i1 .or. ia==i2 ) goto 200 + if ( ib==i1 .or. ib==i2 ) goto 200 + + xa = coor(1,ia) + ya = coor(2,ia) + + xb = coor(1,ib) + yb = coor(2,ib) + +! --- Check whether coordinates of nodes are exactly the same, i.e. +! whether it concerns Plaxis points +! Point ia and i1 + + dis = (x1-xa)*(x1-xa) + (y1-ya)*(y1-ya) + + if ( disxmax ) goto 200 + xlm = max(xa,xb) + if ( xlmymax ) goto 200 + ylm = max(ya,yb) + if ( ylm1 ) then + + i1 = kstapl(1,ielem) + i2 = kstapl(2,ielem) + + kstapl(1,ielem) = kstapl(1,1) + kstapl(2,ielem) = kstapl(2,1) + + kstapl(1,1) = i1 + kstapl(2,1) = i2 + + end if + + end diff --git a/extern/sepran/msho26.for b/extern/sepran/msho26.for new file mode 100644 index 000000000..42a620e29 --- /dev/null +++ b/extern/sepran/msho26.for @@ -0,0 +1,115 @@ + subroutine msho26( kelem, nelem, i2, i3, jelem, i4 ) + +! ======================================================================= +! +! +! programmer niek praagman +! +! version 3.0 date 02-02-2010 Redesign +! version 2.0 date 22-02-1994 New norms +! version 1.0 date 17-04-1989 +! +! +! +! copyright (c) 1989-2010 "ingenieursbureau sepra" +! permission to copy or distribute this software or documentation +! in hard or soft copy granted only by written license obtained +! from "ingenieursbureau sepra". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system (e.g. , in memory, disk or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! +! *********************************************************************** +! +! DESCRIPTION +! +! Determine triangle where i2 - i3 is side of +! +! *********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! triangle +! +! *********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer kelem(*), nelem, i2, i3, jelem, i4 + +! i2 i node number +! i3 i node number +! i4 o extra node to form triangle +! jelem o number of element found +! kelem i element array +! nelem i number of elements in kelem +! +! *********************************************************************** +! +! COMMON BLOCKS +! +! *********************************************************************** +! +! LOCAL PARAMETERS +! + integer ielem, j, j1, j2, j3 +! +! j loop variable +! j1 local element node +! j2 local element node +! j3 local element node +! +! *********************************************************************** +! +! SUBROUTINES CALLED +! +! *********************************************************************** +! +! ERROR MESSAGES +! +! *********************************************************************** +! +! METHOD +! +! ======================================================================= + + ielem = jelem + + jelem = 0 + + do 200 j = 1, nelem + + if ( j /= ielem ) then +! --- Find triangle j with the same side i2 - i3 that is not equal to +! element ielem: + + j1 = kelem(3*j-2) + j2 = kelem(3*j-1) + j3 = kelem(3*j ) + + if ( j1.eq.i3 .and. j2.eq.i2 ) then + jelem = j + i4 = j3 + goto 500 + else if ( j2.eq.i3 .and. j3.eq.i2 ) then + jelem = j + i4 = j1 + goto 500 + else if ( j3.eq.i3 .and. j1.eq.i2 ) then + jelem = j + i4 = j2 + goto 500 + end if + + end if + +200 continue + + i4 = 0 + +500 continue + + end diff --git a/extern/sepran/msho27.for b/extern/sepran/msho27.for new file mode 100644 index 000000000..9f3d7fc72 --- /dev/null +++ b/extern/sepran/msho27.for @@ -0,0 +1,147 @@ + subroutine msho27( coor, i1, i2, i3, i4 ) +! ====================================================================== +! +! programmer niek praagman +! version 3.0 date 22-02-1994 New norms +! version 2.0 date 07-09-1989 New method utilizing a circle-concept +! version 1.0 date 17-04-1989 +! +! copyright (c) 1989-1999 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Determine best diagonal in quadrangle. At input diagonal is +! line 2-3. Check whether 1-4 is better. +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! diagonal +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpr' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision coor(*) + integer i1, i2, i3, i4 + +! coor i coordinate array +! i1 i node +! i2 i node +! i3 i node +! i4 i node +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision af1, af2, xa, xb, xc, xd, ya, yb, yc, yd, + + xm, ym, det + integer j1, j2, j3, j4 + +! af1 distance +! af2 distance +! det area of triangle +! j1 helpnode +! j2 helpnode +! j3 helpnode +! j4 helpnode +! xa x-coordinate +! xb x-coordinate +! xc x-coordinate +! xd x-coordinate +! xm x-coordinate +! ya y-coordinate +! yb y-coordinate +! yc y-coordinate +! yd y-coordinate +! ym y-coordinate +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- consider quadrangle i1 - i2 - i3 - i4 + + j1 = i1 + j2 = i2 + j3 = i3 + j4 = i4 + +! --- Determine best diagonal + + xa = coor(2*i1-1) + xb = coor(2*i2-1) + xc = coor(2*i3-1) + xd = coor(2*i4-1) + ya = coor(2*i1 ) + yb = coor(2*i2 ) + yc = coor(2*i3 ) + yd = coor(2*i4 ) + det = (xa-xb)*(ya-yc) - (xa-xc)*(ya-yb) + if ( abs(det).lt.10 * epsmac ) then + +! --- Triangle 1-2-3 is not good, take diagonal 1-4 + + i1 = j2 + i2 = j4 + i3 = j1 + i4 = j3 + else + xm = ( ( xa*xa + ya*ya ) * ( yb-yc ) + + + ( xb*xb + yb*yb ) * ( yc-ya ) + + + ( xc*xc + yc*yc ) * ( ya-yb ) ) / (2*det) + ym = ( ( xa*xa + ya*ya ) * ( xb-xc ) + + + ( xb*xb + yb*yb ) * ( xc-xa ) + + + ( xc*xc + yc*yc ) * ( xa-xb ) ) / (-2*det) + af1 = ( xa-xm ) * ( xa-xm ) + ( ya-ym ) * ( ya-ym ) + af2 = ( xd-xm ) * ( xd-xm ) + ( yd-ym ) * ( yd-ym ) + if ( af2.lt.af1 ) then + +! --- Change diagonal : (4-1 instead of 2-3) + + i1 = j2 + i2 = j4 + i3 = j1 + i4 = j3 + end if + end if + end diff --git a/extern/sepran/msho28.for b/extern/sepran/msho28.for new file mode 100644 index 000000000..263ab6571 --- /dev/null +++ b/extern/sepran/msho28.for @@ -0,0 +1,174 @@ + subroutine msho28 ( coor, i1, i2, i3, xn, yn, npoint, itri, + + iperm ) +! ====================================================================== +! +! programmer niek praagman +! version 3.1 date 23-03-2009 Accuracy adjusted using norm +! version 3.0 date 15-02-2005 Update +! version 2.2 date 29-09-1998 Correction for double line +! version 2.1 date 21-02-1997 Adjust for double line and hence +! for "double" points +! version 2.0 date 22-02-1994 New norms +! version 1.0 date 07-06-1989 +! +! copyright (c) 1989-2009 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Check whether there are boundary points inside the +! triangle with nodes i1 - i2 - i3. +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! check +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpr' +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision coor(2,*), xn, yn + integer i1, i2, i3, npoint, itri(*), iperm + +! coor i coordinate array +! i1 i first node +! i2 i second node +! i3 i last node triangle, if 0 then new coordinates +! are given by xn,yn +! iperm o result , IPERM = 1 there are internal points +! IPERM = 0 no internal points +! itri i indicator whether point i is in boundary or not +! npoint i number of points in COOR +! xn i coordinate new point if i3 = 0 +! yn i coordinate new point if i3 = 0 +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision x1, y1, x2, y2, x3, y3, xm, ym, opp, det, eps, + + dist, norm + integer i + +! det area of triangle +! dist distance +! eps accuracy +! i loop variable +! norm normed value for length +! opp area of triangle +! x1 x-coordinate +! x2 x-coordinate +! x3 x-coordinate +! xm x-coordinate +! y1 y-coordinate +! y2 y-coordinate +! y3 y-coordinate +! ym y-coordinate +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Check for all boundary points whether they are inside +! If point inside then check whether point is a "double" +! point +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + iperm = 1 + eps = 1d-2 * epsmac + +! --- Check whether boundary points are inside triangle + + x1 = coor(1,i1) + y1 = coor(2,i1) + + x2 = coor(1,i2) + y2 = coor(2,i2) + + if ( i3==0 ) then + x3 = xn + y3 = yn + else + x3 = coor(1,i3) + y3 = coor(2,i3) + end if + +! --- Compute relative value for length of "vector": + norm = abs(x1)+abs(x2)+abs(x3)+abs(y1)+abs(y2)+abs(y3) + +! --- Compute area of triangle + det = x1*(y2-y3) + x2*(y3-y1) + x3*(y1-y2) + + do i = 1, npoint +! --- If not point of triangle and point i in boundary then check + if (i/=i1.and.i/=i2.and.i/=i3.and.itri(i)/=0) then + + xm = coor(1,i) + ym = coor(2,i) + + opp = (x1*(y2-ym) + x2*(ym-y1) + xm*(y1-y2))/det + if ( opp<-eps .or. opp>1d0+eps ) goto 100 + + opp = (x2*(y3-ym) + x3*(ym-y2) + xm*(y2-y3))/det + if ( opp<-eps .or. opp>1d0+eps ) goto 100 + + opp = (x3*(y1-ym) + x1*(ym-y3) + xm*(y3-y1))/det + if ( opp<-eps .or. opp>1d0+eps ) goto 100 + +! --- Point i is inside, check whether point coincides +! with one of the cornerpoints (and hence is a "double" +! point) + + dist = abs(x1-xm) + abs(y1-ym) + + if ( distnipnt ) then + iex = iwork(ia)-iwork(ia-1) + if ( iex==3 .or. ianipnt ) then + iex = iwork(ib)-iwork(ib-1) + if ( iex==3 .or. ibnipnt ) then + iex = iwork(ic)-iwork(ic-1) + if ( iex==3 .or. icnipnt ) then + iex = iwork(id)-iwork(id-1) + if ( iex==3 .or. ididebug +! ielem loop variable for elements +! iex1 node to be considered, neighbour +! iex2 node to be considered, neighbour +! ifill indicator whether diagonals of quadrilaterals +! have been changed (1) or not (0) +! ih loop variable +! ii1 node to be considered +! ii2 node to be considered +! imultiply Multiplication factor +! In this program this factor is arbitrarely set to +! 10 log(coarsemax/coarsemin) +! It is used to define the number of searches for +! "acceptable" elements +! inear indicator how near a boundary point is +! iperm indicator whether line is permitted or not +! ipoint node number +! ipotn1 potential point +! ipotn2 potential point +! itot help for summing +! itri array containing information whether a nodal point np is +! in the actual boundary (itri(np)>0) or not (=0) +! j1 node number +! j2 node number +! j3 node number +! j4 node number +! ja help indicator +! jcoars indicator whether coarseness is given (1) or not (0) +! jcube array indicating whether a cube is outside the volume (0), +! is a boundary cube ( 1 ) or is inside ( 2 ) +! jelem element number +! jpn node number +! kdrie number of boundary element for crossing +! kinbnd array with extra internal boundary pieces +! kstap actual length of array KSTAPL +! kstapl array containing all actual boundary elements +! lenbnd length axtra internal curvs part in kinbnd +! leng actual length of repos array +! ma maximum value +! maxratio maximum ratio allowed in two subsequent elements +! meshtmp helparray to store temporarily elements of "best" mesh +! n1 actual number of blocks in x-direction +! n2 actual number of blocks in y-direction +! nc cube number +! ncube number of reference blocks +! neldef defined length of helpelementsarray +! nelemi Number of internal cells (elements) +! Hence, number of boundary cells = nelem - nelemi +! neltmp helpvariable allocation array of elements +! nherha count of redivisions performed +! nipnt number of initial points +! nkmeshc estimated number of elements in MESH +! no help indicator +! nochan change indicator +! npndef defined length of defined help pointsarray +! npntmp helpvariable allocation array of points +! nrepos estimated length of repositioning array +! nx number of reference blocks in x-direction +! ny number of reference blocks in y-direction +! ratiop min ratio of temporary mesh +! surf area value +! surf1 area value +! surf2 area value +! tran scaling parameter +! userco local helparray to store coordinates of all userpoints +! valare reference areavalue +! verh ratio +! x x-coordinate +! xm x-coordinate help node on boundary +! xmaxloc extreme (max) x-value for the whole area +! xminloc extreme (min) x-value for the whole area +! xmint min x for transformation +! xn x-coordinate new point +! xnx x-coordinate second new point +! xstart x-reference coordinate +! y y-coordinate +! ym y-coordinate help node on boundary +! ymaxloc extreme (max) y-value for the whole area +! yminloc extreme (min) y-value for the whole area +! ymint min y for transformation +! yn y-coordinate new point +! yny y-coordinate second new point +! ystart y-reference coordinate +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! ERRINT Put integer in error message +! ERRSUB Error messages +! MSHCHKSTAPL Check the contents of array kstapl +! MSHCURVINTERS2 Check if edges in boundary of surface do not intersect +! MSHO01 Check number of neighbours for all boundary points and +! compute coarseness for all points +! MSHO03 Compute distance between two points +! MSHO04 Determine extreme coordinate values +! MSHO05 Determine min and max distance for total area +! MSHO06 Determine coarseness for each triangle +! MSHO07 Check whether point belongs to given area +! MSHO08 Check whether all elements are given right and adjust +! boundary elements array +! MSHO09 Compute midpoint line and the normal vector +! MSHO10 Fill element in in array and adjust boundary array +! MSHO11 compute angle +! MSHO12 Compute neighbour nodes and angles +! MSHO13 Check for common points with other lines +! MSHO14 Check whether new point is not too near to +! old point +! MSHO15 Fill element with new point in in array +! MSHO16 Compute number of neighbours of points +! MSHO18 Perform repositioning +! MSHO19 Compute area of triangle +! MSHO20 Change ordering of boundary +! MSHO21 Compute reference value for area +! MSHO22 Check form of triangle +! MSHO24 Check whether line has point in common with boundary +! MSHO25 Place smallest element at top of boundary array +! MSHO26 Determine triangle with given side +! MSHO27 Determine best diagonal in quadrilateral +! MSHO28 Check whether boundary points are inside triangle +! MSHO29 Remove internal points with three or four neighbours +! MSHO30 Make boundar array for all elements surrounding +! element indicated +! MSHO33 Determine the ratio (2*Rout/Rin) for all triangles of mesh +! MSHO35 Place special nodes and nodes and elements around +! these nodes +! MSHO36 Add nodal points of internal lines to coor and adjust +! array of boundaries kstapl for mesh generation +! MSHO38 check the coarseness in the total domain considered +! in relation to smoothness requirements +! MSHO40 Check whether all barycenters of triangles are only +! belonging to their "own" triangle +! MSHO42 Check whether line i - j is a piece in one of the internal +! curves +! MSHTRANS2DSUR Transform 2d region to region of unit length in first +! quadrant +! PLOTBOUNINTER Plot actual boundary during the process of creation +! of a mesh +! PLOTMESHINTER Plot actual mesh during the process of creation of a mesh +! PRININ print 1d integer array +! PRININ1 print 2d integer array +! PRINRL1 Print 2d real vector +! ********************************************************************** +! +! I/O +! +! none +! ********************************************************************** +! +! ERROR MESSAGES +! +! 900 Estimated number of points too small +! 901 Estimated length of element array too small. +! 902 No convergence in MESH generation. +! 903 Either connections array not correct or repositioning +! array too small +! ********************************************************************** +! +! PSEUDO CODE +! +! MSHO2D is meant to divide an arbitrary polygon in triangles +! The method used is the so-called advancing boundary method +! Consider all parts that together constitute the boundary of the area +! that has to be triangulated. +! A global coarseness is computed over the whole area using a Laplacian +! method. +! If special points (array coar) are submitted the division is started by +! creating special elements around these points. +! Next the smallest part (segment) of the boundary is determined. +! First it is considered whether there can be created a triangle with one of +! the two neighbouring segments +! If so the new boundary is defined and the +! process starts again. +! If not the process goes on +! A new point is defined using the inside pointing normal. It is con- +! sidered whether this new point is really inside and far enough away +! from the other boundary lines. +! If not so it is considered whether a triangle can be formed using +! one of the already created points. +! If so the boundary is redefined and the process starts +! again. +! If not the actual considered part is placed at the back +! of the boundary array and another part is considered first. +! If so the new boundary is defined and the process starts. +! The process ends when there are no parts in the boundary, i.e. the area +! has been divided totally in triangles or when it is not possible to cre- +! ate new triangles. In that case a message is given. +! If the process has terminated normally, a repositioning is performed. +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen( 'msho2d' ) + debug = .false. + +! --- debug = .false. + + if ( debug ) write(irefwr,*) 'At start of msho2d, npunt =',npunt + idebug = 10000000 + icount = 0 + +! --- Copy estimate for number of elements: + + !nkmeshc = nelem + nkmeshc = 2000000 ! nelem is uninitialised + +! --- Initialize + + neltmp = 0 + npntmp = 0 + +! --- Allocate helparrays: + + allocate( chelp ( npunt ) ) + allocate( icube ( npunt ) ) + allocate( itri ( npunt ) ) + allocate( kstapl ( 10 * npunt + 20 ) ) + +! --- Fill arrays userco and coaval: + + allocate( userco( 2 * nuspnt ) ) + allocate( coaval( 2 + nuspnt ) ) + +! --- Coordinates: + + do i=1, nuspnt + userco(2*i-1) = rinput(1 + ndim*i) + userco(2*i ) = rinput(2 + ndim*i) + end do + +! --- Coarseness: + + ! AvD: enable this to use coarseness points and coarseness values in rinput array (if nuspnt>0) + jcoars = 0 !intarmsh(44) + + if ( jcoars==1 ) then + +! --- Coarseness is given: + + do i=1, nuspnt+2 + coaval( i ) = rinput(2 + ndim*nuspnt + i) + end do + else + +! --- No coarseness given, hence no actions: + + coaval( 1 ) = 1d0 + end if + + if ( debug ) then + +! --- Give coordinates and coarsenesses submitted userpoints: + + write(irefwr,*) 'in msho2d, nuspnt = ',nuspnt + write(irefwr,*) 'coordinates and coarseness:' + write(irefwr,*) 'overall coarseness',coaval(1) + write(irefwr,*) 'maxratio ',coaval(nuspnt + 2) + do i=1, nuspnt + write(irefwr,*) i,userco(2*i-1),userco(2*i),coaval(i+1) + end do + end if + +! --- Replace all nodes temporarily to the first (positive) quadrant: +! (Determine translation parameters x- and y-tran) + + call mshtrans2dsur( coor, npoint, xmint, ymint, tran, + + ncoar, coar, ncurvs, curves, cocurv, + + userco, nuspnt ) + + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'Debug information from msho2d' + write(irefwr,*) 'Nodenumbers and coordinates' + do i=1, npoint + write(irefwr,*) i,'x = ',coor(1,i),'y = ',coor(2,i) + end do + write(irefwr,*) 'Boundary pieces' + write(irefwr,*) 'End boundary pieces' + end if + if ( ierror/=0 ) goto 1000 + +! --- Set accuracy + + eps = 10 * epsmac + xn = 0d0 + yn = 0d0 + +! --- Check whether each line in KBOUND is connected +! and determine for each point a coarseness-value +! (this check concerns the outer boundary and eventually holes +! as given bij bcord. Internal lines are treated later) + + if ( debug ) then + write(irefwr,*) 'MSHO2D array coar contains',ncoar,'points' + write(irefwr,*) 'these points are internal in surf',isurnr + do i=1, ncoar + write(irefwr,*) i,'crds',( coar(i1,i),i1=1,3) + end do + write(irefwr,*) 'end points array coar for surf',isurnr + end if + +! --- Compute the coarsenesses: + + call msho01 ( kbound, nbound, itri, kstapl, chelp, coor, + + npoint, coarsemin, coarsemax, coar, ncoar ) + if ( ierror/=0 ) goto 1000 + +! --- Check that edges in array kbound do not intersect each other + + call mshcurvinters2 ( kbound, nbound, coor, isurnr ) + if ( ierror/=0 ) goto 1000 + +! --- Place boundary elements in kstapl: + + kstap = nbound + +! --- Run through all pieces: + + do i = 1, 2*nbound + kstapl(i) = kbound(i) + end do + +! --- Set number of boundary points before internal lines are added + + nipnt = npoint + +! --- Eventually print contents kstapl: + + if ( debug ) then + write(irefwr,*) 'Array kstapl' + do i = 1, kstap + write(irefwr,*) 'Piece',i,':',kstapl(2*i-1),'-',kstapl(2*i) + end do + end if + +! --- Internal lines? + + if ( ncurvs>0 ) then + +! --- Place points of extra internal lines in kstapl and check +! the boundaries again (was already checked): + + call msho36 ( coor, npoint, istep, ncurvs, curves, cocurv, + + kstapl, kstap, kbndpt, nbndpt, coarsemin, + + extquanodes, chelp ) + if ( debug ) then + +! --- Give computed coarsenesses extra nodes due to internal +! lines + + do i=nipnt+1, npoint + write(irefwr,*) 'Node',i,'coarseness',chelp(i) + end do + end if + +! --- Check for intersections: + + call mshcurvinters2 ( kstapl, kstap, coor, isurnr ) + if ( ierror/=0 ) then + write(irefwr,*) + + 'Intersection(s) found due to internal lines. + + Error! Please check your input' + goto 1000 + end if + +! --- Eventually print kstapl again: + + if ( debug ) then + write(irefwr,*) 'Start MSHO2D with ',npoint,' points' + do i=1, npoint + write(irefwr,*) i,'crd-s',(coor(ierror,i),ierror=1,2) + end do + write(irefwr,*) 'Check! ok? Check kstapl yourself ' + write(irefwr,*) 'Array kstapl, kstap = ',kstap + do i=1, kstap + write(irefwr,*) i,kstapl(2*i-1),kstapl(2*i) + end do + end if + ierror = 0 + end if + +! --- Place all boundary pieces in new array kinbnd, +! determine length (use all kstapl pieces) and allocate: + + lenbnd = 2 * kstap + +! --- Kinbnd has to be kept for later use, allocate: + + allocate ( kinbnd ( lenbnd ) ) + +! --- Fill array: + + do i = 1, lenbnd + kinbnd(i) = kstapl(i) + end do + +! --- Eventually print array kinbnd: + + if ( debug ) then + write(irefwr,*) 'array kinbnd' + write(irefwr,*) (kinbnd(i),i=1,lenbnd) + write(irefwr,*) 'end array kinbnd' + end if + +! --- The minimum and maximum coarseness at the boundary is used to define +! the multiplication factor + + imultiply = max(1,nint(log10(coarsemax/coarsemin))) + if ( debug ) + + write(irefwr,*) 'coarsemin, coarsemax, imultiply ', + + coarsemin, coarsemax, imultiply + if ( ierror/=0 ) goto 1000 + +! --- Determine extreme coordinate-values for this surface + + call msho04 ( coor, npoint, xminloc, xmaxloc, yminloc, ymaxloc ) + if ( ierror/=0 ) goto 1000 + +! --- Determine max and min distance for total area +! ( First set nodes internal curves etc to zero) + + call msho05 ( chelp, nipnt, dismin, dismax ) + + if ( ierror/=0 ) goto 1000 + +! --- Determine global frame +! Determine number of reference quadrilaterals for this frame +! Use mean value for coarse frame: + + dism = (dismax + 2 * dismin) / 3d0 + +! --- Compute number of "boxes": + + nx = int( (xmaxloc-xminloc) / (0.9998 * dism) ) + 1 + ny = int( (ymaxloc-yminloc) / (0.9998 * dism) ) + 1 + +! --- Number of quadrilaterals + + ncube = nx * ny + + if ( debug ) + + write(irefwr,*) 'nx, ny, ncube, dism',nx,ny,ncube,dism + +! --- Allocate space for arrays jcube and cube: + + allocate( jcube( ncube ) ) + allocate( cube( ncube ) ) + +! --- Determine for each centre a dis value + + xstart = ( xmaxloc + xminloc - (nx)*dism ) / 2d0 + ystart = ( ymaxloc + yminloc - (ny)*dism ) / 2d0 + +! --- Place startvalues a little "upwards": + + xstart = xstart + dism/12d0 + ystart = ystart + dism/12d0 + + if ( debug ) then + write(irefwr,*) 'MSHO2D:' + write(irefwr,*) 'xminloc =',xminloc,' xmaxloc =',xmaxloc + write(irefwr,*) 'yminloc =',yminloc,' ymaxloc =',ymaxloc + write(irefwr,*) 'x en y start in cube 1',xstart,ystart + write(irefwr,*) 'x last cube is ',xstart+nx*dism + write(irefwr,*) 'y last cube is ',ystart+ny*dism + write(irefwr,*) 'dismin = ',dismin,' dismax = ',dismax + end if + +! --- Determine coarseness for each quadrilateral + + if ( debug ) + + write(irefwr,*) 'Determine coarseness for surf ',isurnr + + call msho06 ( npoint, coor, dism, xstart, ystart, nx, ny, + + icube, chelp, cube, jcube, kbound, nbound, + + coar, ncoar, ncurvs, curves, cocurv ) + +! --- Check all mutual coarsenesses: userpoint, internal_points and +! internal_curves + + if ( jcoars==1 ) then + maxratio = coaval( nuspnt + 2 ) + else + maxratio = 0 + end if + +! --- Check coarseness ratio's only in 2D problems and only if user +! has submitted a value (i.e. maxratio is not zero!) + + if ( ndim==2 .and. maxratio>1d0 ) then + +! --- Check submitted coarsenesses of user: + + call msho38 ( npoint, coor , dism , xstart, ystart, + + kbndpt, nbndpt, numcrvboun , boundary, + + nbound, nholes, nx , ny , icube , + + chelp , cube , jcube , kstapl, kstap , + + ncurvs, curves, cocurv , isurnr, userco, + + nuspnt, coaval, tran ) + end if + + if ( ierror/=0 ) goto 1000 + +! --- Compute reference area value for each quadrilateral + + deallocate( chelp ) + +! --- Next allocate and use array chelp for area of blocks: + + allocate( chelp ( ncube ) ) + + call msho21 ( cube, ncube, chelp ) + + if ( ierror/=0 ) goto 1000 + +! --- Set number of old (fixed!) points +! (Now nodes on internal lines are not excluded) + + nipnt = npoint + +! --- Repositioning + + nrepos = 10 * npunt + 20 + +! --- Clear array itri + + do i = 1, npunt + itri(i) = 0 + end do + +! --- Fill array itri + + do i = 1, 2*kstap + ipoint = kstapl(i) + itri(ipoint) = itri(ipoint) + 1 + end do + +! --- Eventually check array kstapl: + + nelem = 0 + nelemi = 0 + +! --- First step: check whether there are special points that should be +! treated first. If so fill elements. + + coarmin = coarsemin + + if ( ncoar>0 ) then + +! --- Place special nodes and fill elements: + + call msho35 ( npoint, coor, xstart, ystart, dism, + + coar, ncoar, icube, nx, kmeshc, nelem, + + kstapl, kstap, itri, isurnr, userpoints, + + kbndpt, nbndpt ) + +! --- Adjust number of initial ("fixed") points +! (Make choice: only the point itself, or also +! the surrounding points) +! --- In case of also the surrounding points +! nipnt = nipnt + 7 * ncoar +! --- Choice: only the point itself: + + nipnt = nipnt + 7 * ncoar + nelemi = nelem + + do i=1, ncoar + if ( coar(3,i)npunt ) then + if ( debug ) write(irefwr,*) 'Error while kstap = ',kstap + call errint ( npunt , 1 ) + call errint ( npoint, 2 ) + call errsub ( 900, 2, 0, 0 ) + end if + + if ( nelem>nkmeshc ) then + write(irefwr,*) 'Estimated length of element array too small' + write(irefwr,*) 'Number of elements found is more than the' + write(irefwr,*) 'used estimate',nkmeshc,'in SEPRAN.' + write(irefwr,*) 'Most probable cause: too much difference' + write(irefwr,*) 'in the coarseness along the boundary.' + write(irefwr,*) 'Try to divide your original region in' + write(irefwr,*) 'smaller sections with less coarseness variety' + write(irefwr,*) 'or check and change the local coarsenesses in' + write(irefwr,*) 'the userpoints of the original region.' + write(irefwr,*) 'If nothing helps: Please inform SEPRA' + call errsub ( 901, 0, 0, 0 ) + end if + + if ( ierror/=0 ) goto 1000 + +! --- Here follow helpstatements for debugging, normally these statements +! are skipped, using debug = .false.: + + debug = .false. + +! --- debug = .false. + + if ( debug .and. nochan==0 .and. nelem>0 ) then + i1 = kmeshc(1,nelem) + i2 = kmeshc(2,nelem) + i3 = kmeshc(3,nelem) + call msho19( coor, i1, i2, i3, surf1 ) + write(irefwr,*) 'element',nelem,' - ',i1,i2,i3 + if ( 0>1 ) then + do i=1, kstap + i1 = kstapl(2*i-1) + i2 = kstapl(2*i) + write(irefwr,*) 'Stuk',i1,i2 + end do + write(irefwr,*) 'coordinates' + do i=1,kstap + i1 = kstapl(2*i-1) + xm = coor(1,i1) + ym = coor(2,i1) + write(irefwr,*) i1,xm,ym + end do + write(irefwr,*) 'End of boundary' + end if + end if + + if ( nochan==0 .and. nelem==-3 ) then + write(irefwr,*) 'elem',nelem,'nodes',(kmeshc(i,nelem),i=1,3) + i1 = kmeshc(1,nelem) + i2 = kmeshc(2,nelem) + i3 = kmeshc(3,nelem) + call msho19( coor, i1, i2, i3, surf1 ) + write(irefwr,*) 'surface of element = ',surf1 + if ( surf1<10*epsmac ) then + write(irefwr,*) 'Results, kstap =',kstap + do i=1, npoint + xm = coor(1,i) + ym = coor(2,i) + write(irefwr,'(i6,(2f10.5))' ) i,xm,ym + end do + write(irefwr,*) 'Elements' + do i=1,nelem + i1 = kmeshc(1,i) + i2 = kmeshc(2,i) + i3 = kmeshc(3,i) + write(irefwr,'(4i5)') i,i1,i2,i3 + end do + write(irefwr,*) 'the end ' + go to 950 + end if + end if + debug = .false. + + iperm = 0 + +! --- Statements to indicate at which stage the subdivision is + + if ( debug .and. (nelem-1000*(nelem/1000))==0.and.nochan==0 ) then + write(irefwr,*) 'nelem = ',nelem + write(irefwr,*) 'kstap = ',kstap + end if + + if ( debug .and. nelem>100 ) then + +! --- Check kstapl + + write(irefwr,*) 'Check kstapl, nelem =',nelem,'kstap',kstap + call mshcurvinters2 ( kstapl, kstap, coor, isurnr ) + if ( ierror/=0 ) then + write(irefwr,*) + + 'Intersection, error! nelem = ',nelem + goto 1000 + end if + end if + + if ( debug .and. (nelem-1000*(nelem/1000))==0.and.nochan==0) then + write(irefwr,*) 'Control: nelem = ',nelem + +! --- Check whether all elements are given right and adjust array kstapl + + write(irefwr,*) 'Check via msho08 ' + call msho08 ( kstapl, kstap, coor, xstart, dismin, holeinfo, + + nholes, .true. ) + if ( ierror/=0 ) goto 1000 + write(irefwr,*) 'No error during check for nelem = ',nelem + call msho40 ( coor, kmeshc, npoint, nelem, iperm ) + end if + + if ( debug .and. nochan>0 ) then + write(irefwr,*) 'nelem = ',nelem,' nochan = ',nochan + write(irefwr,*) 'no element for',i1,'- ',i2 + end if + if ( debug .and. isurnr==-15 ) then + write(irefwr,*) 'surface number is',isurnr + write(irefwr,*) 'nelem = ',nelem,'kstap = ',kstap + if ( nochan==0 .and. nelem>0 ) then + write(irefwr,*) (kmeshc(i,nelem),i=1,3) + end if + end if + + if ( debug .and. nochan==0 .and. nelem>0 ) then + +! --- Print all elements one after one + + write(irefwr,*) 'Element',nelem,(kmeshc(i,nelem),i=1,3) + end if + + debug = .false. + +! --- Determine value for first group of boundary pieces to be considered: + + if ( nochan=idebug ) then + write(irefwr,*) 'extra check, kstap, npoint, icount ', + + kstap, npoint , icount + + call msho08 ( kstapl, kstap, coor, xstart, dismin, + + holeinfo, nholes, .true. ) + +! --- The next statements can be used if the process "hangs" + + write(irefwr,*) 'kstap, nochan,nelem ', kstap, nochan,nelem + end if + + if ( debug .and. nelem==-20000 ) then + write(irefwr,*) 'nelem = ',nelem,' checks' + call mshchkstapl ( kstapl, kstap, 'geval nelem' ) + write(irefwr,*) 'na mshchkstapl ierror =',ierror + call mshcurvinters2 ( kstapl, kstap, coor, isurnr ) + write(irefwr,*) 'na mshcurvinters2, ierror =',ierror + write(irefwr,*) 'nog ok?' + end if + + if ( debug ) then + +! --- Debug information + + end if + + debug = .false. + +! --- Check for smallest element: + + if ( ichan>0 ) call msho25 ( kstapl, ichan, coor ) + + angle = -0.1d0 + +! --- Remark: factor determines the number of elements +! Decreasing factor to for example 0.8 gives a much smoother mesh, +! but also a lot of extra points and elements + + factor = 1d0 + +! --- Change values in case of no convergence + + if ( nochan>10 .or. nochan>kstap ) then + angle = -0.7d0 + factor = 0.6d0 + end if + + if ( nochan >2 * kstap ) then + angle = -0.95d0 + factor = 0.50d0 + end if + +! --- If no convergence possible stop + + if ( nochan>3*kstap ) then + !write(irefwr,*) 'nochan =',nochan,' and kstap =',kstap + +! --- nochan too large + + if ( debug .or. 1>0 ) then + write(irefwr,*) 'Error 902, see information' + + do i=1, kstap + write(irefwr,*) kstapl(2*i-1),kstapl(2*i) + end do + do i=1, kstap + ja = kstapl(2*i-1) + write(*,*) 'P',ja,'=',coor(1,ja),coor(2,ja) + end do + write(irefwr,*) 'npoint = ',npoint + write(irefwr,*) 'Enough info?' + end if + + call errint ( nochan, 1 ) + call errint ( 3*kstap, 2 ) + call errint ( kstap, 3 ) + call errsub ( 902, 3, 0, 0 ) + + end if + if ( ierror/=0 ) goto 1000 + +! --- Check for ready + + if ( kstap==0 ) goto 500 + +! --- Transform in triangles, run through kstapl + + i1 = kstapl(1) + i2 = kstapl(2) + +! --- Change array itri + + itri(i1) = itri(i1) - 1 + itri(i2) = itri(i2) - 1 + +! --- First check whether triangle can be formed with other +! boundary lines, compute nodes and angles + + call msho12 ( coor, kstapl, kstap, i1, i2, iex1, iex2, + + angle1, angle2 ) + +! --- In emergency case: + + if ( nochan>kstap .and. 0>1 ) then + +! --- Try shortcut, compute surfaces: + + call msho19( coor, iex1, i1, i2, surf1 ) + call msho19( coor, i1, i2, iex2, surf2 ) + + write(irefwr,*) 'Shortcut, Emergency used:' + if ( surf1>0 .and. surf1>surf2 ) then + call msho10( kmeshc, nelem, i1, i2, iex1, + + kstapl, kstap, itri ) + write(irefwr,*) i1,i2,iex1 + nochan = 0 + + goto 300 + + else if ( surf2>0 .and. surf2>surf1 ) then + + call msho10( kmeshc, nelem, i1, i2, iex2, + + kstapl, kstap, itri ) + write(irefwr,*) i1,i2,iex2 + nochan = 0 + + goto 300 + + end if + end if + +! --- Check for errors + + if ( ierror/=0 ) goto 1000 + + ja = 0 + + if ( nochan>kstap .and. kstap>4 ) then + +! --- Combination of difficult triangles ? + + call msho12( coor, kstapl, kstap, iex1, i1, j1, j2, e1, e2 ) + if ( j1==iex2 ) ja = 1 + end if + if ( ierror/=0 ) goto 1000 + + if ( kstap==4 .or. ja==1 ) then + +! --- Special situation + + call msho19( coor, iex1, i1, i2, surf1 ) + call msho19( coor, i2, iex2, iex1, surf2 ) + + if ( surf1<0 .or. surf2<0 ) then + +! --- Difficult situation, first next triangle + + call msho19( coor, i1, i2, iex2, surf1 ) + if ( surf1>0 ) then + call msho10( kmeshc, nelem, i1, i2, iex2, kstapl, + + kstap, itri ) + nochan = 0 + goto 300 + end if + end if + end if + if ( ierror/=0 ) goto 1000 + + if ( iex1==iex2 ) then + +! --- Consider triangle i1 - i2 - iex1 = iex2, compute area + + call msho19( coor, i1, i2, iex1, surf ) + + iperm = 0 + if ( inside==1 ) + + call msho28( coor, i1, i2, iex1, xn, yn, npoint, + + itri, iperm ) + + if ( surf>=0 .and. iperm==0 ) then + + call msho10( kmeshc, nelem, i1, i2, iex1, + + kstapl, kstap, itri ) + nochan = 0 + + goto 300 + + end if + + if ( surf<=0 .and. kstap==3 ) then + +! --- Error: may be that later on repositioning solves this problem: + + write(irefwr,*) 'Emergency: Temporary bad element created' + write(irefwr,*) 'element has nodes' + write(irefwr,*) i1,' - ',i2,' - ',iex1 + call msho10( kmeshc, nelem, i1, i2, iex1, + + kstapl, kstap, itri ) + nochan = 0 + + goto 300 + + end if + + end if + +! --- Check for angles not greater than 180 degrees and determine +! which points are potential for new triangles + + call msho19( coor, i1, i2, iex1, surf1 ) + if ( ierror/=0 ) goto 1000 + + if ( surf1angle .and. angle2>=angle1 ) then + + call msho11 ( i1, iex1, iex2, coor, angleh ) + + if ( angleh<-0.5 ) then + +! --- Try i1 - i2 - iex1 + + ja = 1 + +! --- Adjust computation (surface is always computed) + + call msho19 ( coor, i2, iex2, iex1, surf ) + if ( surf<100 * eps ) ja = 0 + +! --- Check if none of the boundary nodes is in the new triangle: + + iperm = 0 + if ( ja==1 ) + + call msho28 ( coor, i1, i2, iex1, xn, yn, npoint, + + itri, iperm ) + + if ( ja==1 .and. iperm==0 ) then + +! --- Check whether i2 - iex1 is permitted + + call msho24 ( kstapl, kstap, coor, i2, iex1, icheck ) + + if ( icheck==0 ) then + + call msho10( kmeshc, nelem, i1, i2, iex1, kstapl, + + kstap, itri ) + nochan = 0 + + goto 300 + + end if + + else + + surf1 = rinfin + + end if + + else ! (angleh>angle ) + +! --- Try i1 - i2 - iex2 + + ja = 1 + +! --- Adjust computation (surface is always computed) + + call msho19 ( coor, i1, i2, iex2, surf ) + if ( surf<100 * eps ) ja = 0 + +! --- Check if none of the boundary nodes in the new triangle: + + iperm = 0 + if ( ja==1 ) + + call msho28 ( coor, i1, i2, iex2, xn, yn, npoint, + + itri, iperm ) + + if ( ja==1 .and. iperm==0 ) then + +! --- Check whether i1 - iex2 is permitted + + call msho24 ( kstapl, kstap, coor, i1, iex2, icheck ) + + if ( icheck==0 ) then + + call msho10( kmeshc, nelem, i1, i2, iex2, kstapl, + + kstap, itri ) + nochan = 0 + + goto 300 + + end if + + else + + surf2 = rinfin + + end if + + end if + + end if + + if ( ierror/=0 ) goto 1000 + + if ( surf1angle .and. angle1>=angle2 ) then + + call msho11 ( i2, iex2, iex1, coor, angleh ) + + if ( angleh<-0.5 ) then + +! --- Try i1 - i2 - iex2 + + ja = 1 + +! --- Adjust computation (surface is always computed) + + call msho19 ( coor, i1, iex2, iex1, surf ) + if ( surf<100 * eps ) ja = 0 + +! --- Check if none of the boundary nodes is in the new triangle: + + iperm = 0 + if ( ja==1 ) + + call msho28 ( coor, i1, i2, iex2, xn, yn, npoint, + + itri, iperm ) + + if ( ja==1 .and. iperm==0 ) then + +! --- Check whether i1 - iex2 is permitted + + call msho24 ( kstapl, kstap, coor, i1, iex2, icheck ) + + if ( icheck==0 ) then + call msho10( kmeshc, nelem, i1, i2, iex2, kstapl, + + kstap, itri ) + nochan = 0 + goto 300 + end if + else + surf2 = rinfin + end if + else ! (angleh>angle ) + +! --- Try i1 - i2 - iex1 + + ja = 1 + +! --- Adjust computation (surface is always computed) + + call msho19 ( coor, i1, i2, iex1, surf ) + if ( surf<100 * eps ) ja = 0 + +! --- Check if none of the boundary nodes is in the new triangle: + + iperm = 0 + if ( ja==1 ) + + call msho28 ( coor, i1, i2, iex1, xn, yn, npoint, + + itri, iperm ) + if ( ja==1 .and. iperm==0 ) then + +! --- Check whether i2 - iex1 is permitted + + call msho24 ( kstapl, kstap, coor, i2, iex1, icheck ) + + if ( icheck==0 ) then + call msho10( kmeshc, nelem, i1, i2, iex1, kstapl, + + kstap, itri ) + nochan = 0 + goto 300 + end if + else + surf1 = rinfin + end if + end if + end if + + if ( ierror/=0 ) goto 1000 + + if ( surf2 nx ) then + n1 = nx + end if + n2 = int ( (yn-ystart) / dism ) + if ( n2 < 0 ) then + n2 = 0 + else if ( n2 > ny - 1 ) then + n2 = ny - 1 + end if + nc = 1 + n1 + n2*nx + +! --- Find helpcoarseness + + cdis = cube(nc) + +! --- New guess using both coarsenesses: + coa = (disold + 2 * cdis)/3d0 + + xn = xm + coa * e1 + yn = ym + coa * e2 + +! --- Check whether new point belongs to volume + + ja = 0 + + call msho07( xn, yn, xstart, coor, kstapl, kstap, ja ) + + if ( ierror/=0 ) goto 1000 + +! --- Determine extra values for case that new point has to be placed + + if ( cdis > 1.2 * disold ) then + xnx = xm + coa * e1 + yny = ym + coa * e2 + else if ( cdis < 0.8 * disold ) then + xnx = xm + 0.7 * coa * e1 + yny = ym + 0.7 * coa * e2 + else + xnx = xm + 0.85 * coa * e1 + yny = ym + 0.85 * coa * e2 + end if + +! --- Check whether new point is allowed or is there a common +! point with another line + + call msho13( coor, i1, i2, kdrie, kstapl, kstap, xn, yn ) + +! --- Check for double crossinglines: + + if ( kdrie==-1 ) then + +! --- Double crossings: change array kstapl + + if ( debug ) then + write(irefwr,*) 'Check msho13: Double crossing: skip' + end if + call msho20(kstapl,kstap,itri) + nochan = nochan + 1 + goto 300 + end if + + if ( ierror/=0 ) goto 1000 + +! --- Check for impossible situation + + if ( ja==0 .and. kdrie==0 ) then + +! --- Rearrange, impossible + + xn = xn - dismin * 1d-3 + dismin * 1d-4 + yn = yn + dismin * 1d-3 + dismin * 1d-4 + + ja = 0 + call msho07( xn, yn, xstart, coor, kstapl, kstap, ja ) + + call msho13( coor, i1, i2, kdrie, kstapl, kstap, xn, yn ) + + if ( ja==0 .and. kdrie==0 .or. kdrie==-1 ) then + +! --- Really impossible, change + + if ( debug ) then + write(irefwr,*) 'Check msho13' + write(irefwr,*) 'Really impossible situation, skip' + write(irefwr,*) 'If your input is OK inform SEPRA' + end if + call msho20( kstapl, kstap, itri ) + nochan = nochan + 1 + goto 300 + end if + end if + if ( ierror/=0 ) goto 1000 + +420 if ( kdrie>0 ) then + +! --- Common point with line kdrie + + ii1 = kstapl( 2*kdrie - 1 ) + ii2 = kstapl( 2*kdrie ) + +! --- Triangle with one of these (old) points +! ( Check whether points are allowed ) + + jpn = 0 + + if ( ii1==i2 .and. surf2eps ) then + call msho10(kmeshc,nelem,i1,i2,ii2,kstapl, + + kstap,itri) + nochan = 0 + goto 300 + else if ( icheck>0 ) then + kdrie = icheck + goto 420 + end if + + end if + + end if + + if ( ii2==i1 .and. surf1eps ) then + call msho10(kmeshc,nelem,i1,i2,ii1,kstapl, + + kstap,itri) + nochan = 0 + goto 300 + else if ( icheck>0 ) then + kdrie = icheck + goto 420 + end if + + end if + + end if + + if ( ierror/=0 ) then + if ( debug ) write(irefwr,*) 'Halfway ierror =',ierror + goto 1000 + end if + + if ( i2/=ii1 .and. i1/=ii2 ) then + +! --- Point ii1 ? + + dist1 = rinfin + + dx = xnx - coor( 1,ii1 ) + dy = yny - coor( 2,ii1 ) + + dist1 = sqrt( dx*dx + dy*dy ) + jpn = ii1 + +! --- Point ii2 ? + + dx = xnx - coor( 1,ii2 ) + dy = yny - coor( 2,ii2 ) + + dist = sqrt( dx*dx + dy*dy ) + + if ( dist0 ) then + call msho19(coor,i1,i2,jpn,surf) + valare = ( chelp(icube(i1))+chelp(icube(i2)) )/2d0 + if ( nochanrinfin/2.) jpn = 0 + if ( jpn==iex2.and.surf2>rinfin/2.) jpn = 0 + end if + + iperm = 0 + if ( jpn>0 ) + + call msho28(coor,i1,i2,jpn,xn,yn,npoint,itri,iperm) + if ( iperm==1 ) jpn = 0 + + if ( jpn>0 ) then + call msho10(kmeshc,nelem,i1,i2,jpn,kstapl, + + kstap,itri) + nochan = 0 + + else + +! --- Change array kstapl + + call msho20(kstapl,kstap,itri) + nochan = nochan + 1 + end if + else + +! --- New point not to near to old point ? Run through array itri + + jpn = 0 + dista = 2. * coa + + call msho14(coor,jpn,npoint,itri,i1,i2,xnx,yny,dista) + + if ( dista>0.55d0 * coa ) jpn = 0 + + iperm = 0 + if ( jpn/=0 .and. inside==1 ) + + call msho28(coor,i1,i2,jpn,xn,yn,npoint,itri,iperm) + if ( iperm==1 ) then + call msho20(kstapl,kstap,itri) + nochan = nochan + 1 + goto 300 + end if + + if ( jpn/=0 .and. jpn/=iex1 .and. + + ipotn1==0 ) then + + call msho19(coor,iex1,i1,jpn,surf) + + valare = chelp(icube(i1)) + + if ( surf<0.15d0 * valare ) then + call msho20(kstapl,kstap,itri) + nochan = nochan + 1 + goto 300 + end if + + end if + + if ( jpn/=0 .and. jpn/=iex2 .and. + + ipotn2==0 ) then + + call msho19(coor,i2,iex2,jpn,surf) + + valare = chelp(icube(i2)) + + if ( surf<0.15d0 * valare ) then + call msho20(kstapl,kstap,itri) + nochan = nochan + 1 + goto 300 + end if + + end if + + inear = 0 + no = 0 + + if ( dista<0.55d0*coa ) then + inear = 1 + call msho24(kstapl,kstap,coor,i1,jpn,icheck) + if ( icheck/=0 ) no = 1 + call msho24(kstapl,kstap,coor,i2,jpn,icheck) + if ( icheck/=0 ) no = 1 + end if + + if ( jpn==0 ) then + ja = 0 + else + call msho19(coor,i1,i2,jpn,surf) + valare = ( chelp(icube(i1))+chelp(icube(i2)) )/2. + if ( nochan nx ) then + n1 = nx + end if + n2 = int ( (yny-ystart) / dism ) + if ( n2 < 0 ) then + n2 = 0 + else if ( n2 > ny - 1 ) then + n2 = ny - 1 + end if + + nc = 1 + n1 + n2*nx + + if ( nc>(nx*ny) ) then + write(irefwr,*) 'Error in msho2d' + write(irefwr,*) 'Please inform SEPRA' + write(irefwr,*) 'Execution NOT terminated' !AvD: do not stop +!AvD call instop + end if + + icube(npoint) = nc + + else + +! --- No solution found: change array kstapl + + call msho20(kstapl,kstap,itri) + nochan = nochan + 1 + end if + + end if + + if ( ierror/=0 ) then + if ( debug ) write(irefwr,*) 'Error: End of normal loop' + goto 1000 + end if + +! --- Array kstapl empty ? + + if ( kstap>0 ) goto 300 + +! --- Check itri (all entries of this array should by now be zero) + +500 itot = 0 + + if ( debug ) then + write(irefwr,*) 'Temporary output after label 500' + write(irefwr,*) 'nelem = ',nelem,'kstap = ',kstap + if ( nelem>0 ) then + write(irefwr,*) 'Listing of',nelem,'elements' + do i=1, nelem + write(irefwr,*) i,(kmeshc(i1,i),i1=1,3) + end do + write(irefwr,*) 'Output meshgeneration nodes' + write(irefwr,*) 'End msho2d with ',npoint,' nodes' + do i=1, npoint + write(irefwr,*) i,(coor(ja,i),ja=1,2) + end do + + write(irefwr,*) 'Array kbndpt: ( nbndpt = ',nbndpt,')' + write(irefwr,*) (kbndpt(i),i=1,nbndpt) + write(irefwr,*) 'Contents OK?' + end if + end if + + do i = 1, npoint + itot = itot + abs(itri(i)) + end do + + if ( itot/=0 ) then + write(irefwr,*) 'Error in connections array' + call errsub ( 903, 0, 0, 0 ) + end if + + if ( npoint>npunt ) then + call errint ( npoint, 1 ) + call errint ( npunt, 2 ) + call errsub ( 900, 2, 0, 0 ) + end if + + if ( nelem>nkmeshc ) then + call errsub ( 901, 0, 0, 0 ) + end if + if ( ierror/=0 ) goto 1000 + +! --- First solution found, save before extra actions: + + if ( nherha==0 ) then + +! --- Allocate space for helparrays coortmp and meshtmp: + +! --- Length coortmp is npoint: + + npndef = npoint + int(5 + npoint/10) + npntmp = npoint + +! --- Length meshtmp is nelem: + + neldef = nelem + int(5 + nelem/10) + neltmp = nelem + + allocate( coortmp( 2, npndef ) ) + allocate( meshtmp( 3, neldef ) ) + +! --- Fill helparrays temporary: +! --- Coordinates: + + do i = 1, npoint + coortmp(1,i) = coor(1,i) + coortmp(2,i) = coor(2,i) + end do + +! --- Elements: + do i = 1, nelem + meshtmp(1,i) = kmeshc(1,i) + meshtmp(2,i) = kmeshc(2,i) + meshtmp(3,i) = kmeshc(3,i) + end do + +! --- Determine characteristic ratiovalue for comparison reasons in +! the next steps: + + ratiop = rinfin + + do ielem = 1, nelem + i1 = kmeshc (1,ielem) + i2 = kmeshc (2,ielem) + i3 = kmeshc (3,ielem) + call msho33 ( coor, verh, i1, i2, i3 ) + call msho19 ( coor, i1, i2, i3, surf ) + if ( surf<0 ) then + verh = -verh + if ( debug ) then + write(irefwr,*) 'nherha = ',nherha + write(irefwr,*) 'verh = ',verh + write(irefwr,*) 'Triangle',ielem,' - ',i1,i2,i3 + end if + end if + ratiop = min( verh, ratiop ) + + end do ! ielem = 1, nelem + + if ( debug ) then + write(irefwr,*) 'End first subdivision, ratio = ',ratiop + end if + end if + +! --- Determine number of neighbours of points + +540 leng = nrepos + + do ih = 1, 3 + + call msho16(kmeshc,nelem,npoint,nipnt,itri,kstapl,leng) + +! --- Check length used + + if ( leng>nrepos ) then + call errsub ( 903, 0, 0, 0 ) + goto 1000 + end if + +! --- Remove internal points with three or four neighbours + + icancel = 1 + + do while ( icancel>0 ) + + icancel = 0 + + call msho29( kmeshc, nelem, npoint, itri, kstapl, nipnt, + + coor, icancel ) + + if ( ierror/=0 ) then + if ( debug ) write(irefwr,*) 'msho29 ierror =',ierror + goto 1000 + end if + +! --- Rearrange arrays COOR and KELEM + + do i = 1, npoint + itri(i) = 0 + end do + + do i = 1, nelem + i1 = kmeshc( 1,i ) + i2 = kmeshc( 2,i ) + i3 = kmeshc( 3,i ) + + itri(i1) = 1 + itri(i2) = 1 + itri(i3) = 1 + end do + + itot = 0 + + do i = 1, npoint + x = coor( 1,i ) + y = coor( 2,i ) + + if ( itri(i)==1 .or. i<=nipnt ) then + itot = itot + 1 + coor( 1,itot ) = x + coor( 2,itot ) = y + itri(i) = itot + end if + + end do + + ja = npoint - itot + npoint = itot + +! --- Renumber KELEM + + do i = 1, nelem + + i1 = kmeshc( 1,i ) + i2 = kmeshc( 2,i ) + i3 = kmeshc( 3,i ) + + kmeshc( 1,i ) = itri(i1) + kmeshc( 2,i ) = itri(i2) + kmeshc( 3,i ) = itri(i3) + end do + + end do ! while loop + + end do + +! --- Temporary for checking: +! if ( kstap==0 ) goto 900 + +! --- Check angles + + ifill = 0 + + do ielem = nelemi+1, nelem + + i1 = kmeshc( 1,ielem ) + i2 = kmeshc( 2,ielem ) + i3 = kmeshc( 3,ielem ) + +! --- Check all inside "diagonals": +! Start computing the angles of each triangle + + call msho03(i1,i2,coor,adis) + call msho03(i2,i3,coor,bdis) + call msho03(i3,i1,coor,cdis) + +! --- Check angles + + call msho22( adis, bdis, cdis, icase ) + + if ( icase>0 ) then + +! --- Triangle ielem has an angle that is larger than 90 degrees, +! try to change the diagonal + + ma = 1 + + jelem = ielem + + if ( icase==1 ) then + +! --- common line is i2 - i3 + + call msho26(kmeshc,nelem,i2,i3,jelem,i4) + +! --- Check whether i2-i3 is internal boundary: + + ja = 0 + call msho42( kinbnd,lenbnd, i2, i3, ja ) + if ( ja==1 ) i4 = 0 + if ( i4>0 .and. jelem/=ielem ) then + +! --- consider i1 - i2 - i3 - i4 + + j1 = i1 + call msho27(coor,i1,i2,i3,i4) + if ( j1/=i1 ) ifill = 1 + + j1 = i1 + j2 = i2 + j3 = i3 + j4 = i4 + else + ma = 0 + end if + else if ( icase==2 ) then + +! --- common line is i3 - i1 + + call msho26(kmeshc,nelem,i3,i1,jelem,i4) + +! --- Check whether i3-i1 is internal boundary: + + ja = 0 + call msho42( kinbnd, lenbnd, i3, i1, ja ) + if ( ja==1 ) i4 = 0 + if ( i4>0 .and. jelem/=ielem ) then + +! --- consider i2 - i3 - i1 - i4 + + j2 = i2 + call msho27(coor,i2,i3,i1,i4) + if ( j2/=i2 ) ifill = 1 + + j1 = i2 + j2 = i3 + j3 = i1 + j4 = i4 + else + ma = 0 + end if + else if ( icase==3 ) then + +! --- common line is i1 - i2 + + call msho26(kmeshc,nelem,i1,i2,jelem,i4) + +! --- Check whether i1-i2 is internal boundary: + + ja = 0 + call msho42( kinbnd, lenbnd, i1, i2, ja ) + if ( ja==1 ) i4 = 0 + if ( i4>0 .and. jelem/=ielem ) then + +! --- consider i3 - i1 - i2 - i4 + + j3 = i3 + call msho27(coor,i3,i1,i2,i4) + if ( j3/=i3 ) ifill = 1 + + j1 = i3 + j2 = i1 + j3 = i2 + j4 = i4 + else + ma = 0 + end if + end if + +! --- Refill element array + + if ( ma>0 ) then + kmeshc( 1,ielem ) = j1 + kmeshc( 2,ielem ) = j2 + kmeshc( 3,ielem ) = j3 + + kmeshc( 1,jelem ) = j2 + kmeshc( 2,jelem ) = j4 + kmeshc( 3,jelem ) = j3 + end if + end if + end do + + if ( ierror/=0 ) then + write(irefwr,*) 'Just past angle checking, ierror =',ierror + goto 1000 + end if + +! --- Check this mesh (all diagonals should are optimal now) + + dismin = rinfin + + do ielem = 1, nelem + i1 = kmeshc (1,ielem) + i2 = kmeshc (2,ielem) + i3 = kmeshc (3,ielem) + call msho33 ( coor, verh, i1, i2, i3 ) + call msho19 ( coor, i1, i2, i3, surf ) + if ( surf<0 ) then + verh = -verh + if ( debug ) then + write(irefwr,*) 'nherha = ',nherha + write(irefwr,*) 'verh = ',verh + write(irefwr,*) 'Triangle',ielem,' - ',i1,i2,i3 + end if + end if + dismin = min( verh, dismin ) + end do ! ielem = 1, nelem + +! --- Check whether this mesh is better: + + if ( dismin>ratiop ) then + +! --- Better mesh: + + if ( debug ) then + write(irefwr,*) 'ratio new mesh (diagonals) ',dismin + write(irefwr,*) 'ratio',dismin,'>old ratio',ratiop + write(irefwr,*) 'safe the better one' + end if + +! --- Use "best" mesh: +! Set equal to new number of points: + + npntmp = npoint + + if ( npntmp>npndef ) then + write(irefwr,*) 'Error in allocation temporary pointsarray' + write(irefwr,*) 'Please inform SEPRA' + write(irefwr,*) 'Execution stopped' + go to 1000 + end if + +! --- Coordinates: + + do i = 1, npoint + coortmp(1,i) = coor(1,i) + coortmp(2,i) = coor(2,i) + end do + +! --- Set number of elements: + + neltmp = nelem + if ( neltmp>neldef ) then + write(irefwr,*) 'Error in allocation temporary elemarray' + write(irefwr,*) 'Please inform SEPRA' + write(irefwr,*) 'Execution stopped' + go to 1000 + end if + +! --- Elements: + + do i = 1, nelem + meshtmp(1,i) = kmeshc(1,i) + meshtmp(2,i) = kmeshc(2,i) + meshtmp(3,i) = kmeshc(3,i) + end do + + ratiop = dismin + end if + + if ( debug .and. icount>=idebug ) then + write(irefwr,*) 'extra check, kstap, npoint, icount ', + + kstap, npoint , icount + call msho08 ( kstapl, kstap, coor, xstart, dismin, + + holeinfo, nholes, .true. ) + +! --- The next statements can be used if the process "hangs" + + write(irefwr,*) 'kstap, nochan,nelem ', kstap, nochan,nelem + end if + +! --- If convergence seems to be difficult and results are "acceptable" +! return + + if ( reposition .and. ( nherha>10 .and. ifill==0 ) .or. + + nherha>20 ) goto 900 + +! --- Repositioning + + nherha = nherha + 1 + leng = nrepos + + call msho16(kmeshc,nelem,npoint,nipnt,itri,kstapl,leng) + + if ( leng>nrepos ) then + write(irefwr,*) 'Just after msho16',leng,'>',nrepos + call errsub ( 903, 0, 0, 0 ) + goto 1000 + end if + + coa = dismin + + ! call msho18(kmeshc,nelem,coor,npoint,nipnt,itri,kstapl,coa) ! Perform a Laplacian repositioning of the nodes + + if ( debug .and. icount>=idebug ) then + jtimes = 1 + jtimes = 3 + jtimes = 0 + call msho08 ( kstapl, kstap, coor, xstart, dismin, + + holeinfo, nholes, .true. ) + +! --- The next statements can be used if the process "hangs" + + write(irefwr,*) 'kstap, nochan,nelem ', kstap, nochan,nelem + end if + +! --- Check result of Repositioning + + do i = nelemi+1, nelem + i1 = kmeshc( 1,i ) + i2 = kmeshc( 2,i ) + i3 = kmeshc( 3,i ) + +! --- Check only triangles that are fully inside: + + if ( i1>nipnt .and. i2>nipnt .and. i3>nipnt ) then + + call msho19(coor,i1,i2,i3,surf) + + valare = chelp(icube(i1))+chelp(icube(i2))+chelp(icube(i3)) + valare = valare / 3d0 + + if ( surf<0d0 .or. + + surf<0.1d0 * valare .and. nherha<50 .or. + + surf>1.0d1 * valare .and. nherha<50 ) then + +! --- Redivision for this triangle + + ielem = i + + call msho30( kmeshc, nelem, ielem, kstapl, kstap, npoint, + + itri , nelemi ) + +! --- Make a new division for this array kstapl + + if ( icount>=idebug ) then + + write(irefwr,*) 'nherha, leng ', nherha, leng + call msho08 ( kstapl, kstap, coor, xstart, dismin, + + holeinfo, nholes, .true. ) + +! --- The next statements can be used if the process "hangs" + + write(irefwr,*) 'kstap, nochan,nelem ', + + kstap, nochan,nelem + end if + + goto 300 + + end if + + end if + + end do + + if ( ierror/=0 ) then + if ( debug ) + + write(irefwr,*) 'Just before redivision, ierror =',ierror + goto 1000 + end if + +! --- No redivision needed, check again for points with four neighbours + + ja = 0 + + do i = nipnt+1,npoint + no = itri(i) - itri(i-1) + if ( no<5 ) ja = 1 + end do + + if ( debug ) write(irefwr,*) 'At the end of loop nherha = ',nherha + + if ( nherha<5 .or. ja==1 .or. ifill==1 ) goto 540 + +900 continue + +! --- Ready, no error, but check before leaving whether the temporary +! mesh as stored, is better by comparison of the ratio-values: + + dismin = rinfin + + do ielem = 1, nelem + + i1 = kmeshc(1,ielem) + i2 = kmeshc(2,ielem) + i3 = kmeshc(3,ielem) + call msho33 ( coor, verh, i1, i2, i3 ) + call msho19 ( coor, i1, i2, i3, surf ) + + if ( surf<0 ) verh = -verh + + dismin = min(verh,dismin) + + end do ! ielem = 1, nelem + +! --- Compare + + if ( debug ) then + write(irefwr,*) 'Check of last mesh' + write(irefwr,*) 'ratiop = ',ratiop + write(irefwr,*) 'dismin = ',dismin + write(irefwr,*) 'nherha = ',nherha + end if + + if ( dismin0 ) then + +! --- Information statements: + + write(irefwr,*) + + 'End msho2d: Check barycenters of',nelem,'elements' + iperm = 0 + call msho40 ( coor, kmeshc, npoint, nelem, iperm ) + write(irefwr,*) 'Ready with check, iperm = ',iperm + +! --- Compute total surface of all elements and check for negative +! values: + + surf = 0 + + do i = 1, nelem + i1 = kmeshc( 1,i ) + i2 = kmeshc( 2,i ) + i3 = kmeshc( 3,i ) + +! --- Check triangle and add surface: + + call msho19(coor,i1,i2,i3,surf1) + + if ( surf1<0 ) then + write(irefwr,*) 'error,surface',i1,i2,i3,'neg = ',surf1 + end if + + surf = surf + surf1 + + end do + + write(irefwr,*) 'Surface (all elements added) is ',surf + + write(irefwr,*) 'kstap = ',kstap + + if ( kstap>0 ) then + write(irefwr,*) 'kstap =',kstap,' end msho2d' + write(irefwr,*) (kstapl(i),i=1,2*kstap) + end if + + write(irefwr,*) 'Output meshgeneration elements and nodes' + write(irefwr,*) 'End msho2d with ',npoint,' nodes' + do i=1, npoint + write(irefwr,*) i,(coor(ja,i),ja=1,2) + end do + + write(irefwr,*) 'ok? ' + write(irefwr,*) 'End msho2d' + write(irefwr,*) 'Number of elements = ', nelem + write(irefwr,*) 'Contents array kbndpt, value nbndpt = ',nbndpt + write(irefwr,*) (kbndpt(i),i=1,nbndpt) + + end if + +! --- Check all triangles of this surface for the ratio-value: + + dismin = rinfin + ratiop = 0 + + do ielem = 1, nelem + + i1 = kmeshc(1,ielem) + i2 = kmeshc(2,ielem) + i3 = kmeshc(3,ielem) + call msho33 ( coor, verh, i1, i2, i3 ) + ratiop = ratiop + abs(verh) + + dismin = min(verh,dismin) + + end do ! ielem = 1, nelem + + if ( debug ) then + +! --- Compute mean value: + + ratiop = ratiop/nelem + write(irefwr,*) 'Smallest ratio in mesh =',dismin + write(irefwr,*) 'Mean ratio in mesh = ',ratiop + + end if + +! --- Check whether values have been changed and act accordingly: + + if ( maxratio>1d0 .and. dismin<0.15d0 ) then + +! --- Suggest new values for the coarsenesses of the userpoints + + write(irefwr,*) 'Bad-shaped elements found in surface',isurnr + write(irefwr,*) 'smallest ratiovalue = ',dismin + write(irefwr,*) 'Use eventually the following coarseness' + write(irefwr,*) 'values for the',nuspnt,'submitted userpoints' + do i=2, nuspnt+1 + write(irefwr,*) 'node',i-1,'coarseness',coaval(i) + end do + end if + +! --- Delete the temporary helparrays + +950 deallocate( userco ) + deallocate( coaval ) + deallocate( chelp ) + deallocate( cube ) + deallocate( icube ) + deallocate( itri ) + deallocate( jcube ) + deallocate( kstapl ) + + if ( neltmp>0 ) then + deallocate( coortmp ) + deallocate( meshtmp ) + end if + + if ( lenbnd>0 ) deallocate ( kinbnd ) + +! --- Close + +1000 call erclos( 'msho2d' ) + + end diff --git a/extern/sepran/msho30.for b/extern/sepran/msho30.for new file mode 100644 index 000000000..d29ab8a86 --- /dev/null +++ b/extern/sepran/msho30.for @@ -0,0 +1,266 @@ + subroutine msho30 ( kelem, nelem, ielem, kstapl, kstap, npoint, + + itri , nelmfix) +! ====================================================================== +! +! programmer Niek Praagman +! version 3.3 date 09-04-2009 use nelmfix i.s.o. nelemi +! version 3.2 date 18-03-2005 Extra parameter nelemi +! version 3.1 date 15-02-2005 Update +! version 3.0 date 11-01-2005 Remove nipnt +! version 2.1 date 14-08-2002 Consider Plaxis boundaries +! version 2.0 date 28-01-1994 Complete new version +! version 1.1 date 19-02-1993 New layout +! version 1.0 date 13-06-1989 +! +! copyright (c) 1989-2009 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Subroutine to refill arrays KSTAPL and ITRI after a Repositioning +! error +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! ********************************************************************** +! +! MODULES USED +! + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer kelem(3,*), nelem, ielem, kstapl(2,*), kstap, + + npoint, itri(*), nelmfix + +! ielem i element to be cancelled +! itri o indicator whether point i is in boundary or not +! kelem i/o New KMESH part c with respect to the surface elements +! All elements have the same number of nodes +! kstap o number of line segments in KSTAP +! kstapl o new array of boundary segments +! nelem i/o Number of elements +! nelmfix i Number of elements that is fixed +! npoint i Number of nodal points +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer i, ia, ib, ic, nextra, i1, i2, i3, j1, j2, jp, jtal, + + iaan, is + +! i counting variable +! i1 help node number +! i2 help node number +! i3 help node number +! ia node number of triangle to be considered +! iaan indicator whether segment has been cancelled or not +! ib node number of triangle to be considered +! ic node number of triangle to be considered +! is counting variable +! j1 segment node +! j2 segment node +! jp indicator whether element should be reconsidered +! or not +! jtal temporary number of segments in kstapl +! nextra number of elements which are not cancelled +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! none +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! determine the three node numbers of the triangle to be cancelled +! run through all elements +! if element has at least one node in common with triangle +! cancel element and fill the three segments in kstapl +! refill itri +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Determine the three node numbers of the triangle to be skipped + + ia = kelem( 1, ielem ) + ib = kelem( 2, ielem ) + ic = kelem( 3, ielem ) + +! --- Set parameters KSTAP and NEXTRA + + kstap = 0 + nextra = nelmfix + +! --- Run through all elements that have at least one point in common +! with the triangle + + do i = nelmfix + 1 , nelem + + i1 = kelem( 1, i ) + i2 = kelem( 2, i ) + i3 = kelem( 3, i ) + + jp = 0 + + if ( i1==ia .or. i1==ib .or. i1==ic ) jp = 1 + if ( i2==ia .or. i2==ib .or. i2==ic ) jp = 1 + if ( i3==ia .or. i3==ib .or. i3==ic ) jp = 1 + + if ( jp==1 ) then + +! --- add three line segments to kstapl +! start with i1 - i2 + + if ( i1<=-1 .and. i2<=-1 ) then + + kstap = kstap + 1 + kstapl( 1, kstap ) = i1 + kstapl( 2, kstap ) = i2 + + else + +! --- Check whether i1 - i2 already belongs to kstapl + + jtal = 0 + iaan = 0 + + do is = 1, kstap + j1 = kstapl( 1, is ) + j2 = kstapl( 2, is ) + if ( j1==i2 .and. j2==i1 ) then + +! --- do nothing, i.e. skip segment + + iaan = 1 + else + jtal = jtal + 1 + kstapl( 1, jtal ) = j1 + kstapl( 2, jtal ) = j2 + end if + end do + if ( iaan==0 ) then + +! --- add segment + + jtal = jtal + 1 + kstapl( 1, jtal ) = i1 + kstapl( 2, jtal ) = i2 + end if + kstap = jtal + end if + +! --- next check whether i2 - i3 already belongs to kstapl + + jtal = 0 + iaan = 0 + + do is = 1, kstap + j1 = kstapl( 1, is ) + j2 = kstapl( 2, is ) + if ( j1==i3 .and. j2==i2 ) then + +! --- do nothing, i.e. skip segment + + iaan = 1 + else + jtal = jtal + 1 + kstapl( 1, jtal ) = j1 + kstapl( 2, jtal ) = j2 + end if + end do + if ( iaan==0 ) then + +! --- add segment + + jtal = jtal + 1 + kstapl( 1, jtal ) = i2 + kstapl( 2, jtal ) = i3 + end if + kstap = jtal + +! --- finally check whether i3 - i1 already belongs to kstapl + + jtal = 0 + iaan = 0 + + do is = 1, kstap + j1 = kstapl( 1, is ) + j2 = kstapl( 2, is ) + if ( j1==i1 .and. j2==i3 ) then + +! --- do nothing, i.e. skip segment + + iaan = 1 + else + jtal = jtal + 1 + kstapl( 1, jtal ) = j1 + kstapl( 2, jtal ) = j2 + end if + end do + if ( iaan==0 ) then + +! --- add segment + + jtal = jtal + 1 + kstapl( 1, jtal ) = i3 + kstapl( 2, jtal ) = i1 + end if + kstap = jtal + + else + +! --- triangle is outside interesting area + + nextra = nextra + 1 + kelem( 1, nextra ) = i1 + kelem( 2, nextra ) = i2 + kelem( 3, nextra ) = i3 + end if + end do + nelem = nextra + +! --- Refill array ITRI + + do i = 1 , npoint + itri(i) = 0 + end do + + do i = 1 , kstap + + i1 = kstapl( 1, i ) + i2 = kstapl( 2, i ) + + itri(i1) = itri(i1) + 1 + itri(i2) = itri(i2) + 1 + + end do + + end diff --git a/extern/sepran/msho31.for b/extern/sepran/msho31.for new file mode 100644 index 000000000..54a470967 --- /dev/null +++ b/extern/sepran/msho31.for @@ -0,0 +1,413 @@ + subroutine msho31 ( coor, npoint, kelem, nelem, kbound, nbn, + + extquanodes ) +! ====================================================================== +! +! programmer Niek Praagman +! version 3.2 date 29-10-2010 Dynamic allocation helparrays +! version 3.1 date 15-07-2009 Quadratic internal lines allowed +! version 3.0 date 15-02-2005 Update +! +! copyright (c) 1990-2010 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Create quadratic triangles in case of an existing +! linear triangular SEPRAN mesh as given in array KELEM. +! ********************************************************************** +! +! KEYWORDS +! +! 2d +! mesh_generation +! triangle +! quadratic +! ********************************************************************** +! +! MODULES USED +! + use mshdummymethods + use mshconstants + use msherror + + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cconst' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision coor(*) + integer npoint, kelem(*), nelem, nbn, kbound(*), extquanodes(*) + +! coor i/o coordinates array +! extquanodes i helparray for quadratic internal line elements +! kbound i array containing the endnodes of the boundary +! elements (length 2*nbn) +! kelem i,o array containing the triangular linear elements +! at input and quadratic at output +! nbn i number of boundary elements +! nelem i number of elements +! npoint i,o at input total number of points in triangular +! linear mesh, at output inj quadratic mesh +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer error, i, ip(6), meshtp, nummer, iextra, jstart, jstend, + + ii, ibrp, itotal, npnold, ibrlen, npt, nbr, ia, ib, + + ileng + integer, allocatable, dimension(:) :: istart + integer, allocatable, dimension(:) :: ibrpnt + integer, allocatable, dimension(:) :: kelemh + +! error Return value of allocate or deallocate +! i loop variable +! ia first node +! ib second node +! ibrlen declared length of neighbour array +! ibrp guess of number of neighbours for each point +! ibrpnt helparray containing the neighbours of each point +! iextra helpvariable for case of more than five neighbours +! ii loop variable +! ileng length helparray for quadratic case +! ip array to store node numbers +! istart helparray with starting positions for each node in ibrpnt +! itotal total number of nodes +! jstart start of do variable for neighbours +! jstend end of do variable for checking neighbours +! kelemh helparray used if node has more than five neighbours +! meshtp element type according to SEPRAN rules +! nbr number of neighbours +! npnold old number of points (before creation of quadratic +! elements) +! npt helpvariable for number of positions +! nummer helpvariable for new points +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERALLOC Produce error message in case allocate went wrong +! ERCLOS Resets old name of previous subroutine of higher level +! ERDEALLOC Produce error message in case deallocate went wrong +! EROPEN Produces concatenated name of local subroutine +! ERRINT Put integer in error message +! ERRSUB Error messages +! MSH401 Run through group of elements to determine neighbours +! MSH402 Place nodes of one line in neighbour array +! MSH403 Determine number refinement point in line piece +! MSH406 Place quadratic triangle in element array +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! 1274 Error extra points not recognized +! 1275 Not enough space reserved for neighbours +! ********************************************************************** +! +! PSEUDO CODE +! +! Create quadratic elements and needed points in two steps +! First place the old already existing midpoints in array ibrpnt +! next create the new points and place in ibrpnt +! finally determine the new elements +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen ( 'msho31' ) + +! --- Allocate space for helparrays + + allocate ( istart(npoint+1), ibrpnt((npoint+1)*10), + + kelemh(npoint), stat = error ) + if ( error/=0 ) call eralloc ( error, 12*npoint+11, 'istart' ) + if ( ierror/=0 ) go to 1000 + + istart = 0 ! Clear array istart + ibrpnt = 0 ! Clear array ibrpnt + + ibrp = 10 + +! --- Set used length kelemh + + kelemh(1) = 0 + +! --- Special value for meshtp + + meshtp = 3 + +! --- Fill arrays + + call msh401( npoint, kelem, nelem, istart, ibrp, ibrpnt, kelemh, + + meshtp, 3 , 1 , 0 , 0 ) + +! --- Make shift in array for all neighbour points + + iextra = 0 + nummer = 0 + +! --- First skip all empty places + + do i = 1 , npoint + jstart = ibrp * (i-1) + 1 + jstend = ibrp * i + do ii = jstart, jstend + if ( ibrpnt(ii)/=0 ) then + +! --- Place neighbour point + + nummer = nummer + 1 + ibrpnt(nummer) = ibrpnt(ii) + end if + end do + end do + +! --- Keep total number + + itotal = nummer + +! --- Number of positions needed in ibrpnt is 2 * nummer and number of +! positions declared is ibrlen + + ibrlen = ibrp * ( npoint + 1 ) + +! --- Check length + + if ( ibrlen<2 * nummer ) then + +! --- Error, not enough positions + + call errint ( 2*nummer, 1 ) + call errint ( ibrlen , 2 ) + call errsub ( 1275, 2, 0, 0 ) + go to 1000 + end if + +! --- Make shift + + npt = ibrlen + +! --- Run through all basis nodes + + do i = npoint, 1, -1 + +! --- Determine number of neighbours of i + + nbr = istart(i) + +! --- Check for extra points + + if ( nbr>ibrp ) then + +! --- There are extra points + + iextra = 1 + +! --- Make reservation of positions + + do ib = 1 , nbr-ibrp + ibrpnt(npt) = 0 + npt = npt - 1 + end do + +! --- Add to itotal + + itotal = itotal + nbr - ibrp + nbr = ibrp + end if + + do ib = 1 , nbr + ibrpnt( npt ) = ibrpnt( nummer ) + npt = npt - 1 + nummer = nummer - 1 + end do + + if ( nptibrlen ) then + call errint ( 2*nummer, 1 ) + call errint ( ibrlen , 2 ) + call errsub ( 1275, 2, 0, 0 ) + go to 1000 + end if + +! --- Set number of points for copiing later + + itotal = istart(npoint+1)-1 + + do i = 2, npoint+1 + istart(i) = 2 * istart(i)-1 + end do + +! --- Make place for new nodes + + do i = itotal, 1, -1 + ibrpnt(2*i ) = 0 + ibrpnt(2*i-1) = ibrpnt(i) + end do + +! --- Place new nodal-point numbers +! first the old numbers have to be placed again (determine the number +! while realizing that several gaps may exist in the boundary) + + do i = 1 , nbn + ip(1) = kbound( 2*i - 1 ) + ip(2) = kbound( 2*i ) + ip(3) = ip(1) + 1 + if ( ip(1)0 .and. ip(3)==0 ) then + +! --- Place new point and compute coordinates + + npoint = npoint + 1 + ibrpnt( ii+1 ) = npoint + coor(2*npoint-1)=(coor(2*i-1)+coor(2*ip(2)-1)) / 2d0 + coor(2*npoint )=(coor(2*i )+coor(2*ip(2) )) / 2d0 + end if + end do + end do + +! --- Create the new elements + + do i = nelem , 1 , -1 + ip(1) = kelem( 3*i - 2 ) + ip(3) = kelem( 3*i - 1 ) + ip(5) = kelem( 3*i ) + call msh403( npnold, ip(1), ip(3), ibrpnt, istart, ip(2) ) + call msh403( npnold, ip(3), ip(5), ibrpnt, istart, ip(4) ) + call msh403( npnold, ip(5), ip(1), ibrpnt, istart, ip(6) ) + call msh406( kelem, i, + + ip(1), ip(2), ip(3), ip(4), ip(5), ip(6) ) + end do + +! --- Finally deallocate helparrays + + deallocate( istart, ibrpnt, kelemh, stat = error ) + if ( error/=0 ) call erdealloc ( error, 'istart' ) + +! --- Close routine + +1000 call erclos ( 'msho31' ) + + end diff --git a/extern/sepran/msho32.for b/extern/sepran/msho32.for new file mode 100644 index 000000000..9fc5d61ed --- /dev/null +++ b/extern/sepran/msho32.for @@ -0,0 +1,98 @@ + subroutine msho32 ( kelem, nelem, inpelm, npunt ) +! ====================================================================== +! +! programmer Niek Praagman +! version 3.0 date 15-02-2005 Update +! version 2.0 date 21-02-1994 New norms +! version 1.0 date 12-04-1991 +! +! copyright (c) 1991-2005 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Recreate a triangular mesh from quadratic triangles. +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! recreation +! ********************************************************************** +! +! MODULES USED +! + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer kelem(*), nelem, inpelm, npunt + +! inpelm i number of nodes in one element +! kelem i,o array containing the triangular quadratic elements +! at input and the linear ones at output +! nelem i number of elements +! npunt o highest point number in triangular mesh +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer i, j1, j2 + +! i loop variable +! j1 local pointer +! j2 local pointer +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! trivial +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Run through array kelem to make linear triangles + + do i = 1 , nelem + j1 = 3 * ( i - 1 ) + j2 = inpelm * ( i - 1 ) + kelem( j1 + 1 ) = kelem( j2 + 1 ) + kelem( j1 + 2 ) = kelem( j2 + 3 ) + kelem( j1 + 3 ) = kelem( j2 + 5 ) + end do + +! --- Find highest node number + + npunt = 0 + do i = 1 , 3 * nelem + if ( kelem(i)>npunt ) npunt = kelem(i) + end do + end diff --git a/extern/sepran/msho33.for b/extern/sepran/msho33.for new file mode 100755 index 000000000..1da566ccb --- /dev/null +++ b/extern/sepran/msho33.for @@ -0,0 +1,126 @@ + subroutine msho33 ( coor, ratio, i1, i2, i3 ) +! ====================================================================== +! +! programmer Niek Praagman +! version 1.0 date 17-01-2007 +! +! copyright (c) 2007-2007 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Determine the ratio (2*Rout/Rin) for all triangles of the mesh +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! radius +! 2d +! ********************************************************************** +! +! MODULES USED +! + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer i1, i2, i3 + double precision ratio, coor(2,*) + +! coor i array with coordinates of nodes +! i1 i first node of triangle +! i2 i second node of triangle +! i3 i third node of triangle +! ratio o 2 * radius divided by radius outer circle +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision opp, ri, ro, s, s1, s2, s3, + + x1, x2, x3, y1, y2, y3 + +! opp surface +! ri radius inner circle +! ro radius outer circle +! s helpvariable to store sum of length of sides +! s1 euclidian distance side 1 +! s2 euclidian distance side 2 +! s3 euclidian distance side 3 +! x1 x-coordinate node 1 +! x2 x-coordinate node 2 +! x3 x-coordinate node 3 +! y1 y-coordinate node 1 +! y2 y-coordinate node 2 +! y3 y-coordinate node 3 +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! trivial +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Determine coordinates + + x1 = coor(1,i1) + y1 = coor(2,i1) + + x2 = coor(1,i2) + y2 = coor(2,i2) + + x3 = coor(1,i3) + y3 = coor(2,i3) + +! --- Determine length of the three sides: + + s1 = sqrt( (x2-x1)*(x2-x1) + (y2-y1)*(y2-y1) ) + s2 = sqrt( (x3-x2)*(x3-x2) + (y3-y2)*(y3-y2) ) + s3 = sqrt( (x1-x3)*(x1-x3) + (y1-y3)*(y1-y3) ) + + s = 0.5 * ( s1 + s2 + s3 ) + +! --- Calculate the surfacearea of the triangle: + + opp = sqrt( s * ( s - s1 ) * ( s - s2 ) * ( s - s3 ) ) + +! --- Calculate the values of the radii of outer and inner circle: + + ro = ( s1 * s2 * s3 ) / ( 4 * opp ) + + ri = opp / s + +! --- Finally determine the ratio value: + + ratio = 2 * ri / ro + + end diff --git a/extern/sepran/msho34.for b/extern/sepran/msho34.for new file mode 100755 index 000000000..d936887f3 --- /dev/null +++ b/extern/sepran/msho34.for @@ -0,0 +1,270 @@ + subroutine msho34( kpoint, coor , ncurvs, curves, + + kbndpt, nbndpt, numcurvboun, + + boundary, nbound, nholes, userco, nuspnt, + + coaval, ius1, ius2 ) +! ====================================================================== +! +! programmer niek praagman +! version 1.1 date 07-12-2009 Determination istart adjusted +! version 1.0 date 10-11-2009 +! +! copyright (c) 2009-2009 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Subroutine to determine begin- and end user point of curve on +! which node kpoint is situated. +! In node kpoint special coarseness is required. +! Compute new coarsenesses for begin and end point of curve +! ********************************************************************** +! +! KEYWORDS +! +! mesh +! mesh_generation +! 2d +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +!AvDtmp include 'SPcommon/cmcdpr' +!AvDtmp include 'SPcommon/cmcdpi' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer kpoint, ncurvs, curves(ncurvs), numcurvboun, + + boundary(2,*),nbound, nholes, nbndpt, kbndpt(nbndpt), + + nuspnt, ius1, ius2 + double precision coor(2,*), userco(2,nuspnt), + + coaval(nuspnt+1) + +! boundary i array containing start and end nodes boundary curves +! coaval i array with first the user given unity of coarseness +! and from position 2 to nuspnt+1 the coarsenesses +! of all prescribed user points +! coor i coordinate array +! curves i array with number of nodes for each internal curve +! ius1 i start node curve +! ius2 i end node curve +! kbndpt i array containing numbers of all boundary points on +! all boundary curves, internal curves included +! kpoint i nodepoint with too large coarseness +! nbound i number of nodes in boundary curves - 1 +! nbndpt i length of boundary array kbndpt +! ncurvs i number of internal curves +! nholes i number of holes in boundary +! numcurvboun i number of boundary curves +! nuspnt i number of userpoints given by user +! userco i coordinate array userpoints +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision :: afst, dis, xt, yt, xst, yst, xen, yen, xk, yk + + integer :: i, istart, j, k, n1, n2 + + logical :: debug, found + +! afst local distance between sequential nodes +! debug indicator for debugging +! dis Euclidian distance +! found indicator for finding position +! i loop variable +! istart helpvariable to find discontinuties +! j loop variable +! k loop variable +! n1 help variable to determine ref number of node +! n2 help variable to determine reference number of node +! xen x-coordinate +! xk x-coordinate +! xst x-coordinate +! xt x-coordinate +! yen y-coordinate +! yk y-coordinate +! yst y-coordinate +! yt y-coordinate +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Set debug and found + + debug = .false. + found = .false. + +! debug = .false. + +! --- Coarseness problems in node kpoint. Coordinates are: + xk = coor(1,kpoint) + yk = coor(2,kpoint) + if ( debug ) then + write(irefwr,*) 'Debug info from msho34' + write(irefwr,*) 'Node considered',kpoint,'has crds',xk,yk + end if + +! --- Check contents of all submitted curves and nodes +! and give warning for coarseness value + istart = 0 + + xst = 9999d0 + yst = 9999d0 + + xen = 9999d0 + yen = 9999d0 + +! --- Determine start and endpoint of the curve on which kpoint is +! situated: + + if ( debug ) then + write(irefwr,*) 'Contents array boundary' + write(irefwr,*) 'Number of curves is numcurvboun',numcurvboun + do i = 1, numcurvboun + n1 = boundary(2,i) + n2 = boundary(2,i+1) + write(irefwr,*) 'curve',i,'nodepos',n1,'-',n2 + end do + write(irefwr,*) 'Contents array',kbndpt + do i=1,nbndpt + write(irefwr,*) 'pos',i,'value',kbndpt(i) + end do + end if + + i = 0 + do while ( .not.found .and. in1+1 ) then + n2 = n2 - 1 + istart = 0 + end if + + if ( debug ) then + write(irefwr,*) 'Curve number',boundary(1,i) + write(irefwr,*) 'Nodes sequentially',n1,'up to',n2 + end if + + !debug = .false. + do j = n1, n2 + if ( kpoint == kbndpt(j) ) then + if ( debug ) write(irefwr,*) 'On boundary-line',i + xst = coor(1,kbndpt(n1)) + yst = coor(2,kbndpt(n1)) + xen = coor(1,kbndpt(n2)) + yen = coor(2,kbndpt(n2)) + found = .true. + !write(irefwr,*) 'Found on line',n1,'- ',n2,'ready' + end if + end do + + end do + +! --- If not yet found: internal curves? + i = 0 + + do while ( .not. found .and. i0 ) then + + kstapl(1, kstap) = npn + kstapl(2, kstap) = npoint + 1 + + kstap = kstap + 1 + kstapl(1, kstap) = npoint + 1 + kstapl(2, kstap) = npn + + if ( istep==2 ) then +! --- Extra for neighbours array + + extquanodes(ibound+1) = npn + extquanodes(ibound+2) = npoint + extquanodes(ibound+3) = npoint+1 + + ibound = ibound + 3 + end if + + else + + kstapl(1, kstap) = npoint + 1 - istep + kstapl(2, kstap) = npoint + 1 + + kstap = kstap + 1 + kstapl(1, kstap) = npoint + 1 + kstapl(2, kstap) = npoint + 1 - istep + + if ( istep==2 ) then +! --- Extra for neighbours array + + extquanodes(ibound+1) = npoint - 1 + extquanodes(ibound+2) = npoint + extquanodes(ibound+3) = npoint + 1 + + ibound = ibound + 3 + end if + + end if + + end do + +! --- Add last node of line to coor array and fill +! kbndpt accordingly: + + j = nnodes + curves(i) + + x = cocurvs(1,j) + y = cocurvs(2,j) + + npn = 0 + +! --- Check nodes so far: + + do iext = 1 , npoint-1 + + dx = x - coor(1,iext) + dy = y - coor(2,iext) + + dis = sqrt(dx*dx + dy*dy) + + if ( dis0 ) then + coa = cube ( i ) + isml = i + end if + end do + +! --- Set smallest value: + + csmall = cube(isml) + + coa = 0d0 + + do i = 1, nx * ny +! --- Check each cube + if ( cube(i)>coa .and. jcube(i)>0 ) then + coa = cube ( i ) + ilrg = i + end if + end do + +! For future use??? +! clarge = cube(ilrg) + +! --- If Debug determine coordinates of these cubes: + if ( debug ) then + write(irefwr,*) 'nx = ',nx,' en ny = ',ny + write(irefwr,*) 'stepsize dist = ',dist + write(irefwr,*) 'xstart = ',xstart,'ystart = ',ystart + write(irefwr,*) 'xend = ',xstart+nx*dist,'yend = ', + + ystart+ny * dist + write(irefwr,*) 'en de y max = ',ystart+ny*dist + +! --- Compute n1 and n2 for cube with smallest coarseness: + n2 = int( isml/nx ) + n1 = isml - 1 - n2 * nx + + write(irefwr,*) 'Cube smallest coarseness' + write(irefwr,*) 'x- and y-coordinates centre of cube:' + write(irefwr,*) ' x=',xstart+(n1+0.5)*dist + write(irefwr,*) ' y=',ystart+(n2+0.5)*dist + +! --- Compute n1 and n2 for cube with largest coarseness: + n2 = int( ilrg/nx ) + n1 = ilrg - 1 - n2 * nx + + write(irefwr,*) 'Cube largest coarseness' + write(irefwr,*) 'coordinates:' + write(irefwr,*) ' x=',xstart+(n1+0.5)*dist + write(irefwr,*) ' y=',ystart+(n2+0.5)*dist + + end if + +! --- Check all local linepieces, running along +! the boundary + +! --- Initialize locbound array + do i = 1, numcurvboun + locbound(i) = 0 + end do + + istart = 1 + +! --- Eventually (not used now) check the boundary of this domain + if ( istart<0 ) then + + do i = 1, kstap + + i1 = kstapl(1,i) + i2 = kstapl(2,i) + + if ( i maxratio .or. dx1/dx2 > maxratio ) then +! --- Coarseness problems in node i2: + + write(irefwr,*) 'Problem for node',i2,'with crds',x2,y2 +! --- Find curve number for node i2: + do j = 1 , numcurvboun + write(irefwr,*) j,boundary(1,j),boundary(2,j) +! --- Find positions in boundary + n1 = boundary(2,j) + if ( j==numcurvboun) then + n2 = nbndpt + else + n2 = boundary(2,j+1) + end if + write(irefwr,*) 'Curve',boundary(1,j), 'Nodes' + do k = n1, n2 + xt = coor(1,k) + yt = coor(2,k) + write(irefwr,*) 'Node',kbndpt(k),xt,yt + + if ( i2==kbndpt(k) ) then + write(irefwr,*) 'Node is in curve',boundary(1,j) + locbound(j) = locbound(j)+1 + end if + end do + end do + end if + + end do + + iperm = 1 + do i = 1, numcurvboun + if ( locbound(i)>0 ) then + iperm = 0 + write(irefwr,*) + + 'Coarseness problems curve C with number',boundary(1,i), + + 'which is part of the boundary of surface',isurnr, + + 'coarsenesses start- and endnode differ too much!' + end if + locbound(i) = 0 + end do + + if ( iperm==0 ) then + write(irefwr,*) 'Check and adjust your input for the curves' + end if + + end if + +! --- Second step: check all internal mutual lines +! --- Check all nodes via internal "visible" lines: + +! --- Run through all prescribed points and consider mutual distances in relation +! to their local coarsenesses: +! (Give warning if points are not in one line) + + iperm = 1 + + eps = 1d-9 * coaval(1) + + do i = 1, npoint-1 + do j = i+1, npoint +! --- Be sure that nodes are really in linear mesh: + if ( coarse(i)> eps .and. coarse(j)>eps ) then +! --- Next step: check mutual visibility and +! if visible then check coarsenesses + + if ( debug ) write(irefwr,*) 'Check Point',i,'and point',j + +! --- Compute Euclidian distance + call msho03( i, j, coor, afst ) + +! --- Check whether coarsenesses and mutual distance are +! realistic. Find cmax and cmin of these two values: + if ( coarse(i)>coarse(j) ) then + cmax = coarse(i) + cmin = coarse(j) + kpoint = i + else + cmax = coarse(j) + cmin = coarse(i) + kpoint = j + end if + + coa = abs( (cmax - cmin)/(cmax+cmin) ) + +! --- Check possibilities: + if ( afst<0.2 * csmall ) then +! --- Check whether line does not cross outer or inner boundary: + call msho24( kstapl, kstap, coor, i, j, icheck) + + if ( icheck==0 ) then +! --- No intermediate points, give warning: too small distance + +! --- Find number of internal curve and values of coarseness + call msho34( kpoint, coor, ncurvs, curves, kbndpt, + + nbndpt, numcurvboun, boundary, nbound, + + nholes, userco, nuspnt, coaval, ius1, ius2 ) + if ( debug ) then + write(irefwr,*) 'msho38: problems in surface',isurnr + write(irefwr,*) 'Locally coarseness too small' + write(irefwr,*) 'Found value ',afst + write(irefwr,*) 'Position of nodes' + write(irefwr,*) ' Node ',i,' = ',coor(1,i),coor(2,i) + write(irefwr,*) ' Node ',j,' = ',coor(1,j),coor(2,j) + write(irefwr,*) 'Adjust coarsenesses of nodes ' + iperm = 0 + end if + end if + else if ( coa > 0.1 ) then +! --- Only action if there is a real coarseness difference + iallow = 1 + call msho39( cmax, cmin, afst, maxratio, iallow ) + if ( iallow==0 .and. debug ) + + write(irefwr,*) 'Routine msho39 iallow=0 use cmax =',cmax + icheck = 0 + if ( iallow==0 ) then +! --- Check visibility: + call msho24( kstapl, kstap, coor, i, j, icheck) + end if + + if ( iallow==0 .and. icheck==0 ) then +! --- Point is visible and coarseness is not ok + iperm = 0 + + if ( debug ) then + write(irefwr,*) 'Warning coarseness nodes',i,'and',j + write(irefwr,*) 'differs too much' + write(irefwr,*) 'Positions of the nodes are' + write(irefwr,*) ' Node ',i,' = ',coor(1,i),coor(2,i) + write(irefwr,*) ' Node ',j,' = ',coor(1,j),coor(2,j) + write(irefwr,*) 'Distance = ',afst + write(irefwr,*) 'coarseness first point = ',coarse(i) + write(irefwr,*) 'coarseness second point = ',coarse(j) + write(irefwr,*) 'Adjust Coarseness' + + end if +! --- Determine coarseness needed in kpoint: + call msho41( cmin, cmax, afst, maxratio ) +! --- Find start- and end-point of line: + call msho34( kpoint, coor, ncurvs, curves, kbndpt, + + nbndpt, numcurvboun, boundary, nbound, + + nholes, userco, nuspnt, coaval, ius1, ius2 ) + +! --- Determine new coarseness needed in ius1 and ius2: + if ( debug ) then + write(irefwr,*) 'cords kpoint',(coor(k,kpoint),k=1,2) + write(irefwr,*) 'cords ius1 ',(userco(k,ius1),k=1,2) + write(irefwr,*) 'cords ius2 ',(userco(k,ius2),k=1,2) + write(irefwr,*) 'coarsen i1 ',(coaval(ius1+1)) + write(irefwr,*) 'coarsen i2 ',(coaval(ius2+1)) + write(irefwr,*) 'coarsen kp ',cmax + write(irefwr,*) 'maxratio =',coaval(1),'tran=',tran + write(irefwr,*) (coaval(k),k=2,nuspnt+1) + end if +! --- Compute coarseness values in ius1 and ius2: +! (Use transformation coefs) + val1 = coaval(1)*coaval(ius1+1)/tran + val2 = coaval(1)*coaval(ius2+1)/tran +! --- Adjust values in coaval array: + if ( cmaxcmin ) then +! --- Check whether there is enough space from small to large: + afst = 0.6 * cmin + som = afst + + do while ( som1d0+eps ) goto 100 + opp = (x2*(y3-ym) + x3*(ym-y2) + xm*(y2-y3))/det + if ( opp<-eps .or. opp>1d0+eps ) goto 100 + opp = (x3*(y1-ym) + x1*(ym-y3) + xm*(y3-y1))/det + if ( opp<-eps .or. opp>1d0+eps ) goto 100 + +! --- Point (xm,ym) is inside: error + + write(irefwr,*) 'Error: barycentre of element',ielem + write(irefwr,*) 'is also inside triangle',jelem + write(irefwr,*) 'Essential error!' + iperm = 1 + end if +100 continue + end do + end do + + if ( iperm==1 ) then + write(irefwr,*) 'Execution stopped. Please inform SEPRA' +!AvD call instop + end if + +! --- Next consider all nodes: they should never be inside a triangle: + + do i = 1 , npoint + +! --- Run through all triangles: + + do ielem = 1, nelem + +! --- Determine nodenumbers: + + i1 = kelem(1,ielem) + i2 = kelem(2,ielem) + i3 = kelem(3,ielem) + if ( i/=i1.and.i/=i2.and.i/=i3 ) then + +! --- Check position of node i + + xm = coor(1,i) + ym = coor(2,i) + x1 = coor(1,i1) + y1 = coor(2,i1) + x2 = coor(1,i2) + y2 = coor(2,i2) + x3 = coor(1,i3) + y3 = coor(2,i3) + +! --- Check for double points: +! Extra check whether coordinates of nodes are exactly the +! same, +! i.e. check whether it concerns Plaxis points + + dis = (x1-xm)*(x1-xm) + (y1-ym)*(y1-ym) + det = abs(x1)+abs(xm)+abs(y1)+abs(ym) + if ( dis1d0+eps ) goto 200 + opp = (x2*(y3-ym) + x3*(ym-y2) + xm*(y2-y3))/det + if ( opp<-eps .or. opp>1d0+eps ) goto 200 + opp = (x3*(y1-ym) + x1*(ym-y3) + xm*(y3-y1))/det + if ( opp<-eps .or. opp>1d0+eps ) goto 200 + +! --- Point (xm,ym) is inside this triangle: error + + write(irefwr,*) 'Error: node',i,'inside element',ielem + write(irefwr,*) 'Essential error!' + iperm = 1 + end if +200 continue + end do + end do + +! --- Problems encountered? + + if ( iperm==1 ) then + write(irefwr,*) 'Execution stopped' + write(irefwr,*) 'Please inform SEPRA' +!AvD call instop + end if + + end diff --git a/extern/sepran/msho41.for b/extern/sepran/msho41.for new file mode 100755 index 000000000..9368c55f0 --- /dev/null +++ b/extern/sepran/msho41.for @@ -0,0 +1,106 @@ + subroutine msho41( cmin, cmax, dist, maxratio ) +! ====================================================================== +! +! programmer niek praagman +! version 1.0 date 10-11-2009 +! +! copyright (c) 2009-2009 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Compute the max allowed coarseness cmax in point B that is in +! accordance with given coarseness cmin in a point A. The +! Euclidian distance from A to B is dist and the max allowed ratio +! between two linepieces is maxratio. +! ********************************************************************** +! +! KEYWORDS +! +! mesh +! mesh_generation +! 2d +! ********************************************************************** +! +! MODULES USED +! + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + double precision cmax, cmin, dist, maxratio + +! cmax i/o i: given coarseness in point B +! o: max allowed coarseness in point B +! cmin i coarseness point A +! dist i Euclidian distance A to B +! maxratio i max allowed multiplication in two neighbouring +! elements (i.e. linepieces) +! ********************************************************************** +! +! LOCAL PARAMETERS +! + double precision afst, som + +! afst local distance between sequential nodes +! som temporary distance +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! Trivial +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! +! --- Check possibilities: + + if ( dist < cmin ) then +! --- Length dist too small: + cmax = cmin + else if ( dist>cmin ) then +! --- Check whether there is enough space from small to large: + afst = 0.65 * cmin + som = afst + + do while ( som xj then +! If x1 <> x2 then +! Determine x-coordinate of common point xs +! If xs lies between xi and xj then +! If xs lies between x1 and x2 then +! There is a common point +! Endif +! Endif +! Else +! If yi = yj then +! If xi and xj lie on opposite sides of xs or +! yi and yj lie on opposite sides of xs then +! There is a common point +! Endif +! Else +! Determine y-coordinate of common point ys +! If ys lies between yi and yj then +! If ys lies between y1 and y2 then +! There is a common point +! Endif +! Endif +! Endif +! Endif +! Else +! If x1 <> x2 then +! If y1 = y2 then +! If yi and yj lie on opposite sides of y1 or +! x1 and x2 lie on opposite sides of xi then +! There is a common point +! Endif +! Else +! Determine y-coordinate of common point ys +! If ys lies between yi and yj then +! If ys lies between y1 and y2 then +! There is a common point +! Endif +! Endif +! Endif +! Else +! If x1 = xi then: a common point +! Endif +! Endif +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + character(len=260) localName + localName = 'msho75' + call eropen( localName ) + + eps = 10 * epsmac + +! --- Start with "no intersection" + + ih = 1 + +! --- Check boxes to find out whether an intersection is possible: +! Determine extreme values line i-j: + + xmin = min( xi, xj ) + xmax = max( xi, xj ) + ymin = min( yi, yj ) + ymax = max( yi, yj ) + +! --- Determine extreme values line 1-2: + + xmi = min( x1, x2 ) + xma = max( x1, x2 ) + ymi = min( y1, y2 ) + yma = max( y1, y2 ) + + if ( xmi>xmax .or. xmaymax .or. yma(eps * (abs(xi) + abs(xj)))) then + +! --- xi#xj + + if (abs(x1-x2)>(eps * (abs(x1) + abs(x2)))) then + +! --- xi#xj and x1#x2 +! determine value x-coordinate intersection + + r1 = ( y1 * x2 - y2 * x1 ) / ( x2 - x1 ) + r2 = ( yi * xj - yj * xi ) / ( xj - xi ) + r3 = ( yj - yi ) / ( xj - xi ) + r4 = ( y2 - y1 ) / ( x2 - x1 ) + if ( abs(r3-r4)>eps ) then + xs = ( r1 - r2 ) / ( r3 - r4 ) + if ( ( xixs ) .or. + + ( xjxs ) .or. + + ( abs(xi-xs)xs ) .or. + + ( x2xs ) .or. + + ( abs(x1-xs)xs .and. xj>xs ) .or. + + ( y1ys .and. y2>ys ) ) ) then + ih = 0 + end if + else + +! --- Determine y-coordinate intersection + + ys = ( (yj - yi) * x1 + yi * xj - yj * xi ) / (xj - xi) + if ( ( y1ys ) .or. + + ( y2ys ) .or. + + ( abs(y1-ys)ys ) .or. + + ( yjys ) .or. + + ( abs(yi-ys)( eps * ( abs(x1) + abs(x2)))) then + +! --- xi = xj and x1#x2 + + if ( abs(y1-y2)ys .and. yj>ys ) .or. + + ( x1xs .and. x2>xs ) ) ) then + ih = 0 + end if + + else + +! --- determine y-coordinate intersection + + ys = ( (y2 - y1) * xi + y1 * x2 - y2 * x1 ) / (x2 - x1) + if ( ( yiys ) .or. + + ( yi>ys .and. yjys ) .or. + + ( y2ys ) .or. + + ( abs(y1-ys)0 ) then + +! --- ncoar>0 + + call prinin ( userpoints, ncoar, 'userpoints' ) + call prinrl1 ( coar, ncoar, 2, 'coar' ) + end if ! ( ncoar>0 ) + if ( numextcurves>0 ) then + +! --- numextcurves>0 + + lenextracrvs = 0 + do i = 1, numextcurves + lenextracrvs = lenextracrvs+numnodextcurvs(i) + end do ! i = 1, numextcurves + call prinin ( numnodextcurvs, numextcurves, + + 'numnodextcurvs' ) + call prinin ( curvenumbers, numextcurves, 'curvenumbers' ) + call prinrl1 ( bcord(2*nbound+1), lenextracrvs, 2, + + 'coordinates extra curves' ) + end if ! ( ncoar>0 ) + 1 format ( a, 1x, (10i6) ) + end if ! ( debug ) + if ( ierror/=0 ) go to 1000 + if ( itime>0 ) call ersettime ( timebefore ) + +! --- Estimated number of points + npunt = npoint +! --- Fill array coor with boundary points +! Allocate temporary space for help array kbound + allocate( kbound( 2 * npunt ), stat = error ) + if ( error/=0 ) call eralloc ( error, 2*npunt, 'kbound' ) + + call mshcopyboun ( jpnt, nbound, bcord, coor, kbndpt, + + kbound, inside, nbn, .true. ) + + if ( ierror/=0 ) go to 1000 + + if ( jnew ) then + npoint = jpnt + istep = 1 + +! --- Check for quadratic + + if ( inpelm==6 .or. inpelm==7 ) then + +! --- Adjust istep, boundary array and eventually extra curves: + + istep = 2 + + nbn = nbn / 2 + + do i = 1, nbn + kbound(2*i-1) = kbound(4*i-3) + kbound(2*i ) = kbound(4*i ) + end do + +! --- Extra curves? + + nnodes = 1 + + if ( numextcurves>0 ) then + +! --- Determine the length of extra array for curves: + + nnodes = 0 + + do i=1, numextcurves + +! --- Run through line i of the internal curves: + + nnodes = nnodes + numnodextcurvs(i) + end do + +! --- Extra array needed to place temporarily the quadratic +! elements of the internal lines: +! Length needed: 2 * nnodes + + end if + + allocate( extquanodes( 2 * nnodes ), stat = ierror) + if ( error/=0 ) call eralloc (error,2*nnodes,'extquanodes') + extquanodes(1) = 0 + + if ( debug ) then + write(irefwr,*) 'extra points = ',nnodes + write(irefwr,*) 'numextcurves = ',numextcurves + end if + else + allocate( extquanodes( 1 ), stat = ierror) + extquanodes(1) = 0 + end if + +! --- Set initial number of points + + nbndpt = nbound + + call msho2d ( coor, npoint, kbound, nbn, kmeshc, + + nelem, boundary, numcurvboun, npunt, + + inside, holeinfo, nholes, .true., + + kbndpt, nbndpt, coar, ncoar, + + userpoints, bcord(2*nbound+1), numextcurves, + + numnodextcurvs, curvenumbers, istep, + + extquanodes, isurnr, rinput, + + nuspnt, ndim ) + + if ( debug ) then + write(irefwr,*) 'Contents array kbndpt after calling msho2d' + write(irefwr,*) (kbndpt(i),i=1,nbndpt) + write(irefwr,*) 'First part coor after calling msho2d' + do i=1, nbndpt + write(irefwr,*) i,coor(2*i-1),coor(2*i) + end do + write(irefwr,*) 'end first part coordinates array coor' + write(irefwr,*) 'number of extra curves = ',numextcurves + write(irefwr,*) 'number of extra nodes on curves' + write(irefwr,*) (numnodextcurvs(i),i=1,numextcurves) + write(irefwr,*) 'it concerns curves with numbers:' + write(irefwr,*) (curvenumbers(i),i=1,numextcurves) + end if + + if ( ierror/=0 ) go to 1000 + +! --- Special treatment if elements are quadratic + + if ( inpelm==6 .or. inpelm==7 ) then + +! --- inpelm = 6 or 7, extra nodes in elements + + call msho31 ( coor, npoint, kmeshc, nelem, kbound, nbn, + + extquanodes) + if ( inpelm==7 ) then + +! --- inpelm = 7, also fill centroid + + !AvD: We only do triangles (inpelm=3), so disable calls to mshtriancentr and mshd7 (routines are missing) + !AvD: call mshtriancentr ( kmeshc, npoint, nelem, inpelm ) + if ( ierror/=0 ) go to 1000 + !AvD: call mshd7 ( kmeshc, coor, nelem, 2 ) + end if + if ( ierror/=0 ) go to 1000 + end if + + deallocate( extquanodes, stat = error ) + if ( error/=0 ) call erdealloc ( error, 'extquanodes' ) + + else + +! --- jnew = .FALSE. hence only repositioning + + nbndpt = jpnt + + !AvD: Disable call mshrep (routine is missing): only used when generating + ! a mesh by REpositioning (given current mesh with only changed boundary + ! points, move inner points). + !AvD: call mshrep ( coor, npoint, kmeshc, nelem, inpelm, nbndpt ) + +! --- MSHREP uses ordering of GENERAL hence make a renumbering if +! inpelm>3 + + if ( inpelm==6 .or. inpelm==7 ) then + +! --- inpelm = 6 or 7, extra nodes in elements + + call msho32(kmeshc,nelem,inpelm,npunt) + if ( ierror/=0 ) go to 1000 + + if ( npunt>jpnt ) then + npoint = npunt + else + npoint = jpnt + end if + +! --- Adjust boundary points value and boundary node numbers + + nbn = nbn / 2 + +! --- Run through all pieces + + do i = 1 , nbn + kbound(2*i-1) = kbound(4*i-3) + kbound(2*i ) = kbound(4*i ) + end do + +! --- Extra internal curves? + + if ( numextcurves>0 ) then + +! --- Determine the length of extra array for curves: + + nnodes = 0 + +! --- Run through internal curves + + do i=1, numextcurves + +! --- Run through line i of the internal curves: + + nnodes = nnodes + numnodextcurvs(i) + end do + +! --- Extra array needed to place temporarily the quadratic +! elements of the internal lines: +! Length needed: 2 * nnodes + + allocate( extquanodes( 2 * nnodes ), stat = ierror) + if (error/=0) call eralloc (error,2*nnodes,'extquanodes') + else + +! --- No extra nodes internal curves: + + allocate( extquanodes( 1 ), stat = ierror) + extquanodes(1) = 0 + end if + + call msho31( coor, npoint, kmeshc, nelem, kbound, nbn, + + extquanodes) + + if ( inpelm==7 ) then + +! --- inpelm = 7, also fill centroid + + !AvD: We only do triangles (inpelm=3), so disable calls to mshtriancentr and mshd7 (routines are missing) + !AvD: call mshtriancentr ( kmeshc, npoint, nelem, inpelm ) + if ( ierror/=0 ) go to 1000 + !AvD: call mshd7 ( kmeshc, coor, nelem, 2 ) + end if + if ( ierror/=0 ) go to 1000 + + deallocate( extquanodes, stat = error ) + if ( error/=0 ) call erdealloc ( error, 'extquanodes' ) + end if + + end if + + if ( igobs==0 .and. inpelm>4 ) then + +! --- Quadratic elements, copy boundary again in order to get a really +! curved boundary + + call mshcopyboun ( jpnt, nbound, bcord, coor, kbndpt, + + kbound, inside, nbn, .false. ) + + end if + + deallocate( kbound, stat = error ) + if ( error/=0 ) call erdealloc ( error, 'kbound' ) + if ( itime==1 ) call printtime('TRIANGLE', timebefore) +1000 call erclos ( 'mshoce' ) + if ( debug ) then + write(irefwr,*) 'Debug information end mshoce' + +! --- Debug information + + write(irefwr,1) 'nholes, npoint, ncoar, nelem, nbound', + + nholes, npoint, ncoar, nelem, nbound + call prinin ( kbndpt, nbound, 'kbndpt' ) + if ( nholes>0 ) then + call prinin1 ( holeinfo(1,0), nholes+2, 2, 'holeinfo' ) + end if ! ( nholes>0 ) + call prinin1 ( kmeshc, nelem, inpelm, 'kmeshc' ) + + write(irefwr,*) 'End msho2d with ',npoint,' nodes' + do i=1, npoint + write(irefwr,*) i,'x-y',coor(2*i-1),coor(2*i) + end do + write(irefwr,*) 'End mshoce' + end if + end diff --git a/extern/sepran/mshtrans2dsur.for b/extern/sepran/mshtrans2dsur.for new file mode 100755 index 000000000..55ce89f64 --- /dev/null +++ b/extern/sepran/mshtrans2dsur.for @@ -0,0 +1,218 @@ + subroutine mshtrans2dsur ( coor, npoint, xmint, ymint, tran, + + ncoar, coar, ncurvs, curves, cocurvs, + + userco, nuspnt ) +! ====================================================================== +! +! programmer Guus Segal +! version 1.1 date 10-11-2009 Add array of userpoints +! version 1.0 date 19-08-2009 +! +! copyright (c) 2009-2009 "Ingenieursbureau SEPRA" +! permission to copy or distribute this software or documentation +! in hard copy or soft copy granted only by written license +! obtained from "Ingenieursbureau SEPRA". +! all rights reserved. no part of this publication may be reproduced, +! stored in a retrieval system ( e.g., in memory, disk, or core) +! or be transmitted by any means, electronic, mechanical, photocopy, +! recording, or otherwise, without written permission from the +! publisher. +! ********************************************************************** +! +! DESCRIPTION +! +! Transform 2d region to region of unit length in first quadrant +! +! ********************************************************************** +! +! KEYWORDS +! +! mesh_generation +! 2d +! transformation +! map +! coordinate +! ********************************************************************** +! +! MODULES USED +! + use mshconstants + use mshdummymethods + use msherror + implicit none +! ********************************************************************** +! +! COMMON BLOCKS +! +! include 'SPcommon/cmcdpi' +! include 'SPcommon/cconst' +! include 'SPcommon/cinout' + +! ********************************************************************** +! +! INPUT / OUTPUT PARAMETERS +! + integer npoint, ncoar, ncurvs, nuspnt, curves(ncurvs) + double precision coor(2,npoint), xmint, ymint, tran, coar(3,*), + + cocurvs(2,*), userco(2,nuspnt) + +! coar i/o array containing coordinates and coarseness of +! special points to be used in later calculations: +! positions of these points are fixed! +! cocurvs i/o array containing the crds of the fixed line nodes +! coor i/o array containing the coordinates of the points +! curves i the curve numbers of the extra internal curves +! ncoar i number of special points in array coar +! ncurvs i number: extra internal curves submitted by user +! npoint i Number of nodal points in boundary +! nuspnt i Number of userpoints +! tran o scaling parameter +! userco i/o array containing the coords of the user points +! xmint o min x for transformation +! ymint o min y for transformation +! ********************************************************************** +! +! LOCAL PARAMETERS +! + integer i, i1, i2, nnodes + double precision xmax, ymax + logical debug + +! debug If true debug statements are carried out otherwise +! they are not +! i Counting variable +! i1 Help parameter to store a constant +! i2 Help parameter to store a constant +! nnodes Number of nodes in curve +! xmax Maximum x-value +! ymax Maximum y-value +! ********************************************************************** +! +! SUBROUTINES CALLED +! +! ERCLOS Resets old name of previous subroutine of higher level +! EROPEN Produces concatenated name of local subroutine +! PRINRL1 Print 2d real vector +! ********************************************************************** +! +! I/O +! +! ********************************************************************** +! +! ERROR MESSAGES +! +! ********************************************************************** +! +! PSEUDO CODE +! +! ********************************************************************** +! +! DATA STATEMENTS +! +! ====================================================================== +! + call eropen ( 'mshtrans2dsur' ) + debug = .false. !.and. ioutp>=0 !AvD ioutp? + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'Debug information from mshtrans2dsur' + 1 format ( a, 1x, (10i6) ) + 2 format ( a, 1x, (5d12.4) ) + + end if ! ( debug ) + if ( ierror/=0 ) go to 1000 + +! --- Replace all nodes temporarily to the first (positive) quadrant: +! (Determine translation parameters x- and y-tran) + + xmint = RINFIN + xmax = -RINFIN + ymint = RINFIN + ymax = -RINFIN + do i = 1, npoint + xmint = min(xmint,coor(1,i)) + xmax = max(xmax ,coor(1,i)) + ymint = min(ymint,coor(2,i)) + ymax = max(ymax ,coor(2,i)) + end do + + if ( debug ) then + write(irefwr,2) 'xmin, xmax', xmint, xmax + write(irefwr,2) 'ymin, ymax', ymint, ymax + end if + +! --- Make temporary transformation: + + if ( xmax - xmint>ymax - ymint ) then + tran = xmax - xmint + else + tran = ymax - ymint + end if + +! --- Scale all submitted points of coor array: + + coor(1,:) = 1d0 + ( coor(1,:) - xmint ) / tran + coor(2,:) = 1d0 + ( coor(2,:) - ymint ) / tran + +!AvD if ( debug ) +! + call prinrl1 ( coor, npoint, 2, +! + 'New coordinates, after scaling' ) + +! --- Scale all user points (userco array): + + userco(1,:) = 1d0 + ( userco(1,:) - xmint ) / tran + userco(2,:) = 1d0 + ( userco(2,:) - ymint ) / tran + +!AvD if ( debug ) +! + call prinrl1 ( userco, nuspnt, 2, +! + 'New userpoint coordinates, after scaling' ) + + if ( ncoar>0 ) then +! --- ncoar>0, change internal points + + coar(1,1:ncoar) = 1d0 + ( coar(1,1:ncoar) - xmint ) / tran + coar(2,1:ncoar) = 1d0 + ( coar(2,1:ncoar) - ymint ) / tran + coar(3,1:ncoar) = coar(3,1:ncoar) / tran + + if ( debug ) + + call prinrl1 ( coar, ncoar, 3, + + 'Internal points after scaling' ) + + end if ! ( ncoar>0 ) + + if ( ncurvs>0 ) then + +! --- Scale nodes on submitted internal curves +! Start computing number of nodes on the curves: + + nnodes = 0 + + do i = 1, ncurvs + if ( debug ) + + write(irefwr,1) 'internal curve', i + +! --- Run through line i of the internal curves: + + i1 = nnodes + 1 + i2 = nnodes + curves(i) + cocurvs(1,i1:i2) = 1d0+(cocurvs(1,i1:i2) - xmint) / tran + cocurvs(2,i1:i2) = 1d0+(cocurvs(2,i1:i2) - ymint) / tran +!AvD if ( debug ) +! + call prinrl1 ( cocurvs(1,i1), curves(i), 2, +! + 'coordinates' ) + nnodes = i2 + end do ! i = 1, ncurvs + + end if ! ( ncurvs>0 ) + +1000 call erclos ( 'mshtrans2dsur' ) + if ( debug ) then + +! --- Debug information + + write(irefwr,*) 'End mshtrans2dsur' + + end if ! ( debug ) + + end From 063fae88d51bc91ebee01c29cc76e0bd81601778 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Thu, 4 Jun 2026 16:35:52 +0200 Subject: [PATCH 07/43] GRIDEDIT-2102 Remvoed executable mode bit from files --- extern/sepran/chsort.for | 0 extern/sepran/mshchkstapl.for | 0 extern/sepran/msho33.for | 0 extern/sepran/msho34.for | 0 extern/sepran/msho40.for | 0 extern/sepran/msho41.for | 0 extern/sepran/msho42.for | 0 extern/sepran/mshtrans2dsur.for | 0 8 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 extern/sepran/chsort.for mode change 100755 => 100644 extern/sepran/mshchkstapl.for mode change 100755 => 100644 extern/sepran/msho33.for mode change 100755 => 100644 extern/sepran/msho34.for mode change 100755 => 100644 extern/sepran/msho40.for mode change 100755 => 100644 extern/sepran/msho41.for mode change 100755 => 100644 extern/sepran/msho42.for mode change 100755 => 100644 extern/sepran/mshtrans2dsur.for diff --git a/extern/sepran/chsort.for b/extern/sepran/chsort.for old mode 100755 new mode 100644 diff --git a/extern/sepran/mshchkstapl.for b/extern/sepran/mshchkstapl.for old mode 100755 new mode 100644 diff --git a/extern/sepran/msho33.for b/extern/sepran/msho33.for old mode 100755 new mode 100644 diff --git a/extern/sepran/msho34.for b/extern/sepran/msho34.for old mode 100755 new mode 100644 diff --git a/extern/sepran/msho40.for b/extern/sepran/msho40.for old mode 100755 new mode 100644 diff --git a/extern/sepran/msho41.for b/extern/sepran/msho41.for old mode 100755 new mode 100644 diff --git a/extern/sepran/msho42.for b/extern/sepran/msho42.for old mode 100755 new mode 100644 diff --git a/extern/sepran/mshtrans2dsur.for b/extern/sepran/mshtrans2dsur.for old mode 100755 new mode 100644 From ab82b3404afd04a79dc9425f2b31124865875309 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Thu, 4 Jun 2026 16:55:49 +0200 Subject: [PATCH 08/43] GRIDEDIT-2102 Added sepran directory --- extern/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/extern/CMakeLists.txt b/extern/CMakeLists.txt index fd9ac19fc..cf78f3933 100644 --- a/extern/CMakeLists.txt +++ b/extern/CMakeLists.txt @@ -1 +1,2 @@ add_subdirectory(triangle) +add_subdirectory(sepran) From e089689ebb5cf20374643f3f8c42b6be34cd77df Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Thu, 4 Jun 2026 16:56:28 +0200 Subject: [PATCH 09/43] GRIDEDIT-2102 Added sepran library --- libs/MeshKernel/tests/CMakeLists.txt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libs/MeshKernel/tests/CMakeLists.txt b/libs/MeshKernel/tests/CMakeLists.txt index 570984d72..38ca34d79 100644 --- a/libs/MeshKernel/tests/CMakeLists.txt +++ b/libs/MeshKernel/tests/CMakeLists.txt @@ -75,8 +75,7 @@ target_link_libraries( MeshKernelTestUtils gmock gtest_main - "/home/wcs1/SEPRAN/sepran/sepran/libsepran.a" - "-lgfortran" + Sepran ) # "-lifport" From bbecf4e2dda5463e1c65137828cdb429b21f875d Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Thu, 4 Jun 2026 16:57:27 +0200 Subject: [PATCH 10/43] GRIDEDIT-2102 Added sepran library cmake file --- extern/sepran/CMakeLists.txt | 86 ++++++++++++++++++++++++++++++++++++ 1 file changed, 86 insertions(+) create mode 100644 extern/sepran/CMakeLists.txt diff --git a/extern/sepran/CMakeLists.txt b/extern/sepran/CMakeLists.txt new file mode 100644 index 000000000..d2bc3bedb --- /dev/null +++ b/extern/sepran/CMakeLists.txt @@ -0,0 +1,86 @@ +enable_language(Fortran) + +set(target_name Sepran) + +add_library(${target_name} STATIC) + +set( + TARGET_SRC_LIST + chsort.for + mshconstants.f90 + mshdummymethods.f90 + msh401.for + msh402.for + msh403.for + msh406.for + msh416.for + mshchkstapl.for + mshcopyboun.for + mshcrossline.for + mshcrossline1.for + mshcurvinters.for + mshcurvinters1.for + mshcurvinters2.for + msho01.for + msho02.for + msho03.for + msho04.for + msho05.for + msho06.for + msho07.for + msho08.for + msho09.for + msho10.for + msho11.for + msho12.for + msho13.for + msho14.for + msho15.for + msho16.for + msho17.for + msho18.for + msho19.for + msho20.for + msho21.for + msho22.for + msho24.for + msho25.for + msho26.for + msho27.for + msho28.for + msho29.for + msho2d.for + msho30.for + msho31.for + msho32.for + msho33.for + msho34.for + msho35.for + msho36.for + msho38.for + msho39.for + msho40.for + msho41.for + msho42.for + msho75.for + mshoce.for + mshtrans2dsur.for +) + +target_sources(${target_name} PRIVATE ${TARGET_SRC_LIST}) + +set_target_properties( + ${target_name} + PROPERTIES + POSITION_INDEPENDENT_CODE ON + Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/modules +) + +if(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") + target_compile_options(${target_name} PRIVATE -w) + target_link_libraries(${target_name} INTERFACE gfortran) +elseif(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") + target_compile_options(${target_name} PRIVATE -w) +endif() + +source_group("Source Files" FILES ${TARGET_SRC_LIST}) \ No newline at end of file From 0f172b2d8a852c0219ef0f3f141805ac8ac11744 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Thu, 4 Jun 2026 16:54:55 +0200 Subject: [PATCH 11/43] GRIDEDIT-2102 Moved triangulation to polymorphic triangulation generator --- libs/MeshKernel/CMakeLists.txt | 2 + .../include/MeshKernel/PolygonalEnclosure.hpp | 18 ++ .../MeshKernel/TriangulationGenerator.hpp | 109 ++++++++++ libs/MeshKernel/src/PolygonalEnclosure.cpp | 37 ++++ .../MeshKernel/src/TriangulationGenerator.cpp | 202 ++++++++++++++++++ libs/MeshKernel/tests/CMakeLists.txt | 5 - libs/MeshKernelApi/src/MeshKernel.cpp | 11 +- 7 files changed, 375 insertions(+), 9 deletions(-) create mode 100644 libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp create mode 100644 libs/MeshKernel/src/TriangulationGenerator.cpp diff --git a/libs/MeshKernel/CMakeLists.txt b/libs/MeshKernel/CMakeLists.txt index 8ad32b061..89fa7a5e8 100644 --- a/libs/MeshKernel/CMakeLists.txt +++ b/libs/MeshKernel/CMakeLists.txt @@ -80,6 +80,7 @@ set( ${SRC_DIR}/SplitRowColumnOfMesh.cpp ${SRC_DIR}/TriangulationInterpolation.cpp ${SRC_DIR}/TriangulationWrapper.cpp + ${SRC_DIR}/TriangulationGenerator.cpp ) set( @@ -222,6 +223,7 @@ set( ${DOMAIN_INC_DIR}/SplitRowColumnOfMesh.hpp ${DOMAIN_INC_DIR}/TriangulationInterpolation.hpp ${DOMAIN_INC_DIR}/TriangulationWrapper.hpp + ${DOMAIN_INC_DIR}/TriangulationGenerator.hpp ${DOMAIN_INC_DIR}/Vector.hpp ) diff --git a/libs/MeshKernel/include/MeshKernel/PolygonalEnclosure.hpp b/libs/MeshKernel/include/MeshKernel/PolygonalEnclosure.hpp index 9e44e9688..f2dc0a765 100644 --- a/libs/MeshKernel/include/MeshKernel/PolygonalEnclosure.hpp +++ b/libs/MeshKernel/include/MeshKernel/PolygonalEnclosure.hpp @@ -110,6 +110,19 @@ namespace meshkernel /// @returns The generated points std::vector GeneratePoints(double scaleFactor = constants::missing::doubleValue) const; + /// @brief Get the projection used. + Projection GetProjection() const; + + /// @brief Compute the surface area of the enclosure. + /// + /// The area of the bounding polygon mimum the sum of the areas of the inner polygons + double ComputeSurfaceArea() const; + + /// @brief Compute the minimum and maximum segment lengths for the outer and all inner polygons + /// + /// Returns {minimum-segment-length, maximum-segment-length} + std::tuple SegmentLengthExtrema() const; + private: /// @typedef IndexRange /// @brief Contains the start and end of a section from the point array @@ -171,3 +184,8 @@ inline const meshkernel::Polygon& meshkernel::PolygonalEnclosure::Inner(const si { return m_inner[i]; } + +inline meshkernel::Projection meshkernel::PolygonalEnclosure::GetProjection() const +{ + return m_outer.GetProjection(); +} diff --git a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp new file mode 100644 index 000000000..86b74290a --- /dev/null +++ b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp @@ -0,0 +1,109 @@ +//---- GPL --------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2011-2026. +// +// 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 version 3. +// +// 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 . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D" and "Deltares" +// are registered trademarks of Stichting Deltares, and remain the property of +// Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------ + +#pragma once + +#include + +#include "MeshKernel/Mesh2D.hpp" +#include "MeshKernel/Polygons.hpp" + +extern "C" +{ + + extern void mshoce_( + const int* jnew, // Input: Reset indicator (Fortran Logical pointer) + double* coor, // Output: Flattened array of node coordinates + int* kmeshc, // Output: Connectivity/topology grid matrix + const int* inpelm, // Input: Element type identifier + const int* nbound, // Input: Number of boundary elements + double* bcord, // Input: Coordinates of boundary control nodes + + int* kbndpt, // Input: Type flags for boundary nodes + int* boundary, // Input: Edge-to-node connectivity map + const int* numcurvboun, // Input: Total count of curved boundary segments + int* npoint, // Output: Count of generated points + int* nelem, // Output: Count of generated elements + + int* holeinfo, // Input: Structural layout parameters for holes + const int* nholes, // Input: Total count of internal holes + const int* ncoar, // Input: Quantity of sizing descriptors passed + double* coar, // Input: Target element sizing arrays + int* userpoints, // Input: Fixed target internal points + + int* isurnr, // Output: Surface structural adjacency mapping register + const int* numextcurves, // Input: Auxiliary alignment curve flags + int* numnodextcurvs, // Input: Node mappings for alignment paths + + int* curvenumbers, // Input: Curve curvature flags + double* rinput, // Input: Supplementary sizing/weighting matrices + const int* nuspnt, // Input: Count of forced target control nodes + const int* ndim // Input: Domain spatial dimension identifier + ); +} + +namespace meshkernel +{ + + class TriangulationGenerator + { + public: + virtual ~TriangulationGenerator() = default; + + virtual std::unique_ptr generate(const Polygons& polygon) const = 0; + }; + + /// \brief Generate a triangulation using the triangle.c function + class SimpleTriangulationGenerator : public TriangulationGenerator + { + public: + SimpleTriangulationGenerator(const double factor) : scaleFactor_(factor) {} + + std::unique_ptr generate(const Polygons& polygon) const override; + + private: + const double scaleFactor_; + }; + + /// \brief Generate a triangulation using the SEPRAN library + class SepranTriangulationGenerator : public TriangulationGenerator + { + public: + std::unique_ptr generate(const Polygons& polygon) const override; + + private: + static double minimumEdgeDelta(const std::vector& polygonNodes); + + static std::vector> generatePolygonReferences(const Polygons& polygon); + + static std::tuple, std::vector>, std::vector> + gatherEdgesAndFaces(const std::vector& kmeshc, const int numberOfElements); + + static std::vector pointsFromFlatArray(const std::vector& coordinates, const int numberOfPoints); + }; + +} // namespace meshkernel diff --git a/libs/MeshKernel/src/PolygonalEnclosure.cpp b/libs/MeshKernel/src/PolygonalEnclosure.cpp index b9142e226..9850ec45e 100644 --- a/libs/MeshKernel/src/PolygonalEnclosure.cpp +++ b/libs/MeshKernel/src/PolygonalEnclosure.cpp @@ -318,3 +318,40 @@ std::vector meshkernel::PolygonalEnclosure::GeneratePoints(do return triangulationWrapper.SelectNodes(*this); } + +double meshkernel::PolygonalEnclosure::ComputeSurfaceArea() const +{ + double area = 0.0; + + auto [outerArea, centreOfMass, orientation] = Outer().FaceAreaAndCenterOfMass(); + area = outerArea; + + for (UInt i = 0; i < NumberOfInner(); ++i) + { + auto [innerArea, centreOfMass, orientation] = Inner(i).FaceAreaAndCenterOfMass(); + area -= innerArea; + } + + return area; +} + +std::tuple meshkernel::PolygonalEnclosure::SegmentLengthExtrema() const +{ + + double minimumDelta = 0.0; + double maximumDelta = 0.0; + + auto [outerMinimum, outerMaximum] = Outer().SegmentLengthExtrema(); + minimumDelta = outerMinimum; + maximumDelta = outerMaximum; + + for (UInt i = 0; i < NumberOfInner(); ++i) + { + auto [innerMinimum, innerMaximum] = Inner(i).SegmentLengthExtrema(); + + minimumDelta = std::min(minimumDelta, innerMinimum); + maximumDelta = std::max(maximumDelta, innerMaximum); + } + + return {minimumDelta, maximumDelta}; +} diff --git a/libs/MeshKernel/src/TriangulationGenerator.cpp b/libs/MeshKernel/src/TriangulationGenerator.cpp new file mode 100644 index 000000000..4ab0414fd --- /dev/null +++ b/libs/MeshKernel/src/TriangulationGenerator.cpp @@ -0,0 +1,202 @@ +#include "MeshKernel/TriangulationGenerator.hpp" + +#include +#include +#include + +std::unique_ptr meshkernel::SimpleTriangulationGenerator::generate(const Polygons& polygon) const +{ + + if (polygon.GetNumPolygons() != 1) + { + throw MeshKernelError("Cannot generate a triangulation for {} polygons", polygon.GetNumPolygons()); + } + + // generate samples in the first polygonal enclosure + auto const generatedPoints = polygon.Enclosure(0).GeneratePoints(scaleFactor_ < 0.0 ? meshkernel::constants::missing::doubleValue : scaleFactor_); + + return std::make_unique(generatedPoints, polygon, polygon.GetProjection()); +} + +double meshkernel::SepranTriangulationGenerator::minimumEdgeDelta(const std::vector& polygonNodes) +{ + double delta = std::numeric_limits::max(); + + for (size_t i = 0; i + 1 < polygonNodes.size(); ++i) + { + double dx = polygonNodes[i + 1].x - polygonNodes[i].x; + double dy = polygonNodes[i + 1].y - polygonNodes[i].y; + + delta = std::min(delta, std::sqrt(dx * dx + dy * dy)); + } + + return delta; +} + +std::vector meshkernel::SepranTriangulationGenerator::pointsFromFlatArray(const std::vector& coordinates, const int numberOfPoints) +{ + std::vector meshNodes(numberOfPoints); + + for (int i = 0; i < numberOfPoints; ++i) + { + meshNodes[i].x = coordinates[2 * i]; + meshNodes[i].y = coordinates[2 * i + 1]; + } + + return meshNodes; +} + +std::vector> meshkernel::SepranTriangulationGenerator::generatePolygonReferences(const Polygons& polygon) +{ + const auto& enclosure = polygon.Enclosure(0); + + std::vector> boundaryLoops; + boundaryLoops.reserve(1 + enclosure.NumberOfInner()); + boundaryLoops.emplace_back(enclosure.Outer()); + + for (meshkernel::UInt i = 0; i < enclosure.NumberOfInner(); ++i) + { + boundaryLoops.emplace_back(enclosure.Inner(i)); + } + + return boundaryLoops; +} + +std::tuple, std::vector>, std::vector> +meshkernel::SepranTriangulationGenerator::gatherEdgesAndFaces(const std::vector& kmeshc, const int numberOfElements) +{ + + std::vector edges(3 * numberOfElements); + std::vector> faceNodes(numberOfElements); + std::vector numFaceNodes(numberOfElements, 0); + + // Gather all edges in the mesh + // The first stage will find shared edges twice, once for each triangle. The duplicate will be removed later. + for (int i = 0; i < numberOfElements; ++i) + { + int index = 3 * i; + + meshkernel::UInt n1 = static_cast(kmeshc[index] - 1); + meshkernel::UInt n2 = static_cast(kmeshc[index + 1] - 1); + meshkernel::UInt n3 = static_cast(kmeshc[index + 2] - 1); + + // Which is better, reserve and push back or allocate and assign? + edges[index] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); + edges[index + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge(n3, n2); + edges[index + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge(n1, n3); + + // Set the nodes of the element. + faceNodes[i].resize(3); + faceNodes[i][0] = n1; + faceNodes[i][1] = n2; + faceNodes[i][2] = n3; + + // Indicate that there are 3 nodes for this element + numFaceNodes[i] = 3; + } + + // Remove the duplicated edges. + // std::pair has a predefined less-than (Edge is a std;:pair) + std::sort(std::execution::par, edges.begin(), edges.end()); + auto [first, last] = std::ranges::unique(edges); + edges.erase(first, last); + + return {edges, faceNodes, numFaceNodes}; +} + +std::unique_ptr meshkernel::SepranTriangulationGenerator::generate(const Polygons& polygon) const +{ + + if (polygon.GetNumPolygons() != 1) + { + throw MeshKernelError("Cannot generate a triangulation for {} polygons", polygon.GetNumPolygons()); + } + + std::vector> boundaryLoops(generatePolygonReferences(polygon)); + + const int numberOfBoundaryNodes = std::accumulate(boundaryLoops.begin(), boundaryLoops.end(), 0, [](int sum, const auto& poly) + { return sum + static_cast(poly.get().Size()); }); + + const int dimension = 2; + const int elementIdentifier = 3; // 3-node linear triangles + const int numberOfPolygons = static_cast(boundaryLoops.size()); + const int numberOfHoles = numberOfPolygons - 1; + + // 1. Interleave coordinates into bcord: [x1, y1, x2, y2...] + // Flatten the outer polygon followed by each inner polygon, without separators. + std::vector boundaryCoordinates(2 * numberOfBoundaryNodes); + + // 2. Map edgeNodeConnectivity: Fortran uses 1-based indexing + std::vector edgeNodeConnectivity(numberOfBoundaryNodes, 0); + + // 3. Map boundary segments: Fortran boundary(2, numberOfPolygons) + // One curve entry per closed loop, flattened in column-major order. + + std::vector boundaryConnectivity(2 * numberOfPolygons); + + // 4. Compute elementSizing array for local polyline point matching + const int numberElementSizing = 0; // numberOfBoundaryNodes; + std::vector elementSizing(1, 0.0); // 3 * numberOfBoundaryNodes); + + int pointOffset = 0; + + for (int loopIndex = 0; loopIndex < numberOfPolygons; ++loopIndex) + { + const auto& loop = boundaryLoops[loopIndex].get().Nodes(); + + boundaryConnectivity[2 * loopIndex] = loopIndex + 1; + boundaryConnectivity[2 * loopIndex + 1] = pointOffset + 1; + + for (int i = 0; i < static_cast(loop.size()); ++i) + { + boundaryCoordinates[2 * (pointOffset + i)] = loop[i].x; + boundaryCoordinates[2 * (pointOffset + i) + 1] = loop[i].y; + edgeNodeConnectivity[pointOffset + i] = pointOffset + i + 1; + } + + pointOffset += static_cast(loop.size()); + } + + // 5. Dynamic Memory Allocation for Output Buffers + // Get estimate of area covered by polygon, subtracting area covered by holes + const double estimatedArea = polygon.Enclosure(0).ComputeSurfaceArea(); + // Compute the minimum spacing between points of the polygon, both outer and all inner polygons + const auto [minimumDelta, maximumDeltaDummy] = polygon.Enclosure(0).SegmentLengthExtrema(); + + const int estimatedNumberOfElements = static_cast((estimatedArea / (0.433 * minimumDelta * minimumDelta)) * 3.5); + const int maximumNumberOfNodes = numberOfBoundaryNodes + 3 * estimatedNumberOfElements; + const int maximumNumberOfElements = 2 * maximumNumberOfNodes; + + std::vector triangulationNodes(dimension * maximumNumberOfNodes, 0.0); + std::vector triangulationElementNodes(elementIdentifier * maximumNumberOfElements, 0); + + // 6. Dummies and Placeholders + std::vector holeinfo(2 * (numberOfHoles + 2), 0); + int forcedControlPoints = 0; + int surfaceSequenceNumber = 1; + int auxiliaryAlignment = 0; + + std::vector numnodextcurvs(1, 0); + std::vector curvenumbers(1, 0); + std::vector rinput(1, 0.0); + std::vector userpoints(1, 0); + + // 7. Make the Call + int newMesh = 1; + int numberOfPoints = maximumNumberOfNodes; + int numberOfElements = maximumNumberOfElements; + + mshoce_(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), + edgeNodeConnectivity.data(), boundaryConnectivity.data(), &numberOfPolygons, &numberOfPoints, &numberOfElements, + holeinfo.data(), &numberOfHoles, &numberElementSizing, elementSizing.data(), userpoints.data(), + &surfaceSequenceNumber, &auxiliaryAlignment, numnodextcurvs.data(), curvenumbers.data(), + rinput.data(), &forcedControlPoints, &dimension); + + // Recover array of Points + std::vector meshNodes(pointsFromFlatArray(triangulationNodes, numberOfPoints)); + + // Recover arrays of edges, face-node connectivity and number of nodes per face. + auto [edges, faceNodes, numFaceNodes] = gatherEdgesAndFaces(triangulationElementNodes, numberOfElements); + + return std::make_unique(edges, meshNodes, faceNodes, numFaceNodes, polygon.GetProjection()); +} diff --git a/libs/MeshKernel/tests/CMakeLists.txt b/libs/MeshKernel/tests/CMakeLists.txt index 38ca34d79..696b66b56 100644 --- a/libs/MeshKernel/tests/CMakeLists.txt +++ b/libs/MeshKernel/tests/CMakeLists.txt @@ -78,11 +78,6 @@ target_link_libraries( Sepran ) - # "-lifport" - # "-lifcore" - # "-lifcoremt" - - # Make sure that coverage information is produced when using gcc if(ENABLE_CODE_COVERAGE AND CMAKE_CXX_COMPILER_ID STREQUAL "GNU") target_compile_options( diff --git a/libs/MeshKernelApi/src/MeshKernel.cpp b/libs/MeshKernelApi/src/MeshKernel.cpp index 7d3f9504d..3da410c6a 100644 --- a/libs/MeshKernelApi/src/MeshKernel.cpp +++ b/libs/MeshKernelApi/src/MeshKernel.cpp @@ -84,6 +84,7 @@ #include #include #include +#include #include #include #include @@ -1960,11 +1961,13 @@ namespace meshkernelapi const meshkernel::Polygons polygon(polygonPointsVector, meshKernelState[meshKernelId].m_mesh2d->m_projection); - // generate samples in the first polygonal enclosure - auto const generatedPoints = polygon.Enclosure(0).GeneratePoints(scaleFactor < 0.0 ? meshkernel::constants::missing::doubleValue : scaleFactor); + meshkernel::TriangulationGenerator* generator = new meshkernel::SimpleTriangulationGenerator(scaleFactor); - const meshkernel::Mesh2D mesh(generatedPoints, polygon, meshKernelState[meshKernelId].m_mesh2d->m_projection); - meshKernelUndoStack.Add(meshKernelState[meshKernelId].m_mesh2d->Join(mesh), meshKernelId); + // // generate samples in the first polygonal enclosure + // auto const generatedPoints = polygon.Enclosure(0).GeneratePoints(scaleFactor < 0.0 ? meshkernel::constants::missing::doubleValue : scaleFactor); + + // const meshkernel::Mesh2D mesh(generatedPoints, polygon, meshKernetate[meshKernelId].m_mesh2d->m_projection); + meshKernelUndoStack.Add(meshKernelState[meshKernelId].m_mesh2d->Join(*generator->generate(polygon)), meshKernelId); } catch (...) { From f6ab05d48cd355e51088cec22c5234bcbc55b93b Mon Sep 17 00:00:00 2001 From: BillSenior Date: Thu, 4 Jun 2026 17:04:10 +0200 Subject: [PATCH 12/43] GRIDEDIT-2102 Removing triangulation test code temporaily --- libs/MeshKernel/tests/src/MeshTests.cpp | 531 ++++++++---------------- 1 file changed, 165 insertions(+), 366 deletions(-) diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index 8889ae2ac..64300b415 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -150,423 +150,217 @@ TEST(Mesh2D, TriangulateSamplesWithSkinnyTriangle) ASSERT_EQ(4, mesh.GetEdge(5).second); } -extern "C" -{ - - extern void mshoce_( - const int* jnew, // Input: Reset indicator (Fortran Logical pointer) - double* coor, // Output: Flattened array of node coordinates - int* kmeshc, // Output: Connectivity/topology grid matrix - const int* inpelm, // Input: Element type identifier - const int* nbound, // Input: Number of boundary elements - double* bcord, // Input: Coordinates of boundary control nodes - - int* kbndpt, // Input: Type flags for boundary nodes - int* boundary, // Input: Edge-to-node connectivity map - const int* numcurvboun, // Input: Total count of curved boundary segments - int* npoint, // Output: Count of generated points - int* nelem, // Output: Count of generated elements - - int* holeinfo, // Input: Structural layout parameters for holes - const int* nholes, // Input: Total count of internal holes - const int* ncoar, // Input: Quantity of sizing descriptors passed - double* coar, // Input: Target element sizing arrays - int* userpoints, // Input: Fixed target internal points - - int* isurnr, // Output: Surface structural adjacency mapping register - const int* numextcurves, // Input: Auxiliary alignment curve flags - int* numnodextcurvs, // Input: Node mappings for alignment paths - - int* curvenumbers, // Input: Curve curvature flags - double* rinput, // Input: Supplementary sizing/weighting matrices - const int* nuspnt, // Input: Count of forced target control nodes - const int* ndim // Input: Domain spatial dimension identifier - ); -} - -// // meshkernel::Mesh2D -// meshkernel::Mesh2D generateMesh(const meshkernel::Polygons& poly [[maybe_unused]]) +// extern "C" // { -// // auto polyline = poly.Enclosure (0).Outer ().Nodes (); -// // std::ranges::reverse(polyline); -// const auto& polyline = poly.Enclosure(0).Outer().Nodes(); - -// int nbound = static_cast(polyline.size() - 0); -// int ndim = 2; -// int inpelm = 3; // 3-node linear triangles +// extern void mshoce_( +// const int* jnew, // Input: Reset indicator (Fortran Logical pointer) +// double* coor, // Output: Flattened array of node coordinates +// int* kmeshc, // Output: Connectivity/topology grid matrix +// const int* inpelm, // Input: Element type identifier +// const int* nbound, // Input: Number of boundary elements +// double* bcord, // Input: Coordinates of boundary control nodes + +// int* kbndpt, // Input: Type flags for boundary nodes +// int* boundary, // Input: Edge-to-node connectivity map +// const int* numcurvboun, // Input: Total count of curved boundary segments +// int* npoint, // Output: Count of generated points +// int* nelem, // Output: Count of generated elements + +// int* holeinfo, // Input: Structural layout parameters for holes +// const int* nholes, // Input: Total count of internal holes +// const int* ncoar, // Input: Quantity of sizing descriptors passed +// double* coar, // Input: Target element sizing arrays +// int* userpoints, // Input: Fixed target internal points + +// int* isurnr, // Output: Surface structural adjacency mapping register +// const int* numextcurves, // Input: Auxiliary alignment curve flags +// int* numnodextcurvs, // Input: Node mappings for alignment paths + +// int* curvenumbers, // Input: Curve curvature flags +// double* rinput, // Input: Supplementary sizing/weighting matrices +// const int* nuspnt, // Input: Count of forced target control nodes +// const int* ndim // Input: Domain spatial dimension identifier +// ); +// } -// // 1. Interleave coordinates into bcord: [x1, y1, x2, y2...] -// // Flatten the boundary polygon. -// std::vector bcord(2 * nbound); // TODO should be 2 * nbound +// double minimumEdgeDelta(const std::vector& polygonNodes) +// { +// double delta = 1.0e20; -// for (int i = 0; i < nbound; ++i) +// for (size_t i = 0; i + 1 < polygonNodes.size(); ++i) // { -// bcord[2 * i] = polyline[i].x; -// bcord[2 * i + 1] = polyline[i].y; -// } - -// // 2. Map kbndpt: Fortran uses 1-based indexing -// std::vector kbndpt(nbound, 0); +// double dx = polygonNodes[i + 1].x - polygonNodes[i].x; +// double dy = polygonNodes[i + 1].y - polygonNodes[i].y; -// for (int i = 0; i < nbound; ++i) -// { -// kbndpt[i] = i + 1; +// delta = std::min(delta, std::sqrt(dx * dx + dy * dy)); // } -// // 3. Map boundary segments: Fortran boundary(2, numcurvboun) -// // Flattened in Column-Major order: segment 1 points, then segment 2 points... -// int numcurvboun = 1; -// std::vector boundary(2 * numcurvboun); +// return delta; +// } -// for (int i = 0; i < numcurvboun; ++i) -// { -// boundary[2 * i] = i + 1; -// boundary[2 * i + 1] = i + 1; -// } +// std::vector> generatePolygonReferences(const meshkernel::Polygons& polygon) +// { +// const auto& enclosure = polygon.Enclosure(0); -// // 4. Compute coar array for local polyline point matching -// int ncoar = 0; // nbound; -// std::vector coar(1, 0.0); // 3 * nbound); +// std::vector> boundaryLoops; +// boundaryLoops.reserve(1 + enclosure.NumberOfInner()); +// boundaryLoops.emplace_back(enclosure.Outer()); -// double min_coar = 1e20; -// for (int i = 0; i < nbound; ++i) +// for (meshkernel::UInt i = 0; i < enclosure.NumberOfInner(); ++i) // { -// // If i == nbound - 1 then get the second point in the list, as the last one is the same as the first -// int next = (i == nbound - 1) ? 1 : i + 1; -// double dx = polyline[next].x - polyline[i].x; -// double dy = polyline[next].y - polyline[i].y; - -// min_coar = std::min(min_coar, std::sqrt(dx * dx + dy * dy)); +// boundaryLoops.emplace_back(enclosure.Inner(i)); // } -// // 5. Dynamic Memory Allocation for Output Buffers -// auto [estimated_area, centre, direction] = poly.Enclosure(0).Outer().FaceAreaAndCenterOfMass(); // Estimate or compute dynamically via Shoelace formula - -// int estimated_elements = static_cast((estimated_area / (0.433 * min_coar * min_coar)) * 3.5); -// int max_nodes = nbound + 3 * estimated_elements; -// int max_elements = 2 * max_nodes; - -// std::cout << " estimated size " << estimated_elements << " " << max_nodes << " " << max_elements << std::endl; -// std::cout << " estimated_area " << estimated_area << " " << min_coar << " " << estimated_elements << std::endl; - -// std::vector coor(ndim * max_nodes, 0.0); -// std::vector kmeshc(inpelm * max_elements, 0); // 4 indices per element tracking matrix - -// // 6. Dummies and Placeholders -// int nholes = 0; -// std::vector holeinfo(4, 0); // = {0, 0, 0, 0}; // 2x2 empty matrix -// // int dummy_userpoint = 0; -// int nuspnt = 0; -// int isurnr = 1; // Initialize tracker to 0 -// int numextcurves = 0; - -// std::vector numnodextcurvs(1, 0); -// std::vector curvenumbers(1, 0); -// std::vector rinput(1, 0.0); -// std::vector userpoints(1, 0); - -// // 7. Make the Call -// int jnew_fortran = 1; -// int npoint = max_nodes; -// int nelem = max_elements; - -// mshoce_(&jnew_fortran, coor.data(), kmeshc.data(), &inpelm, &nbound, bcord.data(), -// kbndpt.data(), boundary.data(), &numcurvboun, &npoint, &nelem, -// holeinfo.data(), &nholes, &ncoar, coar.data(), userpoints.data(), -// &isurnr, &numextcurves, numnodextcurvs.data(), curvenumbers.data(), -// rinput.data(), &nuspnt, &ndim); +// return boundaryLoops; +// } -// std::vector nodes(npoint); +// std::vector pointsFromFlatArray(const std::vector& coordinates, const int numberOfPoints) +// { +// std::vector meshNodes(numberOfPoints); -// for (int i = 0; i < npoint; ++i) +// for (int i = 0; i < numberOfPoints; ++i) // { -// nodes[i].x = coor[2 * i]; -// nodes[i].y = coor[2 * i + 1]; +// meshNodes[i].x = coordinates[2 * i]; +// meshNodes[i].y = coordinates[2 * i + 1]; // } -// // std::vector edges; -// // edges.reserve (3 * nelem); - -// // for (int i = 0; i < nelem; ++i) { -// // int idx = 3 * i; - -// // meshkernel::UInt n1 = static_cast(kmeshc [idx] - 1); -// // meshkernel::UInt n2 = static_cast(kmeshc [idx+ 1] - 1); -// // meshkernel::UInt n3 = static_cast(kmeshc [idx + 2] - 1); - -// // meshkernel::Edge e1 = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1); -// // meshkernel::Edge e2 = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2); -// // meshkernel::Edge e3 = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3); - -// // if (std::find(edges.begin (), edges.end (), e1) == edges.end ()) -// // { -// // edges.push_back (e1); -// // } - -// // if (std::find(edges.begin (), edges.end (), e2) == edges.end ()) -// // { -// // edges.push_back (e2); -// // } - -// // if (std::find(edges.begin (), edges.end (), e3) == edges.end ()) -// // { -// // edges.push_back (e3); -// // } - -// // } +// return meshNodes; +// } -// // Alternative +// std::tuple, std::vector>, std::vector> gatherEdgesAndFaces(const std::vector& kmeshc, const int numberOfElements) +// { -// std::vector edges(3 * nelem); +// std::vector edges(3 * numberOfElements); +// std::vector> faceNodes(numberOfElements); +// std::vector numFaceNodes(numberOfElements, 0); -// for (int i = 0; i < nelem; ++i) +// // Gather all edges in the mesh +// // The first stage will find shared edges twice, once for each triangle. The duplicate will be removed later. +// for (int i = 0; i < numberOfElements; ++i) // { -// int idx = 3 * i; +// int index = 3 * i; -// meshkernel::UInt n1 = static_cast(kmeshc[idx] - 1); -// meshkernel::UInt n2 = static_cast(kmeshc[idx + 1] - 1); -// meshkernel::UInt n3 = static_cast(kmeshc[idx + 2] - 1); +// meshkernel::UInt n1 = static_cast(kmeshc[index] - 1); +// meshkernel::UInt n2 = static_cast(kmeshc[index + 1] - 1); +// meshkernel::UInt n3 = static_cast(kmeshc[index + 2] - 1); // // Which is better, reserve and push back or allocate and assign? -// edges[idx] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); -// edges[idx + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge(n3, n2); -// edges[idx + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge(n1, n3); - -// // edges.push_back (n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1)); -// // edges.push_back (n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2)); -// // edges.push_back (n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3)); +// edges[index] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); +// edges[index + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge(n3, n2); +// edges[index + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge(n1, n3); + +// // Set the nodes of the element. +// faceNodes[i].resize(3); +// faceNodes[i][0] = n1; +// faceNodes[i][1] = n2; +// faceNodes[i][2] = n3; + +// // Indicate that there are 3 nodes for this element +// numFaceNodes[i] = 3; // } -// auto edgeLessThan = [](const meshkernel::Edge& e1, const meshkernel::Edge& e2) -// { -// if (e1.first < e2.first) -// { -// return true; -// } -// else if (e1.first == e2.first) -// { -// return e1.second < e2.second; -// } -// else -// { -// return false; -// } -// }; - -// std::sort(std::execution::par, edges.begin(), edges.end(), edgeLessThan); +// // Remove the duplicated edges. +// // std::pair has a predefined less-than (Edge is a std;:pair) +// std::sort(std::execution::par, edges.begin(), edges.end()); // auto [first, last] = std::ranges::unique(edges); // edges.erase(first, last); -// // TODO need to pass the projection -// // TODO probably need to handle the projection correctly when setting things up, -// // e.g. the minimum coarseness. -// return meshkernel::Mesh2D(edges, nodes, meshkernel::Projection::cartesian); +// return {edges, faceNodes, numFaceNodes}; // } -meshkernel::Mesh2D generateMesh(const meshkernel::Polygons& poly) - { - const auto& enclosure = poly.Enclosure(0); +// meshkernel::Mesh2D generateMesh(const meshkernel::Polygons& poly) +// { +// std::vector> boundaryLoops(generatePolygonReferences(poly)); - std::vector> boundaryLoops; - boundaryLoops.emplace_back(enclosure.Outer()); +// const int numberOfBoundaryNodes = std::accumulate(boundaryLoops.begin(), boundaryLoops.end(), 0, [](int sum, const auto& poly) +// { return sum + static_cast(poly.get().Size()); }); - for (meshkernel::UInt i = 0; i < enclosure.NumberOfInner(); ++i) - { - boundaryLoops.emplace_back(enclosure.Inner(i)); - } +// const int dimension = 2; +// const int elementIdentifier = 3; // 3-node linear triangles +// const int numberOfPolygons = static_cast(boundaryLoops.size()); +// const int numberOfHoles = numberOfPolygons - 1; - int nbound = 0; - for (const auto& loop : boundaryLoops) - { - nbound += static_cast(loop.get().Size()); - } +// // 1. Interleave coordinates into bcord: [x1, y1, x2, y2...] +// // Flatten the outer polygon followed by each inner polygon, without separators. +// std::vector boundaryCoordinates(2 * numberOfBoundaryNodes); - int ndim = 2; - int inpelm = 3; // 3-node linear triangles - int numcurvboun = static_cast(boundaryLoops.size()); - int nholes = numcurvboun - 1; +// // 2. Map edgeNodeConnectivity: Fortran uses 1-based indexing +// std::vector edgeNodeConnectivity(numberOfBoundaryNodes, 0); - // 1. Interleave coordinates into bcord: [x1, y1, x2, y2...] - // Flatten the outer polygon followed by each inner polygon, without separators. - std::vector bcord(2 * nbound); +// // 3. Map boundary segments: Fortran boundary(2, numberOfPolygons) +// // One curve entry per closed loop, flattened in column-major order. - // 2. Map kbndpt: Fortran uses 1-based indexing - std::vector kbndpt(nbound, 0); +// std::vector boundaryConnectivity(2 * numberOfPolygons); - // 3. Map boundary segments: Fortran boundary(2, numcurvboun) - // One curve entry per closed loop, flattened in column-major order. - std::vector boundary(2 * numcurvboun); +// // 4. Compute elementSizing array for local polyline point matching +// const int numberElementSizing = 0; // numberOfBoundaryNodes; +// std::vector elementSizing(1, 0.0); // 3 * numberOfBoundaryNodes); - // 4. Compute coar array for local polyline point matching - int ncoar = 0; // nbound; - std::vector coar(1, 0.0); // 3 * nbound); +// int pointOffset = 0; - double min_coar = 1e20; - double estimated_area = 0.0; - int pointOffset = 0; +// for (int loopIndex = 0; loopIndex < numberOfPolygons; ++loopIndex) +// { +// const auto& loop = boundaryLoops[loopIndex].get().Nodes(); - for (int loopIndex = 0; loopIndex < numcurvboun; ++loopIndex) - { - const auto& loop = boundaryLoops[loopIndex].get().Nodes(); +// boundaryConnectivity[2 * loopIndex] = loopIndex + 1; +// boundaryConnectivity[2 * loopIndex + 1] = pointOffset + 1; - boundary[2 * loopIndex] = loopIndex + 1; - boundary[2 * loopIndex + 1] = pointOffset + 1; +// for (int i = 0; i < static_cast(loop.size()); ++i) +// { +// boundaryCoordinates[2 * (pointOffset + i)] = loop[i].x; +// boundaryCoordinates[2 * (pointOffset + i) + 1] = loop[i].y; +// edgeNodeConnectivity[pointOffset + i] = pointOffset + i + 1; +// } - for (int i = 0; i < static_cast(loop.size()); ++i) - { - bcord[2 * (pointOffset + i)] = loop[i].x; - bcord[2 * (pointOffset + i) + 1] = loop[i].y; - kbndpt[pointOffset + i] = pointOffset + i + 1; - } +// pointOffset += static_cast(loop.size()); +// } - for (int i = 0; i + 1 < static_cast(loop.size()); ++i) - { - double dx = loop[i + 1].x - loop[i].x; - double dy = loop[i + 1].y - loop[i].y; +// // 5. Dynamic Memory Allocation for Output Buffers +// // Get estimate of area covered by polygon, subtracting area covered by holes +// const double estimatedArea = poly.Enclosure(0).ComputeSurfaceArea(); +// // Compute the minimum spacing between points of the polygon, both outer and all inner polygons +// const auto [minimumDelta, _] = poly.Enclosure(0).SegmentLengthExtrema(); - min_coar = std::min(min_coar, std::sqrt(dx * dx + dy * dy)); - } +// const int estimatedNumberOfElements = static_cast((estimatedArea / (0.433 * minimumDelta * minimumDelta)) * 3.5); +// const int maximumNumberOfNodes = numberOfBoundaryNodes + 3 * estimatedNumberOfElements; +// const int maximumNumberOfElements = 2 * maximumNumberOfNodes; - auto [loopArea, centre, direction] = boundaryLoops[loopIndex].get().FaceAreaAndCenterOfMass(); - estimated_area += (loopIndex == 0 ? 1.0 : -1.0) * std::abs(loopArea); +// std::vector triangulationNodes(dimension * maximumNumberOfNodes, 0.0); +// std::vector triangulationElementNodes(elementIdentifier * maximumNumberOfElements, 0); - pointOffset += static_cast(loop.size()); - } +// // 6. Dummies and Placeholders +// std::vector holeinfo(2 * (numberOfHoles + 2), 0); +// int forcedControlPoints = 0; +// int surfaceSequenceNumber = 1; +// int auxiliaryAlignment = 0; - // 5. Dynamic Memory Allocation for Output Buffers - int estimated_elements = static_cast((estimated_area / (0.433 * min_coar * min_coar)) * 3.5); - int max_nodes = nbound + 3 * estimated_elements; - int max_elements = 2 * max_nodes; +// std::vector numnodextcurvs(1, 0); +// std::vector curvenumbers(1, 0); +// std::vector rinput(1, 0.0); +// std::vector userpoints(1, 0); - std::cout << " estimated size " << estimated_elements << " " << max_nodes << " " << max_elements << std::endl; - std::cout << " estimated_area " << estimated_area << " " << min_coar << " " << estimated_elements << std::endl; +// // 7. Make the Call +// int newMesh = 1; +// int numberOfPoints = maximumNumberOfNodes; +// int numberOfElements = maximumNumberOfElements; - std::vector coor(ndim * max_nodes, 0.0); - std::vector kmeshc(inpelm * max_elements, 0); // 4 indices per element tracking matrix +// mshoce_(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), +// edgeNodeConnectivity.data(), boundaryConnectivity.data(), &numberOfPolygons, &numberOfPoints, &numberOfElements, +// holeinfo.data(), &numberOfHoles, &numberElementSizing, elementSizing.data(), userpoints.data(), +// &surfaceSequenceNumber, &auxiliaryAlignment, numnodextcurvs.data(), curvenumbers.data(), +// rinput.data(), &forcedControlPoints, &dimension); - // 6. Dummies and Placeholders - std::vector holeinfo(2 * (nholes + 2), 0); - // int dummy_userpoint = 0; - int nuspnt = 0; - int isurnr = 1; // Initialize tracker to 0 - int numextcurves = 0; - - std::vector numnodextcurvs(1, 0); - std::vector curvenumbers(1, 0); - std::vector rinput(1, 0.0); - std::vector userpoints(1, 0); - - // 7. Make the Call - int jnew_fortran = 1; - int npoint = max_nodes; - int nelem = max_elements; - - mshoce_(&jnew_fortran, coor.data(), kmeshc.data(), &inpelm, &nbound, bcord.data(), - kbndpt.data(), boundary.data(), &numcurvboun, &npoint, &nelem, - holeinfo.data(), &nholes, &ncoar, coar.data(), userpoints.data(), - &isurnr, &numextcurves, numnodextcurvs.data(), curvenumbers.data(), - rinput.data(), &nuspnt, &ndim); - - std::vector nodes(npoint); - - for (int i = 0; i < npoint; ++i) - { - nodes[i].x = coor[2 * i]; - nodes[i].y = coor[2 * i + 1]; - } - - // std::vector edges; - // edges.reserve (3 * nelem); - - // for (int i = 0; i < nelem; ++i) { - // int idx = 3 * i; - - // meshkernel::UInt n1 = static_cast(kmeshc [idx] - 1); - // meshkernel::UInt n2 = static_cast(kmeshc [idx+ 1] - 1); - // meshkernel::UInt n3 = static_cast(kmeshc [idx + 2] - 1); - - // meshkernel::Edge e1 = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1); - // meshkernel::Edge e2 = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2); - // meshkernel::Edge e3 = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3); - - // if (std::find(edges.begin (), edges.end (), e1) == edges.end ()) - // { - // edges.push_back (e1); - // } - - // if (std::find(edges.begin (), edges.end (), e2) == edges.end ()) - // { - // edges.push_back (e2); - // } - - // if (std::find(edges.begin (), edges.end (), e3) == edges.end ()) - // { - // edges.push_back (e3); - // } - - // } - - // Alternative - - std::vector edges(3 * nelem); - - std::vector> faceNodes(nelem); - std::vector numFaceNodes(nelem, 0); - - - for (int i = 0; i < nelem; ++i) - { - int idx = 3 * i; - - meshkernel::UInt n1 = static_cast(kmeshc[idx] - 1); - meshkernel::UInt n2 = static_cast(kmeshc[idx + 1] - 1); - meshkernel::UInt n3 = static_cast(kmeshc[idx + 2] - 1); - - // Which is better, reserve and push back or allocate and assign? - edges[idx] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); - edges[idx + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge(n3, n2); - edges[idx + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge(n1, n3); - - faceNodes[i].resize (3); - faceNodes[i][0] = n1; - faceNodes[i][1] = n2; - faceNodes[i][2] = n3; - - numFaceNodes[i] = 3; - - // edges.push_back (n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge (n2, n1)); - // edges.push_back (n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge (n3, n2)); - // edges.push_back (n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge (n1, n3)); - } - - auto edgeLessThan = [](const meshkernel::Edge& e1, const meshkernel::Edge& e2) - { - if (e1.first < e2.first) - { - return true; - } - else if (e1.first == e2.first) - { - return e1.second < e2.second; - } - else - { - return false; - } - }; - - std::sort(std::execution::par, edges.begin(), edges.end(), edgeLessThan); - auto [first, last] = std::ranges::unique(edges); - edges.erase(first, last); - - // TODO need to pass the projection - // TODO probably need to handle the projection correctly when setting things up, - // e.g. the minimum coarseness. - return meshkernel::Mesh2D(edges, nodes, faceNodes, numFaceNodes, meshkernel::Projection::cartesian); - // return meshkernel::Mesh2D(edges, nodes, meshkernel::Projection::cartesian); - } +// // Recover array of Points +// std::vector meshNodes(pointsFromFlatArray(triangulationNodes, numberOfPoints)); +// // Recover arrays of edges, face-node connectivity and number of nodes per face. +// auto [edges, faceNodes, numFaceNodes] = gatherEdgesAndFaces(triangulationElementNodes, numberOfElements); + +// return meshkernel::Mesh2D(edges, meshNodes, faceNodes, numFaceNodes, poly.GetProjection()); +// } + +#if 0 TEST(Mesh, TriangulateSamples) { @@ -609,10 +403,13 @@ TEST(Mesh, TriangulateSamples) // auto polys = ReadPolygons ("/home/wcs1/MeshKernel/MeshKernel01/build_deb/northbank_001b.pol", meshkernel::Projection::cartesian); + // std::vector nodes{{0.0, 0.0}, {0.5, 0.0}, {1.0, 0.0}, {1.5, 0.0}, {2.0, 0}, {2.5, 0.0}, {3.0, 0.0}, {3.5, 0.0}, {4.0, 0.0}, {4.5, 0.0}, {5.0, 0}, {5.5, 0.0}, {6.0, 0.0}, {6.5, 0.0}, {7.0, 0.0}, {7.5, 0.0}, {8.0, 0.0}, {8.5, 0.0}, {9.0, 0.0}, {9.5, 0.0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}}; + + std::vector nodes{{0.0, 0.0}, {0.5, 0.0}, {1.0, 0.0}, {1.5, 0.0}, {2.0, 0}, {2.5, 0.0}, {3.0, 0.0}, {3.5, 0.0}, {4.0, 0.0}, {4.5, 0.0}, {5.0, 0}, {5.5, 0.0}, {6.0, 0.0}, {6.5, 0.0}, {7.0, 0.0}, {7.5, 0.0}, {8.0, 0.0}, {8.5, 0.0}, {9.0, 0.0}, {9.5, 0.0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, {-998.0, -998.0}, {2.0, 2.0}, {2.5, 2.0}, {3.0, 2.0}, {3.5, 2.0}, {4.0, 2.0}, {4.5, 2.0}, {5.0, 2.0}, {5.0, 3.5}, {5.0, 5.0}, {2.0, 5.0}, {2.0, 2.0}, {-998.0, -998.0}, {6.0, 6.0}, {8.0, 6.0}, {8.0, 8.0}, {6.0, 8.0}, {6.0, 6.0}}; - std::vector nodes{{0.0, 0.0}, {2.5, 0}, {5.0, 0.0}, {7.5, 0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, {-998.0, -998.0}, - {2.0, 2.0}, {5.0, 2.0}, {5.0, 5.0}, {2.0, 5.0}, {2.0, 2.0}, {-998.0, -998.0}, - {6.0, 6.0}, {8.0, 6.0}, {8.0, 8.0}, {6.0, 8.0}, {6.0, 6.0}}; + // std::vector nodes{{0.0, 0.0}, {1.25, 0.0}, {2.5, 0}, {5.0, 0.0}, {6.25, 0.0}, {7.5, 0}, {8.75, 0.0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}}; + + // std::vector nodes{{0.0, 0.0}, {2.5, 0}, {5.0, 0.0}, {7.5, 0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, {-998.0, -998.0}, {2.0, 2.0}, {5.0, 2.0}, {5.0, 5.0}, {2.0, 5.0}, {2.0, 2.0}, {-998.0, -998.0}, {6.0, 6.0}, {8.0, 6.0}, {8.0, 8.0}, {6.0, 8.0}, {6.0, 6.0}}; // // std::vector nodes{{0.0, 0.0}, {5.0, 0.0}, {10.0, 0.0}, // // {10.0, 5.0}, {10.0, 10.0}, {5.0, 10.0}, @@ -658,6 +455,8 @@ TEST(Mesh, TriangulateSamples) meshkernel::SaveVtk(mesh.Nodes(), mesh.m_facesNodes, "trianglemesh.vtu"); } +#endif + TEST(Mesh, TwoTrianglesDuplicatedEdges) { // 1 Setup From 66b2d03696e22acc85d39f34bbd62594cb30c115 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Thu, 4 Jun 2026 17:57:22 +0200 Subject: [PATCH 13/43] GRIDEDIT-2102 Added sepran library mk api cmake file --- libs/MeshKernelApi/tests/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/libs/MeshKernelApi/tests/CMakeLists.txt b/libs/MeshKernelApi/tests/CMakeLists.txt index ab1e61d99..f642be1ba 100644 --- a/libs/MeshKernelApi/tests/CMakeLists.txt +++ b/libs/MeshKernelApi/tests/CMakeLists.txt @@ -50,6 +50,7 @@ target_link_libraries( MeshKernelTestUtils gmock gtest_main + Sepran ) # Make sure that coverage information is produced when using gcc From 195572d0b213db53c8101f9827ccec9ed27c93e4 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Thu, 4 Jun 2026 18:13:58 +0200 Subject: [PATCH 14/43] GRIDEDIT-2102 Added unit test for sepran triangulation --- libs/MeshKernel/tests/src/MeshTests.cpp | 318 ++---------------------- 1 file changed, 27 insertions(+), 291 deletions(-) diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index 64300b415..5f48c4aaf 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -37,6 +37,7 @@ #include #include #include +#include #include #include #include @@ -150,312 +151,47 @@ TEST(Mesh2D, TriangulateSamplesWithSkinnyTriangle) ASSERT_EQ(4, mesh.GetEdge(5).second); } -// extern "C" -// { - -// extern void mshoce_( -// const int* jnew, // Input: Reset indicator (Fortran Logical pointer) -// double* coor, // Output: Flattened array of node coordinates -// int* kmeshc, // Output: Connectivity/topology grid matrix -// const int* inpelm, // Input: Element type identifier -// const int* nbound, // Input: Number of boundary elements -// double* bcord, // Input: Coordinates of boundary control nodes - -// int* kbndpt, // Input: Type flags for boundary nodes -// int* boundary, // Input: Edge-to-node connectivity map -// const int* numcurvboun, // Input: Total count of curved boundary segments -// int* npoint, // Output: Count of generated points -// int* nelem, // Output: Count of generated elements - -// int* holeinfo, // Input: Structural layout parameters for holes -// const int* nholes, // Input: Total count of internal holes -// const int* ncoar, // Input: Quantity of sizing descriptors passed -// double* coar, // Input: Target element sizing arrays -// int* userpoints, // Input: Fixed target internal points - -// int* isurnr, // Output: Surface structural adjacency mapping register -// const int* numextcurves, // Input: Auxiliary alignment curve flags -// int* numnodextcurvs, // Input: Node mappings for alignment paths - -// int* curvenumbers, // Input: Curve curvature flags -// double* rinput, // Input: Supplementary sizing/weighting matrices -// const int* nuspnt, // Input: Count of forced target control nodes -// const int* ndim // Input: Domain spatial dimension identifier -// ); -// } - -// double minimumEdgeDelta(const std::vector& polygonNodes) -// { -// double delta = 1.0e20; - -// for (size_t i = 0; i + 1 < polygonNodes.size(); ++i) -// { -// double dx = polygonNodes[i + 1].x - polygonNodes[i].x; -// double dy = polygonNodes[i + 1].y - polygonNodes[i].y; - -// delta = std::min(delta, std::sqrt(dx * dx + dy * dy)); -// } - -// return delta; -// } - -// std::vector> generatePolygonReferences(const meshkernel::Polygons& polygon) -// { -// const auto& enclosure = polygon.Enclosure(0); - -// std::vector> boundaryLoops; -// boundaryLoops.reserve(1 + enclosure.NumberOfInner()); -// boundaryLoops.emplace_back(enclosure.Outer()); - -// for (meshkernel::UInt i = 0; i < enclosure.NumberOfInner(); ++i) -// { -// boundaryLoops.emplace_back(enclosure.Inner(i)); -// } - -// return boundaryLoops; -// } - -// std::vector pointsFromFlatArray(const std::vector& coordinates, const int numberOfPoints) -// { -// std::vector meshNodes(numberOfPoints); - -// for (int i = 0; i < numberOfPoints; ++i) -// { -// meshNodes[i].x = coordinates[2 * i]; -// meshNodes[i].y = coordinates[2 * i + 1]; -// } - -// return meshNodes; -// } - -// std::tuple, std::vector>, std::vector> gatherEdgesAndFaces(const std::vector& kmeshc, const int numberOfElements) -// { - -// std::vector edges(3 * numberOfElements); -// std::vector> faceNodes(numberOfElements); -// std::vector numFaceNodes(numberOfElements, 0); - -// // Gather all edges in the mesh -// // The first stage will find shared edges twice, once for each triangle. The duplicate will be removed later. -// for (int i = 0; i < numberOfElements; ++i) -// { -// int index = 3 * i; - -// meshkernel::UInt n1 = static_cast(kmeshc[index] - 1); -// meshkernel::UInt n2 = static_cast(kmeshc[index + 1] - 1); -// meshkernel::UInt n3 = static_cast(kmeshc[index + 2] - 1); - -// // Which is better, reserve and push back or allocate and assign? -// edges[index] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); -// edges[index + 1] = n2 < n3 ? meshkernel::Edge(n2, n3) : meshkernel::Edge(n3, n2); -// edges[index + 2] = n3 < n1 ? meshkernel::Edge(n3, n1) : meshkernel::Edge(n1, n3); - -// // Set the nodes of the element. -// faceNodes[i].resize(3); -// faceNodes[i][0] = n1; -// faceNodes[i][1] = n2; -// faceNodes[i][2] = n3; - -// // Indicate that there are 3 nodes for this element -// numFaceNodes[i] = 3; -// } - -// // Remove the duplicated edges. -// // std::pair has a predefined less-than (Edge is a std;:pair) -// std::sort(std::execution::par, edges.begin(), edges.end()); -// auto [first, last] = std::ranges::unique(edges); -// edges.erase(first, last); - -// return {edges, faceNodes, numFaceNodes}; -// } - -// meshkernel::Mesh2D generateMesh(const meshkernel::Polygons& poly) -// { -// std::vector> boundaryLoops(generatePolygonReferences(poly)); - -// const int numberOfBoundaryNodes = std::accumulate(boundaryLoops.begin(), boundaryLoops.end(), 0, [](int sum, const auto& poly) -// { return sum + static_cast(poly.get().Size()); }); - -// const int dimension = 2; -// const int elementIdentifier = 3; // 3-node linear triangles -// const int numberOfPolygons = static_cast(boundaryLoops.size()); -// const int numberOfHoles = numberOfPolygons - 1; - -// // 1. Interleave coordinates into bcord: [x1, y1, x2, y2...] -// // Flatten the outer polygon followed by each inner polygon, without separators. -// std::vector boundaryCoordinates(2 * numberOfBoundaryNodes); - -// // 2. Map edgeNodeConnectivity: Fortran uses 1-based indexing -// std::vector edgeNodeConnectivity(numberOfBoundaryNodes, 0); - -// // 3. Map boundary segments: Fortran boundary(2, numberOfPolygons) -// // One curve entry per closed loop, flattened in column-major order. - -// std::vector boundaryConnectivity(2 * numberOfPolygons); - -// // 4. Compute elementSizing array for local polyline point matching -// const int numberElementSizing = 0; // numberOfBoundaryNodes; -// std::vector elementSizing(1, 0.0); // 3 * numberOfBoundaryNodes); - -// int pointOffset = 0; - -// for (int loopIndex = 0; loopIndex < numberOfPolygons; ++loopIndex) -// { -// const auto& loop = boundaryLoops[loopIndex].get().Nodes(); - -// boundaryConnectivity[2 * loopIndex] = loopIndex + 1; -// boundaryConnectivity[2 * loopIndex + 1] = pointOffset + 1; - -// for (int i = 0; i < static_cast(loop.size()); ++i) -// { -// boundaryCoordinates[2 * (pointOffset + i)] = loop[i].x; -// boundaryCoordinates[2 * (pointOffset + i) + 1] = loop[i].y; -// edgeNodeConnectivity[pointOffset + i] = pointOffset + i + 1; -// } - -// pointOffset += static_cast(loop.size()); -// } - -// // 5. Dynamic Memory Allocation for Output Buffers -// // Get estimate of area covered by polygon, subtracting area covered by holes -// const double estimatedArea = poly.Enclosure(0).ComputeSurfaceArea(); -// // Compute the minimum spacing between points of the polygon, both outer and all inner polygons -// const auto [minimumDelta, _] = poly.Enclosure(0).SegmentLengthExtrema(); - -// const int estimatedNumberOfElements = static_cast((estimatedArea / (0.433 * minimumDelta * minimumDelta)) * 3.5); -// const int maximumNumberOfNodes = numberOfBoundaryNodes + 3 * estimatedNumberOfElements; -// const int maximumNumberOfElements = 2 * maximumNumberOfNodes; - -// std::vector triangulationNodes(dimension * maximumNumberOfNodes, 0.0); -// std::vector triangulationElementNodes(elementIdentifier * maximumNumberOfElements, 0); - -// // 6. Dummies and Placeholders -// std::vector holeinfo(2 * (numberOfHoles + 2), 0); -// int forcedControlPoints = 0; -// int surfaceSequenceNumber = 1; -// int auxiliaryAlignment = 0; - -// std::vector numnodextcurvs(1, 0); -// std::vector curvenumbers(1, 0); -// std::vector rinput(1, 0.0); -// std::vector userpoints(1, 0); - -// // 7. Make the Call -// int newMesh = 1; -// int numberOfPoints = maximumNumberOfNodes; -// int numberOfElements = maximumNumberOfElements; - -// mshoce_(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), -// edgeNodeConnectivity.data(), boundaryConnectivity.data(), &numberOfPolygons, &numberOfPoints, &numberOfElements, -// holeinfo.data(), &numberOfHoles, &numberElementSizing, elementSizing.data(), userpoints.data(), -// &surfaceSequenceNumber, &auxiliaryAlignment, numnodextcurvs.data(), curvenumbers.data(), -// rinput.data(), &forcedControlPoints, &dimension); - -// // Recover array of Points -// std::vector meshNodes(pointsFromFlatArray(triangulationNodes, numberOfPoints)); - -// // Recover arrays of edges, face-node connectivity and number of nodes per face. -// auto [edges, faceNodes, numFaceNodes] = gatherEdgesAndFaces(triangulationElementNodes, numberOfElements); - -// return meshkernel::Mesh2D(edges, meshNodes, faceNodes, numFaceNodes, poly.GetProjection()); -// } - -#if 0 - -TEST(Mesh, TriangulateSamples) +TEST(Mesh, TriangulateGridWithHoleSepran) { - // Prepare - - // std::vector nodes{{0.0, 0.0}, {100.0, 0.0}, {100.0, 100.0}, {0.0, 100.0}, {0.0, 0.0} }; - // // std::vector nodes{{0.0, 0.0}, {10.0, 0.0}, {10.0, 10.0}, {0.0, 10.0}, {0.0, 0.0} }; - - // // nodes.push_back({498.503152894023, 1645.82297461613}); - // // nodes.push_back({-5.90937355559299, 814.854361678898}); - // // nodes.push_back({851.30035347439, 150.079471329115}); - // // nodes.push_back({1411.11078745316, 1182.22995897746}); - // // nodes.push_back({501.418832237663, 1642.90729527249}); - // // nodes.push_back({498.503152894023, 1645.82297461613}); - - // meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); - - // nodes = polygons.RefineFirstPolygon (0, 4, 25); - // // nodes = polygons.RefineFirstPolygon (0, 4, 2.5); - // // nodes = polygons.RefineFirstPolygon (0, 1, 1.0); - // meshkernel::Polygons polygons1(nodes, meshkernel::Projection::cartesian); - - // for (size_t i = 0; i < nodes.size (); ++i) - // { - // std::cout << " nodes " << i << " " << nodes [i].x << ", " << nodes[i].y << std::endl; - // } - - // nodes = polygons1.RefineFirstPolygon (4, 8, 5.0); - // // nodes = polygons1.RefineFirstPolygon (4, 8, 0.5); - // // nodes = polygons1.RefineFirstPolygon (10, 11, 2.0); - // meshkernel::Polygons polygons2(nodes, meshkernel::Projection::cartesian); - - // // Execute - // const auto generatedPoints = polygons2.ComputePointsInPolygons(); - - // for (size_t i = 0; i < generatedPoints[0].size (); ++i) - // { - // std::cout << " pont " << i << " " << generatedPoints[0] [i].x << ", " << generatedPoints[0][i].y << std::endl; - // } - - // auto polys = ReadPolygons ("/home/wcs1/MeshKernel/MeshKernel01/build_deb/northbank_001b.pol", meshkernel::Projection::cartesian); - - // std::vector nodes{{0.0, 0.0}, {0.5, 0.0}, {1.0, 0.0}, {1.5, 0.0}, {2.0, 0}, {2.5, 0.0}, {3.0, 0.0}, {3.5, 0.0}, {4.0, 0.0}, {4.5, 0.0}, {5.0, 0}, {5.5, 0.0}, {6.0, 0.0}, {6.5, 0.0}, {7.0, 0.0}, {7.5, 0.0}, {8.0, 0.0}, {8.5, 0.0}, {9.0, 0.0}, {9.5, 0.0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}}; - std::vector nodes{{0.0, 0.0}, {0.5, 0.0}, {1.0, 0.0}, {1.5, 0.0}, {2.0, 0}, {2.5, 0.0}, {3.0, 0.0}, {3.5, 0.0}, {4.0, 0.0}, {4.5, 0.0}, {5.0, 0}, {5.5, 0.0}, {6.0, 0.0}, {6.5, 0.0}, {7.0, 0.0}, {7.5, 0.0}, {8.0, 0.0}, {8.5, 0.0}, {9.0, 0.0}, {9.5, 0.0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, {-998.0, -998.0}, {2.0, 2.0}, {2.5, 2.0}, {3.0, 2.0}, {3.5, 2.0}, {4.0, 2.0}, {4.5, 2.0}, {5.0, 2.0}, {5.0, 3.5}, {5.0, 5.0}, {2.0, 5.0}, {2.0, 2.0}, {-998.0, -998.0}, {6.0, 6.0}, {8.0, 6.0}, {8.0, 8.0}, {6.0, 8.0}, {6.0, 6.0}}; - - // std::vector nodes{{0.0, 0.0}, {1.25, 0.0}, {2.5, 0}, {5.0, 0.0}, {6.25, 0.0}, {7.5, 0}, {8.75, 0.0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}}; - - // std::vector nodes{{0.0, 0.0}, {2.5, 0}, {5.0, 0.0}, {7.5, 0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, {-998.0, -998.0}, {2.0, 2.0}, {5.0, 2.0}, {5.0, 5.0}, {2.0, 5.0}, {2.0, 2.0}, {-998.0, -998.0}, {6.0, 6.0}, {8.0, 6.0}, {8.0, 8.0}, {6.0, 8.0}, {6.0, 6.0}}; - - // // std::vector nodes{{0.0, 0.0}, {5.0, 0.0}, {10.0, 0.0}, - // // {10.0, 5.0}, {10.0, 10.0}, {5.0, 10.0}, - // // {0.0, 10.0}, {0.0, 5.0}, {0.0, 0.0}}; + std::vector nodes{{0.0, 0.0}, {2.5, 0.0}, {5.0, 0}, {7.5, 0.0}, {10.0, 0.0}, + {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, + {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, + {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, + {-998.0, -998.0}, + {2.0, 2.0}, {3.5, 2.0}, {5.0, 2.0}, {5.0, 3.5}, {5.0, 5.0}, {2.0, 5.0}, {2.0, 2.0}}; meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); - auto polys = &polygons; - // auto mesh2 = generateMesh (polygons); - auto mesh2 = generateMesh(polygons); - meshkernel::SaveVtk(mesh2.Nodes(), mesh2.m_facesNodes, "trianglemesh.vtu"); + meshkernel::SepranTriangulationGenerator generator; + auto mesh2 = generator.generate (polygons); - // auto polys = ReadPolygons ("/home/wcs1/MeshKernel/MeshKernel01/build_deb/northbank_001b.pol", meshkernel::Projection::cartesian); - // generateMesh (*polys); - return; + std::vector expectedEdgeStart{0, 0, 0, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 8, 8, 9, 9, 9, 10, 10, 10, 11, 11, 11, 12, 13, 13, 13, 14, 14, 15, 15, 16, 16, 17, 18, 18, 19, 19, 19, 20, 20, 20, 20, 21, 22, 23, 24, 24, 24, 25, 26}; + std::vector expectedEdgeEnd{1, 15, 16, 2, 16, 17, 3, 17, 18, 4, 5, 18, 22, 5, 6, 22, 23, 7, 23, 24, 27, 8, 27, 9, 27, 10, 26, 27, 11, 25, 26, 12, 13, 25, 13, 14, 21, 25, 15, 21, 16, 21, 17, 21, 18, 19, 22, 20, 22, 23, 21, 23, 24, 25, 25, 23, 24, 25, 26, 27, 26, 27}; - const auto generatedPoints = polys->ComputePointsInPolygons(); + std::vector expectedNodeX{0, 2.5, 5, 7.5, 10, 10, 10, 10, 10, 7.5, 5, 2.5, 0, 0, 0, 0, 2, 3.5, 5, 5, 5, 2, 6.967815551, 7.104568177, 6.730464586, 4.552597509, 6.301132176, 8.595816778}; + std::vector expectedNodeY{0, 0, 0, 0, 0, 2.5, 5, 7.5, 10, 10, 10, 10, 10, 7.5, 5, 2.5, 2, 2, 2, 3.5, 5, 5, 2.750000179, 4.250000179, 6.528037461, 7.250544703, 8.877539953, 8.082877681}; - auto pnts = polys->GatherAllEnclosureNodes(); + ASSERT_EQ (mesh2->GetNumNodes (), 28); + ASSERT_EQ (mesh2->GetNumEdges (), 62); + ASSERT_EQ (mesh2->GetNumFaces (), 34); - for (size_t i = 0; i < pnts.size(); ++i) - { - for (size_t j = i + 1; j < pnts.size(); ++j) - { + const double tolerance = 1.0e-8; - if (pnts[i] == pnts[j]) - { - std::cout << " equal points " << i << " " << j << " " << pnts[i].x << ", " << pnts[i].y << std::endl; - } - } + for (size_t i = 0; i < mesh2->GetNumNodes (); ++i) + { + EXPECT_NEAR (expectedNodeX [i], mesh2->Node (i).x, tolerance); + EXPECT_NEAR (expectedNodeY [i], mesh2->Node (i).y, tolerance); } - meshkernel::Mesh2D mesh(generatedPoints[0], *polys, meshkernel::Projection::cartesian); - - // std::cout << std::endl; - // std::cout << std::endl; - - // for (size_t i = 0; i < mesh.Nodes ().size (); ++i) - // { - // std::cout << " pont " << i << " " << mesh.Nodes ()[i].x << ", " << mesh.Nodes ()[i].y << std::endl; - // } + for (size_t i = 0; i < mesh2->GetNumEdges (); ++i) + { + EXPECT_EQ (expectedEdgeStart [i], mesh2->GetEdge (i).first); + EXPECT_EQ (expectedEdgeEnd [i], mesh2->GetEdge (i).second); + } - meshkernel::SaveVtk(mesh.Nodes(), mesh.m_facesNodes, "trianglemesh.vtu"); } -#endif TEST(Mesh, TwoTrianglesDuplicatedEdges) { From 58255caf19b48af96abfb240d8a1a45b3ffb4623 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Thu, 4 Jun 2026 18:18:30 +0200 Subject: [PATCH 15/43] GRIDEDIT-2102 Added back test that removed during development of sepran triangulation --- libs/MeshKernel/tests/src/MeshTests.cpp | 49 ++++++++++++++++--------- 1 file changed, 31 insertions(+), 18 deletions(-) diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index 5f48c4aaf..3850cee8a 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -151,20 +151,35 @@ TEST(Mesh2D, TriangulateSamplesWithSkinnyTriangle) ASSERT_EQ(4, mesh.GetEdge(5).second); } +TEST(Mesh, TriangulateSamples) +{ + // Prepare + std::vector nodes; + + nodes.push_back({498.503152894023, 1645.82297461613}); + nodes.push_back({-5.90937355559299, 814.854361678898}); + nodes.push_back({851.30035347439, 150.079471329115}); + nodes.push_back({1411.11078745316, 1182.22995897746}); + nodes.push_back({501.418832237663, 1642.90729527249}); + nodes.push_back({498.503152894023, 1645.82297461613}); + + meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); + + // Execute + const auto generatedPoints = polygons.ComputePointsInPolygons(); + + meshkernel::Mesh2D mesh(generatedPoints[0], polygons, meshkernel::Projection::cartesian); +} + TEST(Mesh, TriangulateGridWithHoleSepran) { - std::vector nodes{{0.0, 0.0}, {2.5, 0.0}, {5.0, 0}, {7.5, 0.0}, {10.0, 0.0}, - {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, - {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, - {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, - {-998.0, -998.0}, - {2.0, 2.0}, {3.5, 2.0}, {5.0, 2.0}, {5.0, 3.5}, {5.0, 5.0}, {2.0, 5.0}, {2.0, 2.0}}; + std::vector nodes{{0.0, 0.0}, {2.5, 0.0}, {5.0, 0}, {7.5, 0.0}, {10.0, 0.0}, {10.0, 2.5}, {10.0, 5.0}, {10.0, 7.5}, {10.0, 10.0}, {7.5, 10.0}, {5.0, 10.0}, {2.5, 10.0}, {0.0, 10.0}, {0.0, 7.5}, {0.0, 5.0}, {0.0, 2.5}, {0.0, 0.0}, {-998.0, -998.0}, {2.0, 2.0}, {3.5, 2.0}, {5.0, 2.0}, {5.0, 3.5}, {5.0, 5.0}, {2.0, 5.0}, {2.0, 2.0}}; meshkernel::Polygons polygons(nodes, meshkernel::Projection::cartesian); meshkernel::SepranTriangulationGenerator generator; - auto mesh2 = generator.generate (polygons); + auto mesh2 = generator.generate(polygons); std::vector expectedEdgeStart{0, 0, 0, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 8, 8, 9, 9, 9, 10, 10, 10, 11, 11, 11, 12, 13, 13, 13, 14, 14, 15, 15, 16, 16, 17, 18, 18, 19, 19, 19, 20, 20, 20, 20, 21, 22, 23, 24, 24, 24, 25, 26}; std::vector expectedEdgeEnd{1, 15, 16, 2, 16, 17, 3, 17, 18, 4, 5, 18, 22, 5, 6, 22, 23, 7, 23, 24, 27, 8, 27, 9, 27, 10, 26, 27, 11, 25, 26, 12, 13, 25, 13, 14, 21, 25, 15, 21, 16, 21, 17, 21, 18, 19, 22, 20, 22, 23, 21, 23, 24, 25, 25, 23, 24, 25, 26, 27, 26, 27}; @@ -172,27 +187,25 @@ TEST(Mesh, TriangulateGridWithHoleSepran) std::vector expectedNodeX{0, 2.5, 5, 7.5, 10, 10, 10, 10, 10, 7.5, 5, 2.5, 0, 0, 0, 0, 2, 3.5, 5, 5, 5, 2, 6.967815551, 7.104568177, 6.730464586, 4.552597509, 6.301132176, 8.595816778}; std::vector expectedNodeY{0, 0, 0, 0, 0, 2.5, 5, 7.5, 10, 10, 10, 10, 10, 7.5, 5, 2.5, 2, 2, 2, 3.5, 5, 5, 2.750000179, 4.250000179, 6.528037461, 7.250544703, 8.877539953, 8.082877681}; - ASSERT_EQ (mesh2->GetNumNodes (), 28); - ASSERT_EQ (mesh2->GetNumEdges (), 62); - ASSERT_EQ (mesh2->GetNumFaces (), 34); + ASSERT_EQ(mesh2->GetNumNodes(), 28); + ASSERT_EQ(mesh2->GetNumEdges(), 62); + ASSERT_EQ(mesh2->GetNumFaces(), 34); const double tolerance = 1.0e-8; - for (size_t i = 0; i < mesh2->GetNumNodes (); ++i) + for (size_t i = 0; i < mesh2->GetNumNodes(); ++i) { - EXPECT_NEAR (expectedNodeX [i], mesh2->Node (i).x, tolerance); - EXPECT_NEAR (expectedNodeY [i], mesh2->Node (i).y, tolerance); + EXPECT_NEAR(expectedNodeX[i], mesh2->Node(i).x, tolerance); + EXPECT_NEAR(expectedNodeY[i], mesh2->Node(i).y, tolerance); } - for (size_t i = 0; i < mesh2->GetNumEdges (); ++i) + for (size_t i = 0; i < mesh2->GetNumEdges(); ++i) { - EXPECT_EQ (expectedEdgeStart [i], mesh2->GetEdge (i).first); - EXPECT_EQ (expectedEdgeEnd [i], mesh2->GetEdge (i).second); + EXPECT_EQ(expectedEdgeStart[i], mesh2->GetEdge(i).first); + EXPECT_EQ(expectedEdgeEnd[i], mesh2->GetEdge(i).second); } - } - TEST(Mesh, TwoTrianglesDuplicatedEdges) { // 1 Setup From e8bbce924cd00f27260131545cfcb1821930f68a Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 09:09:13 +0200 Subject: [PATCH 16/43] GRIDEDIT-2102 Fixed clang formatting warning --- tools/test_utils/src/PolygonReader.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/test_utils/src/PolygonReader.cpp b/tools/test_utils/src/PolygonReader.cpp index 94fde5783..d7d641586 100644 --- a/tools/test_utils/src/PolygonReader.cpp +++ b/tools/test_utils/src/PolygonReader.cpp @@ -87,7 +87,7 @@ std::unique_ptr ReadPolygons(const std::string& fileName, points.push_back(readPoint(line)); } - if (points[currentSize] != points.back ()) + if (points[currentSize] != points.back()) { points.push_back(points[currentSize]); } From 652eb5cecc5d57979c1df2ed7dc5c1ca67469acc Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 10:26:23 +0200 Subject: [PATCH 17/43] GRIDEDIT-2102 Fixed doxygen warnings --- .../include/MeshKernel/TriangulationGenerator.hpp | 15 ++++++++++++++- libs/MeshKernel/src/TriangulationGenerator.cpp | 8 ++++---- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp index 86b74290a..3b1880474 100644 --- a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp +++ b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp @@ -69,11 +69,14 @@ extern "C" namespace meshkernel { + /// \brief Generate a triangulation from a polygonal domain boundary. class TriangulationGenerator { public: + /// \brief Destructor virtual ~TriangulationGenerator() = default; + /// \brief Compute triangulation virtual std::unique_ptr generate(const Polygons& polygon) const = 0; }; @@ -81,11 +84,14 @@ namespace meshkernel class SimpleTriangulationGenerator : public TriangulationGenerator { public: + /// \brief Constructor SimpleTriangulationGenerator(const double factor) : scaleFactor_(factor) {} + /// \brief Compute triangulation using triangle std::unique_ptr generate(const Polygons& polygon) const override; private: + /// \brief The scale factor used when generating points in polygon const double scaleFactor_; }; @@ -93,16 +99,23 @@ namespace meshkernel class SepranTriangulationGenerator : public TriangulationGenerator { public: + /// \brief Compute triangulation using SEPRAN library std::unique_ptr generate(const Polygons& polygon) const override; private: + /// \brief Find the smallest delta in the boundary polygon static double minimumEdgeDelta(const std::vector& polygonNodes); + /// \brief Generate a vector of references to polygons from the set of polygonal enclosures static std::vector> generatePolygonReferences(const Polygons& polygon); + /// \brief Construct the set of edges, elements and number of nodes per element to construct mesh2d + /// + /// From the set of elements (triples of node ids in a flat array) construct arra of edges and elements static std::tuple, std::vector>, std::vector> - gatherEdgesAndFaces(const std::vector& kmeshc, const int numberOfElements); + gatherEdgesAndFaces(const std::vector& triangulationElementNodes, const int numberOfElements); + /// \brief Construct arra of points from flat array of double (x,y values store in adjacent pairs) static std::vector pointsFromFlatArray(const std::vector& coordinates, const int numberOfPoints); }; diff --git a/libs/MeshKernel/src/TriangulationGenerator.cpp b/libs/MeshKernel/src/TriangulationGenerator.cpp index 4ab0414fd..4ea3bfc90 100644 --- a/libs/MeshKernel/src/TriangulationGenerator.cpp +++ b/libs/MeshKernel/src/TriangulationGenerator.cpp @@ -63,7 +63,7 @@ std::vector> meshkernel::Sepra } std::tuple, std::vector>, std::vector> -meshkernel::SepranTriangulationGenerator::gatherEdgesAndFaces(const std::vector& kmeshc, const int numberOfElements) +meshkernel::SepranTriangulationGenerator::gatherEdgesAndFaces(const std::vector& triangulationElementNodes, const int numberOfElements) { std::vector edges(3 * numberOfElements); @@ -76,9 +76,9 @@ meshkernel::SepranTriangulationGenerator::gatherEdgesAndFaces(const std::vector< { int index = 3 * i; - meshkernel::UInt n1 = static_cast(kmeshc[index] - 1); - meshkernel::UInt n2 = static_cast(kmeshc[index + 1] - 1); - meshkernel::UInt n3 = static_cast(kmeshc[index + 2] - 1); + meshkernel::UInt n1 = static_cast(triangulationElementNodes[index] - 1); + meshkernel::UInt n2 = static_cast(triangulationElementNodes[index + 1] - 1); + meshkernel::UInt n3 = static_cast(triangulationElementNodes[index + 2] - 1); // Which is better, reserve and push back or allocate and assign? edges[index] = n1 < n2 ? meshkernel::Edge(n1, n2) : meshkernel::Edge(n2, n1); From e2f9c68e2a6da33c966943654a795a492a5aa4f8 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Mon, 8 Jun 2026 10:27:03 +0200 Subject: [PATCH 18/43] GRIDEDIT-2102 Try to get working under macos --- .github/workflows/build-and-test-workflow.yml | 32 ++++++++++++++++--- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index ef29c1cca..c3d9b0e43 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -45,9 +45,31 @@ jobs: echo "ext_deps_dir=${{ github.workspace }}/external_dependencies" >> $GITHUB_OUTPUT echo "install_dir=${{ github.workspace }}/install" >> $GITHUB_OUTPUT - - name: Install system-provided dependencies + # - name: Install system-provided dependencies + # run: | + # brew install boost doxygen libaec libomp + - name: Install system-provided dependencies + run: | + brew install boost doxygen gcc libaec libomp + + - name: Set Fortran compiler (macOS) + if: runner.os == 'macOS' run: | - brew install boost doxygen libaec libomp + GFORTRAN_BIN="$(command -v gfortran || true)" + if [ -z "$GFORTRAN_BIN" ]; then + HOMEBREW_PREFIX="$(brew --prefix)" + GFORTRAN_BIN="$(find "$HOMEBREW_PREFIX/bin" -maxdepth 1 -type f -name 'gfortran-*' | sort -V | tail -n 1)" + fi + + if [ -z "$GFORTRAN_BIN" ]; then + echo "Unable to locate a Homebrew gfortran installation" >&2 + exit 1 + fi + + echo "Using Fortran compiler: $GFORTRAN_BIN" + echo "FC=$GFORTRAN_BIN" >> "$GITHUB_ENV" + echo "F77=$GFORTRAN_BIN" >> "$GITHUB_ENV" + echo "CMAKE_Fortran_COMPILER=$GFORTRAN_BIN" >> "$GITHUB_ENV" # Step: Set OpenMP environment variables (architecture-aware) - name: Set OpenMP environment variables @@ -58,7 +80,7 @@ jobs: else HOMEBREW_PREFIX="/usr/local" fi - + echo "HOMEBREW_PREFIX=$HOMEBREW_PREFIX" >> $GITHUB_ENV echo "LDFLAGS=-L$HOMEBREW_PREFIX/opt/libomp/lib" >> $GITHUB_ENV echo "CPPFLAGS=-I$HOMEBREW_PREFIX/opt/libomp/include" >> $GITHUB_ENV @@ -114,7 +136,7 @@ jobs: # Suppress unused parameter warnings on macOS 15 Intel runner (known platform-specific issue) SUPPRESS_PARAM_FLAG="-DSUPPRESS_UNUSED_PARAMETER_WARNING=ON" fi - + cmake \ -S ${{ github.workspace }} \ -B ${{ steps.paths.outputs.build_dir }} \ @@ -144,7 +166,7 @@ jobs: if [ -f "${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c/bin/libz.dylib" ]; then ln -sf libz.dylib ${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c/bin/libz.1.dylib fi - + export DYLD_LIBRARY_PATH="${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c/bin:$DYLD_LIBRARY_PATH" ctest --test-dir ${{ steps.paths.outputs.build_dir }} \ -C ${{ inputs.build_type }} \ From 12277d88b9e0f74d1f909d77c6c03739498a2640 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 10:50:00 +0200 Subject: [PATCH 19/43] DST-112 Moved generation of points to separate function --- .../include/MeshKernel/TriangulationGenerator.hpp | 3 +++ libs/MeshKernel/src/TriangulationGenerator.cpp | 15 ++++++++++++++- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp index 3b1880474..0d03c2533 100644 --- a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp +++ b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp @@ -87,6 +87,9 @@ namespace meshkernel /// \brief Constructor SimpleTriangulationGenerator(const double factor) : scaleFactor_(factor) {} + /// \brief Compute points within polygon using triangle + std::vector generatePoints(const Polygons& polygon) const; + /// \brief Compute triangulation using triangle std::unique_ptr generate(const Polygons& polygon) const override; diff --git a/libs/MeshKernel/src/TriangulationGenerator.cpp b/libs/MeshKernel/src/TriangulationGenerator.cpp index 4ea3bfc90..9ad855dbb 100644 --- a/libs/MeshKernel/src/TriangulationGenerator.cpp +++ b/libs/MeshKernel/src/TriangulationGenerator.cpp @@ -4,7 +4,7 @@ #include #include -std::unique_ptr meshkernel::SimpleTriangulationGenerator::generate(const Polygons& polygon) const +std::vector meshkernel::SimpleTriangulationGenerator::generatePoints(const Polygons& polygon) const { if (polygon.GetNumPolygons() != 1) @@ -14,6 +14,19 @@ std::unique_ptr meshkernel::SimpleTriangulationGenerator::ge // generate samples in the first polygonal enclosure auto const generatedPoints = polygon.Enclosure(0).GeneratePoints(scaleFactor_ < 0.0 ? meshkernel::constants::missing::doubleValue : scaleFactor_); + return generatedPoints; +} + +std::unique_ptr meshkernel::SimpleTriangulationGenerator::generate(const Polygons& polygon) const +{ + + if (polygon.GetNumPolygons() != 1) + { + throw MeshKernelError("Cannot generate a triangulation for {} polygons", polygon.GetNumPolygons()); + } + + // generate samples in the first polygonal enclosure + auto const generatedPoints = generatePoints(polygon); return std::make_unique(generatedPoints, polygon, polygon.GetProjection()); } From cf166c4559522aa6c284b135747c81916e13aaed Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 10:52:24 +0200 Subject: [PATCH 20/43] GRIDEDIT-2102 Try again to get working on macos --- .github/workflows/build-and-test-workflow.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index c3d9b0e43..e01dc1f98 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -52,6 +52,13 @@ jobs: run: | brew install boost doxygen gcc libaec libomp + - name: Set Fortran compiler (macOS) + if: runner.os == 'macOS' + run: | + brew install boost doxygen libaec libomp + - name: Install system-provided dependencies + run: | + brew install boost doxygen gcc libaec libomp - name: Set Fortran compiler (macOS) if: runner.os == 'macOS' run: | From a96afccb1444399b4d6c59da716ccf6337be6be8 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 10:58:20 +0200 Subject: [PATCH 21/43] GRIDEDIT-2102 Try again to get working on macos --- .github/workflows/build-and-test-workflow.yml | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index e01dc1f98..72bddb962 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -44,18 +44,6 @@ jobs: echo "build_dir=${{ github.workspace }}/build" >> $GITHUB_OUTPUT echo "ext_deps_dir=${{ github.workspace }}/external_dependencies" >> $GITHUB_OUTPUT echo "install_dir=${{ github.workspace }}/install" >> $GITHUB_OUTPUT - - # - name: Install system-provided dependencies - # run: | - # brew install boost doxygen libaec libomp - - name: Install system-provided dependencies - run: | - brew install boost doxygen gcc libaec libomp - - - name: Set Fortran compiler (macOS) - if: runner.os == 'macOS' - run: | - brew install boost doxygen libaec libomp - name: Install system-provided dependencies run: | brew install boost doxygen gcc libaec libomp From 41c60628fe3a623adc6c2c70d7ee083c28811237 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 11:07:44 +0200 Subject: [PATCH 22/43] GRIDEDIT-2102 Try again to get working on macos --- .github/workflows/build-and-test-workflow.yml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index 72bddb962..a5cc52ab9 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -52,8 +52,12 @@ jobs: run: | GFORTRAN_BIN="$(command -v gfortran || true)" if [ -z "$GFORTRAN_BIN" ]; then + FTRNBREW_PREFIX="$(brew --prefix gcc)/bin" HOMEBREW_PREFIX="$(brew --prefix)" - GFORTRAN_BIN="$(find "$HOMEBREW_PREFIX/bin" -maxdepth 1 -type f -name 'gfortran-*' | sort -V | tail -n 1)" + + # 2. Look for the highest version available in that directory + GFORTRAN_BIN=$(ls "$FTRNBREW_PREFIX"/gfortran-* 2>/dev/null | sort -V | tail -n 1) + #GFORTRAN_BIN="$(find "$HOMEBREW_PREFIX/bin" -maxdepth 1 -type f -name 'gfortran-*' | sort -V | tail -n 1)" fi if [ -z "$GFORTRAN_BIN" ]; then From c1351c9d810b2f0a7a730b61d572df1b655488ff Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 11:12:53 +0200 Subject: [PATCH 23/43] GRIDEDIT-2102 Fixed compilation error under macos --- .github/workflows/build-and-test-workflow.yml | 6 ++---- libs/MeshKernel/src/TriangulationGenerator.cpp | 3 ++- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index a5cc52ab9..a389db77a 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -52,12 +52,10 @@ jobs: run: | GFORTRAN_BIN="$(command -v gfortran || true)" if [ -z "$GFORTRAN_BIN" ]; then - FTRNBREW_PREFIX="$(brew --prefix gcc)/bin" - HOMEBREW_PREFIX="$(brew --prefix)" + BREW_PREFIX_GFTRN="$(brew --prefix gcc)/bin" # 2. Look for the highest version available in that directory - GFORTRAN_BIN=$(ls "$FTRNBREW_PREFIX"/gfortran-* 2>/dev/null | sort -V | tail -n 1) - #GFORTRAN_BIN="$(find "$HOMEBREW_PREFIX/bin" -maxdepth 1 -type f -name 'gfortran-*' | sort -V | tail -n 1)" + GFORTRAN_BIN=$(ls "$BREW_PREFIX_GFTRN"/gfortran-* 2>/dev/null | sort -V | tail -n 1) fi if [ -z "$GFORTRAN_BIN" ]; then diff --git a/libs/MeshKernel/src/TriangulationGenerator.cpp b/libs/MeshKernel/src/TriangulationGenerator.cpp index 9ad855dbb..4e848ade5 100644 --- a/libs/MeshKernel/src/TriangulationGenerator.cpp +++ b/libs/MeshKernel/src/TriangulationGenerator.cpp @@ -110,7 +110,8 @@ meshkernel::SepranTriangulationGenerator::gatherEdgesAndFaces(const std::vector< // Remove the duplicated edges. // std::pair has a predefined less-than (Edge is a std;:pair) - std::sort(std::execution::par, edges.begin(), edges.end()); + // Should use the parallel sort, but does not seem to compile under macos: std::sort(std::execution::par, edges.begin(), edges.end()); + std::sort(edges.begin(), edges.end()); auto [first, last] = std::ranges::unique(edges); edges.erase(first, last); From 6e5c614d21a761226b96d0891e9bb3b0c4cd1908 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 11:24:06 +0200 Subject: [PATCH 24/43] GRIDEDIT-2102 Fixed linking error under macos --- extern/sepran/mshoce.for | 2 +- .../include/MeshKernel/TriangulationGenerator.hpp | 3 ++- libs/MeshKernel/src/TriangulationGenerator.cpp | 10 +++++----- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/extern/sepran/mshoce.for b/extern/sepran/mshoce.for index 52e52aed1..35c4901ca 100644 --- a/extern/sepran/mshoce.for +++ b/extern/sepran/mshoce.for @@ -2,7 +2,7 @@ + kbndpt, boundary, numcurvboun, npoint, nelem, + holeinfo, nholes, ncoar, coar, userpoints, + isurnr, numextcurves, numnodextcurvs, - + curvenumbers, rinput, nuspnt, ndim ) + + curvenumbers, rinput, nuspnt, ndim ) bind(c) ! ====================================================================== ! ! programmer Niek Praagman diff --git a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp index 0d03c2533..1921ea1e1 100644 --- a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp +++ b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp @@ -35,7 +35,8 @@ extern "C" { - extern void mshoce_( + /// \brief SEPRAN function for triangulation of a polygonal region + extern void mshoce( const int* jnew, // Input: Reset indicator (Fortran Logical pointer) double* coor, // Output: Flattened array of node coordinates int* kmeshc, // Output: Connectivity/topology grid matrix diff --git a/libs/MeshKernel/src/TriangulationGenerator.cpp b/libs/MeshKernel/src/TriangulationGenerator.cpp index 4e848ade5..a5192c5f2 100644 --- a/libs/MeshKernel/src/TriangulationGenerator.cpp +++ b/libs/MeshKernel/src/TriangulationGenerator.cpp @@ -200,11 +200,11 @@ std::unique_ptr meshkernel::SepranTriangulationGenerator::ge int numberOfPoints = maximumNumberOfNodes; int numberOfElements = maximumNumberOfElements; - mshoce_(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), - edgeNodeConnectivity.data(), boundaryConnectivity.data(), &numberOfPolygons, &numberOfPoints, &numberOfElements, - holeinfo.data(), &numberOfHoles, &numberElementSizing, elementSizing.data(), userpoints.data(), - &surfaceSequenceNumber, &auxiliaryAlignment, numnodextcurvs.data(), curvenumbers.data(), - rinput.data(), &forcedControlPoints, &dimension); + mshoce(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), + edgeNodeConnectivity.data(), boundaryConnectivity.data(), &numberOfPolygons, &numberOfPoints, &numberOfElements, + holeinfo.data(), &numberOfHoles, &numberElementSizing, elementSizing.data(), userpoints.data(), + &surfaceSequenceNumber, &auxiliaryAlignment, numnodextcurvs.data(), curvenumbers.data(), + rinput.data(), &forcedControlPoints, &dimension); // Recover array of Points std::vector meshNodes(pointsFromFlatArray(triangulationNodes, numberOfPoints)); From 4340684ba02adb5b682bdd81951c80072d1fdd20 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 11:37:51 +0200 Subject: [PATCH 25/43] GRIDEDIT-2102 Attempt tofix linking error under macos --- .github/workflows/build-and-test-workflow.yml | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index a389db77a..9ce61636c 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -68,6 +68,16 @@ jobs: echo "F77=$GFORTRAN_BIN" >> "$GITHUB_ENV" echo "CMAKE_Fortran_COMPILER=$GFORTRAN_BIN" >> "$GITHUB_ENV" + # Extract the version number (e.g., "15" from "/opt/homebrew/bin/gfortran-15") + GF_VERSION="${GFORTRAN_BIN##*-}" + + # Construct the exact Homebrew library path for this version + GF_LIB_DIR="$(brew --prefix gcc)/lib/gcc/$GF_VERSION" + + # Export library paths for your linker/CMake to pick up automatically + echo "LDFLAGS=-L$GF_LIB_DIR -lgfortran" >> "$GITHUB_ENV" + echo "CMAKE_EXE_LINKER_FLAGS=-L$GF_LIB_DIR -lgfortran" >> "$GITHUB_ENV" + # Step: Set OpenMP environment variables (architecture-aware) - name: Set OpenMP environment variables run: | @@ -155,6 +165,16 @@ jobs: - name: Build run: cmake --build ${{ steps.paths.outputs.build_dir }} --config ${{ inputs.build_type }} -j 4 + - name: Debug Linker Symbols + run: | + echo "=== FORTRAN SYMBOLS ===" + # Replace 'path/to/fortran_file.o' with your actual object file path + nm path/to/fortran_file.o | grep -i mshoce || echo "No symbols found" + + echo "=== C++ SYMBOLS ===" + # Replace 'path/to/cpp_file.o' with your actual object file path + nm path/to/cpp_file.o | grep -i mshoce || echo "No symbols found" + # Step: Test (portable via ctest) - name: Test timeout-minutes: 10 From 87ab5254b929c60b73d31dcac04f42a76fa68d5c Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 11:42:13 +0200 Subject: [PATCH 26/43] GRIDEDIT-2102 Attempt to fix linking error under macos --- libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp index 1921ea1e1..cf960e34d 100644 --- a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp +++ b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp @@ -36,7 +36,11 @@ extern "C" { /// \brief SEPRAN function for triangulation of a polygonal region +#ifdef __APPLE__ + extern void _mshoce( +#else extern void mshoce( +#endif const int* jnew, // Input: Reset indicator (Fortran Logical pointer) double* coor, // Output: Flattened array of node coordinates int* kmeshc, // Output: Connectivity/topology grid matrix From 3b0d684245d14242d1e05f7feca82baf7fbf0936 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 11:46:32 +0200 Subject: [PATCH 27/43] GRIDEDIT-2102 Attempt to fix linking error under macos --- libs/MeshKernel/src/TriangulationGenerator.cpp | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/libs/MeshKernel/src/TriangulationGenerator.cpp b/libs/MeshKernel/src/TriangulationGenerator.cpp index a5192c5f2..c427f471f 100644 --- a/libs/MeshKernel/src/TriangulationGenerator.cpp +++ b/libs/MeshKernel/src/TriangulationGenerator.cpp @@ -200,7 +200,12 @@ std::unique_ptr meshkernel::SepranTriangulationGenerator::ge int numberOfPoints = maximumNumberOfNodes; int numberOfElements = maximumNumberOfElements; - mshoce(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), +#ifdef __APPLE__ + _mshoce +#else + mshoce +#endif +(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), edgeNodeConnectivity.data(), boundaryConnectivity.data(), &numberOfPolygons, &numberOfPoints, &numberOfElements, holeinfo.data(), &numberOfHoles, &numberElementSizing, elementSizing.data(), userpoints.data(), &surfaceSequenceNumber, &auxiliaryAlignment, numnodextcurvs.data(), curvenumbers.data(), From dfa74ce08c68674ff6965621cf9ed568bc682b91 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 11:56:13 +0200 Subject: [PATCH 28/43] GRIDEDIT-2102 Attempt to fix linking error under macos --- .github/workflows/build-and-test-workflow.yml | 10 ---------- .../include/MeshKernel/TriangulationGenerator.hpp | 4 ---- libs/MeshKernel/src/TriangulationGenerator.cpp | 7 +------ 3 files changed, 1 insertion(+), 20 deletions(-) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index 9ce61636c..e38173039 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -165,16 +165,6 @@ jobs: - name: Build run: cmake --build ${{ steps.paths.outputs.build_dir }} --config ${{ inputs.build_type }} -j 4 - - name: Debug Linker Symbols - run: | - echo "=== FORTRAN SYMBOLS ===" - # Replace 'path/to/fortran_file.o' with your actual object file path - nm path/to/fortran_file.o | grep -i mshoce || echo "No symbols found" - - echo "=== C++ SYMBOLS ===" - # Replace 'path/to/cpp_file.o' with your actual object file path - nm path/to/cpp_file.o | grep -i mshoce || echo "No symbols found" - # Step: Test (portable via ctest) - name: Test timeout-minutes: 10 diff --git a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp index cf960e34d..1921ea1e1 100644 --- a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp +++ b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp @@ -36,11 +36,7 @@ extern "C" { /// \brief SEPRAN function for triangulation of a polygonal region -#ifdef __APPLE__ - extern void _mshoce( -#else extern void mshoce( -#endif const int* jnew, // Input: Reset indicator (Fortran Logical pointer) double* coor, // Output: Flattened array of node coordinates int* kmeshc, // Output: Connectivity/topology grid matrix diff --git a/libs/MeshKernel/src/TriangulationGenerator.cpp b/libs/MeshKernel/src/TriangulationGenerator.cpp index c427f471f..a5192c5f2 100644 --- a/libs/MeshKernel/src/TriangulationGenerator.cpp +++ b/libs/MeshKernel/src/TriangulationGenerator.cpp @@ -200,12 +200,7 @@ std::unique_ptr meshkernel::SepranTriangulationGenerator::ge int numberOfPoints = maximumNumberOfNodes; int numberOfElements = maximumNumberOfElements; -#ifdef __APPLE__ - _mshoce -#else - mshoce -#endif -(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), + mshoce(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), edgeNodeConnectivity.data(), boundaryConnectivity.data(), &numberOfPolygons, &numberOfPoints, &numberOfElements, holeinfo.data(), &numberOfHoles, &numberElementSizing, elementSizing.data(), userpoints.data(), &surfaceSequenceNumber, &auxiliaryAlignment, numnodextcurvs.data(), curvenumbers.data(), From 3a81b77549c105cd8682368422ac578cc4fbf30e Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 8 Jun 2026 12:03:52 +0200 Subject: [PATCH 29/43] GRIDEDIT-2102 Attempt to fix linking error under macos --- libs/MeshKernel/tests/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/MeshKernel/tests/CMakeLists.txt b/libs/MeshKernel/tests/CMakeLists.txt index 696b66b56..d5c192f9f 100644 --- a/libs/MeshKernel/tests/CMakeLists.txt +++ b/libs/MeshKernel/tests/CMakeLists.txt @@ -75,7 +75,7 @@ target_link_libraries( MeshKernelTestUtils gmock gtest_main - Sepran + -Wl,-force_load Sepran ) # Make sure that coverage information is produced when using gcc From ee88ae8e8cf78f0308b0750842fc2b490da80370 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Mon, 8 Jun 2026 13:25:46 +0200 Subject: [PATCH 30/43] GRIDEDIT-2102 Try to get working under macos --- .github/workflows/build-and-test-workflow.yml | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index e38173039..10aa19da5 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -47,7 +47,8 @@ jobs: - name: Install system-provided dependencies run: | brew install boost doxygen gcc libaec libomp - - name: Set Fortran compiler (macOS) + + - name: Set Fortran compiler and GCC runtime paths (macOS) if: runner.os == 'macOS' run: | GFORTRAN_BIN="$(command -v gfortran || true)" @@ -59,14 +60,20 @@ jobs: fi if [ -z "$GFORTRAN_BIN" ]; then - echo "Unable to locate a Homebrew gfortran installation" >&2 + echo "Unable to locate Homebrew gfortran" >&2 exit 1 fi + GCC_LIBDIR="$("$GFORTRAN_BIN" -print-file-name=libgfortran.dylib)" + GCC_LIBDIR="$(dirname "$GCC_LIBDIR")" + echo "Using Fortran compiler: $GFORTRAN_BIN" + echo "Using GCC runtime dir: $GCC_LIBDIR" echo "FC=$GFORTRAN_BIN" >> "$GITHUB_ENV" echo "F77=$GFORTRAN_BIN" >> "$GITHUB_ENV" echo "CMAKE_Fortran_COMPILER=$GFORTRAN_BIN" >> "$GITHUB_ENV" + echo "LDFLAGS=-L$GCC_LIBDIR ${LDFLAGS:-}" >> "$GITHUB_ENV" + echo "DYLD_LIBRARY_PATH=$GCC_LIBDIR:${DYLD_LIBRARY_PATH:-}" >> "$GITHUB_ENV" # Extract the version number (e.g., "15" from "/opt/homebrew/bin/gfortran-15") GF_VERSION="${GFORTRAN_BIN##*-}" @@ -150,6 +157,7 @@ jobs: -DCMAKE_BUILD_TYPE=${{ inputs.build_type }} \ -DCMAKE_PREFIX_PATH=${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c \ -DCMAKE_INSTALL_PREFIX=${{ steps.paths.outputs.install_dir }} \ + -DCMAKE_Fortran_COMPILER="$FC" \ $SUPPRESS_PARAM_FLAG \ -DOpenMP_C_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ -DOpenMP_CXX_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ @@ -158,8 +166,8 @@ jobs: -DOpenMP_omp_LIBRARY="$HOMEBREW_PREFIX/opt/libomp/lib/libomp.dylib" \ -DCMAKE_C_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ -DCMAKE_CXX_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ - -DCMAKE_EXE_LINKER_FLAGS="-L$HOMEBREW_PREFIX/opt/libomp/lib -lomp" \ - -DCMAKE_SHARED_LINKER_FLAGS="-L$HOMEBREW_PREFIX/opt/libomp/lib -lomp" + -DCMAKE_EXE_LINKER_FLAGS="-L$HOMEBREW_PREFIX/opt/libomp/lib -lomp -L$GCC_LIBDIR" \ + -DCMAKE_SHARED_LINKER_FLAGS="-L$HOMEBREW_PREFIX/opt/libomp/lib -lomp -L$GCC_LIBDIR" # Step: CMake build - name: Build From 718ee94d909b9de92d1f097e6b80307fe7b2192e Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Mon, 8 Jun 2026 13:30:32 +0200 Subject: [PATCH 31/43] GRIDEDIT-2102 Try to get working under macos --- .github/workflows/build-and-test-workflow.yml | 51 +++---------------- 1 file changed, 7 insertions(+), 44 deletions(-) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index 10aa19da5..ef29c1cca 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -44,46 +44,10 @@ jobs: echo "build_dir=${{ github.workspace }}/build" >> $GITHUB_OUTPUT echo "ext_deps_dir=${{ github.workspace }}/external_dependencies" >> $GITHUB_OUTPUT echo "install_dir=${{ github.workspace }}/install" >> $GITHUB_OUTPUT - - name: Install system-provided dependencies - run: | - brew install boost doxygen gcc libaec libomp - - name: Set Fortran compiler and GCC runtime paths (macOS) - if: runner.os == 'macOS' + - name: Install system-provided dependencies run: | - GFORTRAN_BIN="$(command -v gfortran || true)" - if [ -z "$GFORTRAN_BIN" ]; then - BREW_PREFIX_GFTRN="$(brew --prefix gcc)/bin" - - # 2. Look for the highest version available in that directory - GFORTRAN_BIN=$(ls "$BREW_PREFIX_GFTRN"/gfortran-* 2>/dev/null | sort -V | tail -n 1) - fi - - if [ -z "$GFORTRAN_BIN" ]; then - echo "Unable to locate Homebrew gfortran" >&2 - exit 1 - fi - - GCC_LIBDIR="$("$GFORTRAN_BIN" -print-file-name=libgfortran.dylib)" - GCC_LIBDIR="$(dirname "$GCC_LIBDIR")" - - echo "Using Fortran compiler: $GFORTRAN_BIN" - echo "Using GCC runtime dir: $GCC_LIBDIR" - echo "FC=$GFORTRAN_BIN" >> "$GITHUB_ENV" - echo "F77=$GFORTRAN_BIN" >> "$GITHUB_ENV" - echo "CMAKE_Fortran_COMPILER=$GFORTRAN_BIN" >> "$GITHUB_ENV" - echo "LDFLAGS=-L$GCC_LIBDIR ${LDFLAGS:-}" >> "$GITHUB_ENV" - echo "DYLD_LIBRARY_PATH=$GCC_LIBDIR:${DYLD_LIBRARY_PATH:-}" >> "$GITHUB_ENV" - - # Extract the version number (e.g., "15" from "/opt/homebrew/bin/gfortran-15") - GF_VERSION="${GFORTRAN_BIN##*-}" - - # Construct the exact Homebrew library path for this version - GF_LIB_DIR="$(brew --prefix gcc)/lib/gcc/$GF_VERSION" - - # Export library paths for your linker/CMake to pick up automatically - echo "LDFLAGS=-L$GF_LIB_DIR -lgfortran" >> "$GITHUB_ENV" - echo "CMAKE_EXE_LINKER_FLAGS=-L$GF_LIB_DIR -lgfortran" >> "$GITHUB_ENV" + brew install boost doxygen libaec libomp # Step: Set OpenMP environment variables (architecture-aware) - name: Set OpenMP environment variables @@ -94,7 +58,7 @@ jobs: else HOMEBREW_PREFIX="/usr/local" fi - + echo "HOMEBREW_PREFIX=$HOMEBREW_PREFIX" >> $GITHUB_ENV echo "LDFLAGS=-L$HOMEBREW_PREFIX/opt/libomp/lib" >> $GITHUB_ENV echo "CPPFLAGS=-I$HOMEBREW_PREFIX/opt/libomp/include" >> $GITHUB_ENV @@ -150,14 +114,13 @@ jobs: # Suppress unused parameter warnings on macOS 15 Intel runner (known platform-specific issue) SUPPRESS_PARAM_FLAG="-DSUPPRESS_UNUSED_PARAMETER_WARNING=ON" fi - + cmake \ -S ${{ github.workspace }} \ -B ${{ steps.paths.outputs.build_dir }} \ -DCMAKE_BUILD_TYPE=${{ inputs.build_type }} \ -DCMAKE_PREFIX_PATH=${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c \ -DCMAKE_INSTALL_PREFIX=${{ steps.paths.outputs.install_dir }} \ - -DCMAKE_Fortran_COMPILER="$FC" \ $SUPPRESS_PARAM_FLAG \ -DOpenMP_C_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ -DOpenMP_CXX_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ @@ -166,8 +129,8 @@ jobs: -DOpenMP_omp_LIBRARY="$HOMEBREW_PREFIX/opt/libomp/lib/libomp.dylib" \ -DCMAKE_C_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ -DCMAKE_CXX_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ - -DCMAKE_EXE_LINKER_FLAGS="-L$HOMEBREW_PREFIX/opt/libomp/lib -lomp -L$GCC_LIBDIR" \ - -DCMAKE_SHARED_LINKER_FLAGS="-L$HOMEBREW_PREFIX/opt/libomp/lib -lomp -L$GCC_LIBDIR" + -DCMAKE_EXE_LINKER_FLAGS="-L$HOMEBREW_PREFIX/opt/libomp/lib -lomp" \ + -DCMAKE_SHARED_LINKER_FLAGS="-L$HOMEBREW_PREFIX/opt/libomp/lib -lomp" # Step: CMake build - name: Build @@ -181,7 +144,7 @@ jobs: if [ -f "${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c/bin/libz.dylib" ]; then ln -sf libz.dylib ${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c/bin/libz.1.dylib fi - + export DYLD_LIBRARY_PATH="${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c/bin:$DYLD_LIBRARY_PATH" ctest --test-dir ${{ steps.paths.outputs.build_dir }} \ -C ${{ inputs.build_type }} \ From 1d83b8e7f95e341fa02ec65a8c4908c04d66ce9e Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Mon, 8 Jun 2026 13:33:46 +0200 Subject: [PATCH 32/43] GRIDEDIT-2102 Try to get working under macos --- .github/workflows/build-and-test-workflow.yml | 27 ++++++++++++++++--- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index ef29c1cca..8097f47dc 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -47,7 +47,25 @@ jobs: - name: Install system-provided dependencies run: | - brew install boost doxygen libaec libomp + brew install boost doxygen gcc libaec libomp + + - name: Set Fortran compiler (macOS) + if: runner.os == 'macOS' + run: | + GFORTRAN_BIN="$(command -v gfortran || true)" + if [ -z "$GFORTRAN_BIN" ]; then + HOMEBREW_PREFIX="$(brew --prefix)" + GFORTRAN_BIN="$(find "$HOMEBREW_PREFIX/bin" -maxdepth 1 -type f -name 'gfortran-*' | sort -V | tail -n 1)" + fi + + if [ -z "$GFORTRAN_BIN" ]; then + echo "Unable to locate Homebrew gfortran" >&2 + exit 1 + fi + + echo "Using Fortran compiler: $GFORTRAN_BIN" + echo "FC=$GFORTRAN_BIN" >> "$GITHUB_ENV" + echo "F77=$GFORTRAN_BIN" >> "$GITHUB_ENV" # Step: Set OpenMP environment variables (architecture-aware) - name: Set OpenMP environment variables @@ -58,7 +76,7 @@ jobs: else HOMEBREW_PREFIX="/usr/local" fi - + echo "HOMEBREW_PREFIX=$HOMEBREW_PREFIX" >> $GITHUB_ENV echo "LDFLAGS=-L$HOMEBREW_PREFIX/opt/libomp/lib" >> $GITHUB_ENV echo "CPPFLAGS=-I$HOMEBREW_PREFIX/opt/libomp/include" >> $GITHUB_ENV @@ -114,13 +132,14 @@ jobs: # Suppress unused parameter warnings on macOS 15 Intel runner (known platform-specific issue) SUPPRESS_PARAM_FLAG="-DSUPPRESS_UNUSED_PARAMETER_WARNING=ON" fi - + cmake \ -S ${{ github.workspace }} \ -B ${{ steps.paths.outputs.build_dir }} \ -DCMAKE_BUILD_TYPE=${{ inputs.build_type }} \ -DCMAKE_PREFIX_PATH=${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c \ -DCMAKE_INSTALL_PREFIX=${{ steps.paths.outputs.install_dir }} \ + -DCMAKE_Fortran_COMPILER="$FC" \ $SUPPRESS_PARAM_FLAG \ -DOpenMP_C_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ -DOpenMP_CXX_FLAGS="-Xpreprocessor -fopenmp -I$HOMEBREW_PREFIX/opt/libomp/include" \ @@ -144,7 +163,7 @@ jobs: if [ -f "${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c/bin/libz.dylib" ]; then ln -sf libz.dylib ${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c/bin/libz.1.dylib fi - + export DYLD_LIBRARY_PATH="${{ steps.paths.outputs.ext_deps_dir }}/netcdf-c/install/netcdf-c/bin:$DYLD_LIBRARY_PATH" ctest --test-dir ${{ steps.paths.outputs.build_dir }} \ -C ${{ inputs.build_type }} \ From dffe63e6ef8d994dae645a7aa13c9fadb45476ba Mon Sep 17 00:00:00 2001 From: "copilot-swe-agent[bot]" <198982749+Copilot@users.noreply.github.com> Date: Mon, 8 Jun 2026 11:38:41 +0000 Subject: [PATCH 33/43] Fix macOS gfortran discovery to include symlinks --- .github/workflows/build-and-test-workflow.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build-and-test-workflow.yml b/.github/workflows/build-and-test-workflow.yml index 8097f47dc..0b7abe707 100644 --- a/.github/workflows/build-and-test-workflow.yml +++ b/.github/workflows/build-and-test-workflow.yml @@ -55,7 +55,7 @@ jobs: GFORTRAN_BIN="$(command -v gfortran || true)" if [ -z "$GFORTRAN_BIN" ]; then HOMEBREW_PREFIX="$(brew --prefix)" - GFORTRAN_BIN="$(find "$HOMEBREW_PREFIX/bin" -maxdepth 1 -type f -name 'gfortran-*' | sort -V | tail -n 1)" + GFORTRAN_BIN="$(find "$HOMEBREW_PREFIX/bin" -maxdepth 1 \( -type f -o -type l \) -name 'gfortran-*' | sort -V | tail -n 1)" fi if [ -z "$GFORTRAN_BIN" ]; then From 4a46202e4644b3dc0d5c2b12c76df272dc0ea86f Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Wed, 10 Jun 2026 11:35:09 +0200 Subject: [PATCH 34/43] GRIDEDIT-2102 Added c++ conversion of the fortran Sepran code This contains a conversion of the SEPRAN Fortran code to c++ using Claude Sonnet. Current it computes a slightly different triangulation that the original fortran code. --- extern/sepran/CMakeLists.txt | 84 +- extern/sepran/Msho2d.cpp | 1025 +++++++ extern/sepran/Msho2d.hpp | 79 + extern/sepran/Mshoce.cpp | 198 ++ extern/sepran/Mshoce.hpp | 72 + extern/sepran/SepranBoundary.cpp | 189 ++ extern/sepran/SepranBoundary.hpp | 68 + extern/sepran/SepranContext.hpp | 41 + extern/sepran/SepranCurveIntersection.cpp | 171 ++ extern/sepran/SepranCurveIntersection.hpp | 78 + extern/sepran/SepranFront.cpp | 2467 +++++++++++++++++ extern/sepran/SepranFront.hpp | 386 +++ extern/sepran/SepranGeometry.cpp | 205 ++ extern/sepran/SepranGeometry.hpp | 72 + extern/sepran/SepranQuadratic.cpp | 445 +++ extern/sepran/SepranQuadratic.hpp | 62 + extern/sepran/SepranSort.cpp | 84 + extern/sepran/SepranSort.hpp | 22 + extern/sepran/SepranTopology.cpp | 301 ++ extern/sepran/SepranTopology.hpp | 130 + extern/sepran/SepranTransform.cpp | 100 + extern/sepran/SepranTransform.hpp | 71 + libs/MeshKernel/CMakeLists.txt | 1 + .../MeshKernel/TriangulationGenerator.hpp | 35 - .../MeshKernel/src/TriangulationGenerator.cpp | 35 +- libs/MeshKernel/tests/CMakeLists.txt | 1 - libs/MeshKernel/tests/src/MeshTests.cpp | 29 +- 27 files changed, 6335 insertions(+), 116 deletions(-) create mode 100644 extern/sepran/Msho2d.cpp create mode 100644 extern/sepran/Msho2d.hpp create mode 100644 extern/sepran/Mshoce.cpp create mode 100644 extern/sepran/Mshoce.hpp create mode 100644 extern/sepran/SepranBoundary.cpp create mode 100644 extern/sepran/SepranBoundary.hpp create mode 100644 extern/sepran/SepranContext.hpp create mode 100644 extern/sepran/SepranCurveIntersection.cpp create mode 100644 extern/sepran/SepranCurveIntersection.hpp create mode 100644 extern/sepran/SepranFront.cpp create mode 100644 extern/sepran/SepranFront.hpp create mode 100644 extern/sepran/SepranGeometry.cpp create mode 100644 extern/sepran/SepranGeometry.hpp create mode 100644 extern/sepran/SepranQuadratic.cpp create mode 100644 extern/sepran/SepranQuadratic.hpp create mode 100644 extern/sepran/SepranSort.cpp create mode 100644 extern/sepran/SepranSort.hpp create mode 100644 extern/sepran/SepranTopology.cpp create mode 100644 extern/sepran/SepranTopology.hpp create mode 100644 extern/sepran/SepranTransform.cpp create mode 100644 extern/sepran/SepranTransform.hpp diff --git a/extern/sepran/CMakeLists.txt b/extern/sepran/CMakeLists.txt index d2bc3bedb..34bc12d76 100644 --- a/extern/sepran/CMakeLists.txt +++ b/extern/sepran/CMakeLists.txt @@ -1,4 +1,5 @@ -enable_language(Fortran) +# C++20 translation of the SEPRAN mesh-generation library. +# Replaces the original Fortran sources. set(target_name Sepran) @@ -6,81 +7,28 @@ add_library(${target_name} STATIC) set( TARGET_SRC_LIST - chsort.for - mshconstants.f90 - mshdummymethods.f90 - msh401.for - msh402.for - msh403.for - msh406.for - msh416.for - mshchkstapl.for - mshcopyboun.for - mshcrossline.for - mshcrossline1.for - mshcurvinters.for - mshcurvinters1.for - mshcurvinters2.for - msho01.for - msho02.for - msho03.for - msho04.for - msho05.for - msho06.for - msho07.for - msho08.for - msho09.for - msho10.for - msho11.for - msho12.for - msho13.for - msho14.for - msho15.for - msho16.for - msho17.for - msho18.for - msho19.for - msho20.for - msho21.for - msho22.for - msho24.for - msho25.for - msho26.for - msho27.for - msho28.for - msho29.for - msho2d.for - msho30.for - msho31.for - msho32.for - msho33.for - msho34.for - msho35.for - msho36.for - msho38.for - msho39.for - msho40.for - msho41.for - msho42.for - msho75.for - mshoce.for - mshtrans2dsur.for + SepranSort.cpp + SepranGeometry.cpp + SepranCurveIntersection.cpp + SepranBoundary.cpp + SepranTransform.cpp + SepranTopology.cpp + SepranFront.cpp + SepranQuadratic.cpp + Msho2d.cpp + Mshoce.cpp ) target_sources(${target_name} PRIVATE ${TARGET_SRC_LIST}) +target_include_directories(${target_name} PUBLIC ${CMAKE_CURRENT_SOURCE_DIR}) + +target_compile_features(${target_name} PUBLIC cxx_std_20) + set_target_properties( ${target_name} PROPERTIES POSITION_INDEPENDENT_CODE ON - Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/modules ) -if(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") - target_compile_options(${target_name} PRIVATE -w) - target_link_libraries(${target_name} INTERFACE gfortran) -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") - target_compile_options(${target_name} PRIVATE -w) -endif() - source_group("Source Files" FILES ${TARGET_SRC_LIST}) \ No newline at end of file diff --git a/extern/sepran/Msho2d.cpp b/extern/sepran/Msho2d.cpp new file mode 100644 index 000000000..5b42d37fb --- /dev/null +++ b/extern/sepran/Msho2d.cpp @@ -0,0 +1,1025 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of msho2d.for from the SEPRAN library +// ("Ingenieursbureau SEPRA", Niek Praagman, 1989-2011). +// +// TRANSLATION CONVENTIONS (flat-span layout): +// coor : coor[2*(k-1)] = x, coor[2*(k-1)+1] = y (1-based k) +// kstapl : kstapl[2*s]=n1, kstapl[2*s+1]=n2 (0-based s) +// kmeshc : kmeshc[3*e], [3*e+1], [3*e+2] (0-based e, 1-based node values) +// itri : itri[k-1] (1-based k) +// boundary: boundary[2*i]=curveNr, boundary[2*i+1]=startAddr (0-based i) +// kbound : kbound[2*e]=n1, kbound[2*e+1]=n2 (0-based e, 1-based node values) + +#include "Msho2d.hpp" + +#include "SepranBoundary.hpp" +#include "SepranCurveIntersection.hpp" +#include "SepranFront.hpp" +#include "SepranGeometry.hpp" +#include "SepranSort.hpp" +#include "SepranTopology.hpp" +#include "SepranTransform.hpp" + +#include +#include +#include +#include +#include + +namespace sepran +{ + +void msho2d(std::span coor, + int& npoint, + std::span kbound, + int nbound, + std::span kmeshc, + int& nelem, + std::span boundary, + int numcrvboun, + int npunt, + int inside, + std::span holeinfo, + int nholes, + bool reposition, + std::span kbndpt_in, + int nbndpt_in, + std::span coar, + int ncoar, + std::span userpoints, + std::span cocurv, + int ncurvs, + std::span curves, + std::span crvnrs, + int istep, + std::span extquanodes, + int isurnr, + std::span rinput, + int nuspnt, + int ndim, + SepranContext& ctx) +{ + (void)crvnrs; + + // --- Allocate local work arrays + const int maxPts = npunt + 20; + const int maxKstap = 10 * maxPts + 20; + + std::vector chelp (maxPts, 0.0); + std::vector icube (maxPts, 0); + std::vector itriArr (maxPts, 0); + std::vector kstaplArr(maxKstap, 0); + + // mutable kbndpt (may be extended by msho36) + std::vector kbndptArr(kbndpt_in.begin(), kbndpt_in.end()); + kbndptArr.resize(maxPts + 2, 0); + int nbndpt = nbndpt_in; + + // Alias spans for helpers + auto kstaplSp = std::span(kstaplArr); + auto kbndptSp = std::span(kbndptArr); + auto itri = std::span(itriArr); + auto chelpSp = std::span(chelp); + auto icubeSp = std::span(icube); + + // --- Fill userco and coaval from rinput + std::vector userco(2 * nuspnt, 0.0); + std::vector coaval(2 + nuspnt, 0.0); + + for (int i = 1; i <= nuspnt; ++i) + { + userco[2*(i-1)] = rinput[1 + ndim*i]; // rinput(1+ndim*i) + userco[2*(i-1)+1] = rinput[2 + ndim*i]; // rinput(2+ndim*i) + } + + // jcoars = 0 (AvD: no coarseness from rinput by default) + coaval[0] = 1.0; + + // --- Transform all nodes into the unit first-quadrant + double xmint = 0.0, ymint = 0.0, tran = 1.0; + { + const int totalCurvNodes = [&](){ + int s = 0; for (int i = 0; i < ncurvs; ++i) s += curves[i]; return s; + }(); + // transform2DSurface needs mutable coar/cocurv/userco – convert to mutable + std::vector coarMut(coar.begin(), coar.end()); + std::vector cocurvMut(cocurv.begin(), cocurv.end()); + std::vector usercoMut(userco.begin(), userco.end()); + TransformParams tp = transform2DSurface( + coor, npoint, + std::span(coarMut), ncoar, + curves, ncurvs, + std::span(cocurvMut), + std::span(usercoMut), + nuspnt, + ctx); + xmint = tp.xmint; ymint = tp.ymint; tran = tp.tran; + (void)totalCurvNodes; + } + if (ctx.ierror != 0) return; + + // --- Compute boundary coarsenesses + double coarsemin = 0.0, coarsemax = 0.0; + // msho01 expects mutable coar + std::vector coarMsho01(coar.begin(), coar.end()); + msho01(kbound, nbound, itri, kstaplSp, chelpSp, coor, npoint, + coarsemin, coarsemax, std::span(coarMsho01), ncoar, ctx); + if (ctx.ierror != 0) return; + + // --- Check boundary self-intersections + boundarySelfIntersectionCheck(kbound, nbound, coor, isurnr, ctx); + if (ctx.ierror != 0) return; + + // --- Build initial kstapl from kbound + int kstap = nbound; + for (int i = 0; i < 2 * nbound; ++i) + kstaplArr[i] = kbound[i]; + + // --- Number of initial boundary nodes (before internal curves) + int nipnt = npoint; + + // --- Add internal curve nodes + if (ncurvs > 0) + { + // coaval[0] already set; cast const away for coarse param (will be updated) + std::vector coarseArr(chelpSp.begin(), chelpSp.end()); + + msho36(coor, npoint, istep, ncurvs, curves, cocurv, + kstaplSp, kstap, + kbndptSp, nbndpt, + coarsemin, + extquanodes, + std::span(coarseArr), + ctx); + + // Copy updated coarsenesses back + std::copy(coarseArr.begin(), coarseArr.end(), chelp.begin()); + + if (ctx.ierror != 0) return; + + // Re-check intersections + boundarySelfIntersectionCheck(kstaplSp.subspan(0, 2 * kstap), kstap, coor, isurnr, ctx); + if (ctx.ierror != 0) return; + } + + // --- Save all boundary pieces for later (kinbnd) + const int lenbnd = 2 * kstap; + std::vector kinbnd(kstaplArr.begin(), kstaplArr.begin() + lenbnd); + + // --- Multiplication factor for search window + (void)std::max(1, static_cast( + std::round(std::log10(std::max(coarsemax / coarsemin, 1.0 + ctx.epsmac))))); + + // --- Bounding box + double xminloc, xmaxloc, yminloc, ymaxloc; + msho04(coor, npoint, xminloc, xmaxloc, yminloc, ymaxloc, ctx); + if (ctx.ierror != 0) return; + + // --- Min/max coarsenesses (boundary nodes only) + double dismin, dismax; + msho05(chelpSp, nipnt, dismin, dismax, ctx); + if (ctx.ierror != 0) return; + + // --- Grid dimensions + const double dism = (dismax + 2.0 * dismin) / 3.0; + const int nx = static_cast((xmaxloc - xminloc) / (0.9998 * dism)) + 1; + const int ny = static_cast((ymaxloc - yminloc) / (0.9998 * dism)) + 1; + const int ncube = nx * ny; + + std::vector jcube(ncube, 0); + std::vector cubeArr(ncube, 0.0); + + double xstart = (xmaxloc + xminloc - nx * dism) / 2.0 + dism / 12.0; + double ystart = (ymaxloc + yminloc - ny * dism) / 2.0 + dism / 12.0; + + // --- Build coarseness grid + msho06(npoint, coor, dism, xstart, ystart, nx, ny, + icubeSp, chelpSp, + std::span(cubeArr), std::span(jcube), + kbound, nbound, + coar, ncoar, + ncurvs, curves, cocurv, + ctx); + + // --- Coarseness smoothness check + if (ndim == 2 && coaval[nuspnt + 1] > 1.0) + { + msho38(npoint, coor, dism, xstart, ystart, + kbndptSp, nbndpt, + numcrvboun, boundary, + nbound, nholes, + nx, ny, + icubeSp, + chelpSp, + std::span(cubeArr), + std::span(jcube), + kstaplSp, kstap, + ncurvs, curves, cocurv, + isurnr, + std::span(userco), + nuspnt, + std::span(coaval), + tran, + ctx); + } + if (ctx.ierror != 0) return; + + // --- Compute reference area values per cube cell + // Reuse chelp (now sized ncube) + chelp.assign(ncube, 0.0); + msho21(std::span(cubeArr), ncube, chelpSp); + if (ctx.ierror != 0) return; + + // --- After msho21, nipnt covers all initial+internal-curve points + nipnt = npoint; + + // --- Clear itri + for (auto& v : itriArr) v = 0; + + // --- Fill itri from current kstapl + for (int i = 0; i < 2 * kstap; ++i) + itriArr[kstaplArr[i] - 1]++; // 1-based node + + nelem = 0; + int nelemi = 0; // number of elements from special nodes + + // --- Place special coarseness-point nodes and elements + double coarmin = coarsemin; + if (ncoar > 0) + { + msho35(npoint, coor, xstart, ystart, dism, + coar, ncoar, icubeSp, nx, + kmeshc, nelem, + kstaplSp, kstap, + itri, + isurnr, userpoints, + kbndptSp, nbndpt, + ctx); + if (ctx.ierror != 0) return; + + nipnt += 7 * ncoar; + nelemi = nelem; + + for (int i = 0; i < ncoar; ++i) + if (coar[3*i+2] < coarmin) coarmin = coar[3*i+2]; + } + + // --- Orient front edges + msho08(kstaplSp, kstap, coor, xstart, dismin, + holeinfo, nholes, false, ctx); + if (ctx.ierror != 0) return; + + // ------------------------------------------------------------------- + // Main advancing-front loop + // ------------------------------------------------------------------- + int nochan = 0; + int nherha = 0; + int iperm = 0; + + // Temporaries for best-mesh bookkeeping + int npntmp = 0, neltmp = 0; + int npndef = 0, neldef = 0; + double ratiop = ctx.rinfin; + std::vector coortmp; + std::vector meshtmp; + bool firstSolution = true; + + const double eps = 10.0 * ctx.epsmac; + + // Helper: compute quality ratio for mesh comparison + auto computeDismin = [&]() -> double + { + double dmin = ctx.rinfin; + for (int ie = 0; ie < nelem; ++ie) + { + const int a = kmeshc[3*ie], b = kmeshc[3*ie+1], c = kmeshc[3*ie+2]; + double ratio; + msho33(coor, ratio, a, b, c); + double surf; + surf = triangleArea(coor, a, b, c); + if (surf < 0.0) ratio = -ratio; + dmin = std::min(ratio, dmin); + } + return dmin; + }; + + // ---- label 300: main iteration ---- + int dbg_newNode = 0, dbg_useExist = 0, dbg_kdrie = 0, dbg_skip = 0; + int dbg_jpnFoundTooFar = 0, dbg_jpnNotFound = 0; + auto advanceFront = [&]() -> bool // returns false when done or error + { + const int nrepos = 10 * npunt + 20; + + // Local iwork/ibuurp for msho16 & msho29 + std::vector iworkArr(maxPts, 0); + std::vector ibuurpArr(nrepos, 0); + + for (;;) // loop equivalent to Fortran "goto 300" + { + // ---- section 300 ---- + int ichan; + if (nochan < kstap - 1) + ichan = std::min(25, kstap - nochan - 1); + else + ichan = 0; + + if (npoint > npunt) + { + ctx.ierror = 1; + throw std::runtime_error( + "msho2d: npunt=" + std::to_string(npunt) + + " exceeded (npoint=" + std::to_string(npoint) + ") (error 900)"); + } + + if (nelem > 2000000) + { + ctx.ierror = 1; + throw std::runtime_error("msho2d: element array too small (error 901)"); + } + + if (nochan > 3 * kstap) + { + ctx.ierror = 1; + throw std::runtime_error( + "msho2d: no convergence, nochan=" + std::to_string(nochan) + + ", kstap=" + std::to_string(kstap) + " (error 902)"); + } + + if (kstap == 0) return true; // done + + if (ichan > 0) + msho25(kstaplSp, ichan, coor, ctx); + + double angle = -0.1; + [[maybe_unused]] double factor = 1.0; + + if (nochan > 10 || nochan > kstap) { angle = -0.7; factor = 0.6; } + if (nochan > 2 * kstap) { angle = -0.95; factor = 0.5; } + + // ---- pick base edge ---- + const int i1 = kstaplArr[0]; + const int i2 = kstaplArr[1]; + + itriArr[i1 - 1]--; + itriArr[i2 - 1]--; + + // ---- find neighbouring front edges ---- + int iex1, iex2; + double angle1, angle2; + msho12(coor, kstaplSp, kstap, i1, i2, iex1, iex2, angle1, angle2, ctx); + if (ctx.ierror != 0) return false; + + // ---- kstap==4 / "difficult combination" special case (msho2d.for ~1092-1117) ---- + { + int ja = 0; + if (nochan > kstap && kstap > 4) + { + int j1 = 0, j2 = 0; + double e1loc = 0.0, e2loc = 0.0; + msho12(coor, kstaplSp, kstap, iex1, i1, j1, j2, e1loc, e2loc, ctx); + if (ctx.ierror != 0) return false; + if (j1 == iex2) ja = 1; + } + + if (kstap == 4 || ja == 1) + { + const double s1 = triangleArea(coor, iex1, i1, i2); + const double s2 = triangleArea(coor, i2, iex2, iex1); + + if (s1 < 0.0 || s2 < 0.0) + { + const double stmp = triangleArea(coor, i1, i2, iex2); + if (stmp > 0.0) + { + addElement(kmeshc, nelem, i1, i2, iex2, kstaplSp, kstap, itri); + nochan = 0; + continue; + } + } + } + } + + const double surfInf = ctx.rinfin; + + // ---- iex1==iex2? ---- + int ipotn1 = 0, ipotn2 = 0; + double surf1 = 0.0, surf2 = 0.0; + double xnLocal = 0.0, ynLocal = 0.0; + + if (iex1 == iex2) + { + double surf; + surf = triangleArea(coor, i1, i2, iex1); + iperm = 0; + if (inside == 1) + msho28(coor, i1, i2, iex1, xnLocal, ynLocal, npoint, itri, iperm, ctx); + + if (surf >= 0.0 && iperm == 0) + { + addElement(kmeshc, nelem, i1, i2, iex1, kstaplSp, kstap, itri); + nochan = 0; continue; + } + if (surf <= 0.0 && kstap == 3) + { + addElement(kmeshc, nelem, i1, i2, iex1, kstaplSp, kstap, itri); + nochan = 0; continue; + } + } + + // ---- check angles ---- + surf1 = triangleArea(coor, i1, i2, iex1); + if (surf1 < eps) { angle1 = -1.0; ipotn1 = 1; } else ipotn1 = 0; + surf2 = triangleArea(coor, i1, i2, iex2); + if (surf2 < eps) { angle2 = -1.0; ipotn2 = 1; } else ipotn2 = 0; + + if (angle1 > angle && angle2 >= angle1) + { + double angleh; + msho11(i1, iex1, iex2, coor, angleh, ctx); + if (angleh < -0.5) + { + // try i1-i2-iex1 + double stest = triangleArea(coor, i2, iex2, iex1); + int ja = (stest >= 100.0 * eps) ? 1 : 0; + iperm = 0; + if (ja == 1) msho28(coor, i1, i2, iex1, xnLocal, ynLocal, npoint, itri, iperm, ctx); + if (ja == 1 && iperm == 0) + { + int icheck; + msho24(kstaplSp, kstap, coor, i2, iex1, icheck, ctx); + if (icheck == 0) + { addElement(kmeshc, nelem, i1, i2, iex1, kstaplSp, kstap, itri); nochan=0; continue; } + } + else surf1 = surfInf; + } + else + { + // try i1-i2-iex2 + double stest = triangleArea(coor, i1, i2, iex2); + int ja = (stest >= 100.0 * eps) ? 1 : 0; + iperm = 0; + if (ja == 1) msho28(coor, i1, i2, iex2, xnLocal, ynLocal, npoint, itri, iperm, ctx); + if (ja == 1 && iperm == 0) + { + int icheck; + msho24(kstaplSp, kstap, coor, i1, iex2, icheck, ctx); + if (icheck == 0) + { addElement(kmeshc, nelem, i1, i2, iex2, kstaplSp, kstap, itri); nochan=0; continue; } + } + else surf2 = surfInf; + } + } + if (ctx.ierror != 0) return false; + if (surf1 < eps) surf1 = surfInf; + + if (angle2 > angle && angle1 >= angle2) + { + double angleh; + msho11(i2, iex2, iex1, coor, angleh, ctx); + if (angleh < -0.5) + { + // try i1-i2-iex2 + double stest = triangleArea(coor, i1, iex2, iex1); + int ja = (stest >= 100.0 * eps) ? 1 : 0; + iperm = 0; + if (ja == 1) msho28(coor, i1, i2, iex2, xnLocal, ynLocal, npoint, itri, iperm, ctx); + if (ja == 1 && iperm == 0) + { + int icheck; + msho24(kstaplSp, kstap, coor, i1, iex2, icheck, ctx); + if (icheck == 0) + { addElement(kmeshc, nelem, i1, i2, iex2, kstaplSp, kstap, itri); nochan=0; continue; } + } + else surf2 = surfInf; + } + else + { + // try i1-i2-iex1 + double stest = triangleArea(coor, i1, i2, iex1); + int ja = (stest >= 100.0 * eps) ? 1 : 0; + iperm = 0; + if (ja == 1) msho28(coor, i1, i2, iex1, xnLocal, ynLocal, npoint, itri, iperm, ctx); + if (ja == 1 && iperm == 0) + { + int icheck; + msho24(kstaplSp, kstap, coor, i2, iex1, icheck, ctx); + if (icheck == 0) + { addElement(kmeshc, nelem, i1, i2, iex1, kstaplSp, kstap, itri); nochan=0; continue; } + } + else surf1 = surfInf; + } + } + if (ctx.ierror != 0) return false; + if (surf2 < eps) surf2 = surfInf; + + // ---- midpoint + normal ---- + double e1, e2, xm, ym; + msho09(coor, i1, i2, e1, e2, xm, ym); + + const double dx = coor[2*(i2-1)] - coor[2*(i1-1)]; + const double dy = coor[2*(i2-1)+1] - coor[2*(i1-1)+1]; + double disold = std::sqrt(dx*dx + dy*dy); + + const int ic1 = icubeSp[i1-1]; + const int ic2 = icubeSp[i2-1]; + // Initial coarseness estimate (Fortran: coa = (cube(icube(i1))+cube(icube(i2)))/2) + double coa = ((ic1 >= 1 && ic1 <= ncube ? cubeArr[ic1-1] : dismin) + + (ic2 >= 1 && ic2 <= ncube ? cubeArr[ic2-1] : dismin)) / 2.0; + // Fortran: disold = (disold + 2*coa)/3 — modifies disold as weighted average + disold = (disold + 2.0 * coa) / 3.0; + + double xnNew = xm + 0.95 * disold * e1; + double ynNew = ym + 0.95 * disold * e2; + + int n1c = static_cast((xnNew - xstart) / dism); + int n2c = static_cast((ynNew - ystart) / dism); + n1c = std::clamp(n1c, 0, nx - 1); + n2c = std::clamp(n2c, 0, ny - 1); + const int nc = 1 + n1c + n2c * nx; + + const double cdis = (nc >= 1 && nc <= ncube) ? cubeArr[nc-1] : dismin; + + // Fortran: computes xnx/yny after reassigning coa = (disold+2*cdis)/3. + // (Saving pre-reassignment coa as coaInit gives closer match to Fortran output.) + const double coaInit = coa; + // Reassign coa for front-point estimate + coa = (disold + 2.0 * cdis) / 3.0; + xnNew = xm + coa * e1; + ynNew = ym + coa * e2; + + double xnxLocal, ynyLocal; + if (cdis > 1.2 * disold) { xnxLocal = xm + coaInit*e1; ynyLocal = ym + coaInit*e2; } + else if (cdis < 0.8*disold) { xnxLocal = xm + 0.7*coaInit*e1; ynyLocal = ym + 0.7*coaInit*e2; } + else { xnxLocal = xm + 0.85*coaInit*e1; ynyLocal = ym + 0.85*coaInit*e2; } + + int ja = 0; + msho07(xnNew, ynNew, xstart, coor, kstaplSp.subspan(0, 2*kstap), kstap, ja, ctx); + if (ctx.ierror != 0) return false; + + int kdrie = 0; + msho13(coor, i1, i2, kdrie, kstaplSp, kstap, xnNew, ynNew, ctx); + + if (kdrie == -1) + { msho20(kstaplSp, kstap, itri); nochan++; continue; } + if (ctx.ierror != 0) return false; + + if (ja == 0 && kdrie == 0) + { + // try a small offset + xnNew += -dismin * 1e-3 + dismin * 1e-4; + ynNew += dismin * 1e-3 + dismin * 1e-4; + ja = 0; + msho07(xnNew, ynNew, xstart, coor, kstaplSp.subspan(0, 2*kstap), kstap, ja, ctx); + msho13(coor, i1, i2, kdrie, kstaplSp, kstap, xnNew, ynNew, ctx); + if ((ja == 0 && kdrie == 0) || kdrie == -1) + { msho20(kstaplSp, kstap, itri); nochan++; continue; } + } + if (ctx.ierror != 0) return false; + + // ---- loop 420: use existing front point ---- + while (kdrie > 0) + { + const int ii1 = kstaplArr[2*(kdrie-1)]; + const int ii2 = kstaplArr[2*(kdrie-1)+1]; + + int jpn = 0; + + if (ii1 == i2 && surf2 < surfInf / 2.0) + { + double stest = triangleArea(coor, i1, iex1, ii2); + if (stest < -eps || ipotn1 == 1) + { + int icheck; + msho24(kstaplSp, kstap, coor, i1, ii2, icheck, ctx); + double sf = triangleArea(coor, i1, i2, ii2); + if (icheck == 0 && sf > eps) + { addElement(kmeshc, nelem, i1, i2, ii2, kstaplSp, kstap, itri); nochan=0; goto next300; } + else if (icheck > 0) { kdrie = icheck; continue; } + } + } + + if (ii2 == i1 && surf1 < surfInf / 2.0) + { + double stest = triangleArea(coor, i2, ii1, iex2); + if (stest < -eps || ipotn2 == 1) + { + int icheck; + msho24(kstaplSp, kstap, coor, i2, ii1, icheck, ctx); + double sf = triangleArea(coor, i1, i2, ii1); + if (icheck == 0 && sf > eps) + { addElement(kmeshc, nelem, i1, i2, ii1, kstaplSp, kstap, itri); nochan=0; goto next300; } + else if (icheck > 0) { kdrie = icheck; continue; } + } + } + + if (ctx.ierror != 0) return false; + + if (i2 != ii1 && i1 != ii2) + { + // pick closer of ii1, ii2 + const double dx1 = xnxLocal - coor[2*(ii1-1)], dy1 = ynyLocal - coor[2*(ii1-1)+1]; + const double dx2 = xnxLocal - coor[2*(ii2-1)], dy2 = ynyLocal - coor[2*(ii2-1)+1]; + double dist1 = std::sqrt(dx1*dx1 + dy1*dy1); + double dist = std::sqrt(dx2*dx2 + dy2*dy2); + jpn = (dist < dist1) ? ii2 : ii1; + + // visibility check + int no = 0; + { int ic; msho24(kstaplSp, kstap, coor, i1, jpn, ic, ctx); if (ic != 0) no = 1; } + { int ic; msho24(kstaplSp, kstap, coor, i2, jpn, ic, ctx); if (ic != 0) no = 1; } + if (no) jpn = 0; + + if (jpn != 0 && jpn != iex1 && ipotn1 == 0 && nochan < kstap) + { + double sf = triangleArea(coor, iex1, i1, jpn); + double va = ic1 >= 1 && ic1 <= ncube ? chelp[ic1-1] : 0.0; + if (sf < 0.15 * va) { msho20(kstaplSp, kstap, itri); nochan++; goto next300; } + } + if (jpn != 0 && jpn != iex2 && ipotn2 == 0 && nochan < kstap) + { + double sf = triangleArea(coor, i2, iex2, jpn); + double va = ic2 >= 1 && ic2 <= ncube ? chelp[ic2-1] : 0.0; + if (sf < 0.15 * va) { msho20(kstaplSp, kstap, itri); nochan++; goto next300; } + } + } + + if (jpn > 0) + { + double sf = triangleArea(coor, i1, i2, jpn); + const double va = ((ic1 >= 1 && ic1 <= ncube ? chelp[ic1-1] : 0.0) + + (ic2 >= 1 && ic2 <= ncube ? chelp[ic2-1] : 0.0)) / 2.0; + if ((nochan < kstap && sf < 0.01 * va) || sf < 10.0 * eps) jpn = 0; + if (jpn == iex1 && surf1 > surfInf / 2.0) jpn = 0; + if (jpn == iex2 && surf2 > surfInf / 2.0) jpn = 0; + } + + iperm = 0; + if (jpn > 0) msho28(coor, i1, i2, jpn, xnLocal, ynLocal, npoint, itri, iperm, ctx); + if (iperm == 1) jpn = 0; + + if (jpn > 0) + { ++dbg_kdrie; addElement(kmeshc, nelem, i1, i2, jpn, kstaplSp, kstap, itri); nochan = 0; goto next300; } + else + { ++dbg_skip; msho20(kstaplSp, kstap, itri); nochan++; goto next300; } + } + + // ---- kdrie==0: try to use nearby node or create new one ---- + { + int jpn = 0; + double dista = 2.0 * coa; + msho14(coor, jpn, npoint, itri, i1, i2, xnxLocal, ynyLocal, dista); + if (dista > 0.55 * coa) { if (jpn > 0) ++dbg_jpnFoundTooFar; else ++dbg_jpnNotFound; jpn = 0; } + + iperm = 0; + if (jpn != 0 && inside == 1) + msho28(coor, i1, i2, jpn, xnLocal, ynLocal, npoint, itri, iperm, ctx); + if (iperm == 1) { msho20(kstaplSp, kstap, itri); nochan++; continue; } + + if (jpn != 0 && jpn != iex1 && ipotn1 == 0) + { + double sf = triangleArea(coor, iex1, i1, jpn); + double va = ic1 >= 1 && ic1 <= ncube ? chelp[ic1-1] : 0.0; + if (sf < 0.15 * va) { msho20(kstaplSp, kstap, itri); nochan++; continue; } + } + if (jpn != 0 && jpn != iex2 && ipotn2 == 0) + { + double sf = triangleArea(coor, i2, iex2, jpn); + double va = ic2 >= 1 && ic2 <= ncube ? chelp[ic2-1] : 0.0; + if (sf < 0.15 * va) { msho20(kstaplSp, kstap, itri); nochan++; continue; } + } + + int inear = 0, no = 0; + if (dista < 0.55 * coa) + { + inear = 1; + int ic; msho24(kstaplSp, kstap, coor, i1, jpn, ic, ctx); if (ic) no = 1; + msho24(kstaplSp, kstap, coor, i2, jpn, ic, ctx); if (ic) no = 1; + } + + int useJpn = 0; + if (jpn != 0) + { + double sf = triangleArea(coor, i1, i2, jpn); + double va = ((ic1 >= 1 && ic1 <= ncube ? chelp[ic1-1] : 0.0) + + (ic2 >= 1 && ic2 <= ncube ? chelp[ic2-1] : 0.0)) / 2.0; + useJpn = (!(nochan < kstap && sf < 0.02 * va) && sf >= 10.0 * eps) ? 1 : 0; + } + if (no) useJpn = 0; + + if (useJpn == 0) dista = surfInf; + + if (dista < 0.55 * coa) + { + ++dbg_useExist; + addElement(kmeshc, nelem, i1, i2, jpn, kstaplSp, kstap, itri); + nochan = 0; + } + else if (inear == 0) + { + // new point + ++dbg_newNode; + msho15(coor, npoint, kmeshc, nelem, kstaplSp, kstap, itri, + i1, i2, xnxLocal, ynyLocal); + nochan = 0; + + n1c = static_cast((xnxLocal - xstart) / dism); + n2c = static_cast((ynyLocal - ystart) / dism); + n1c = std::clamp(n1c, 0, nx - 1); + n2c = std::clamp(n2c, 0, ny - 1); + icubeSp[npoint - 1] = 1 + n1c + n2c * nx; + } + else + { + msho20(kstaplSp, kstap, itri); nochan++; + } + } + + next300: + if (ctx.ierror != 0) return false; + // loop + } + + return true; // kstap == 0 + }; + + bool done = advanceFront(); + if (!done || ctx.ierror != 0) return; + + auto verifyConnectionsArray = [&]() + { + int itot = 0; + for (int i = 0; i < npoint; ++i) itot += std::abs(itriArr[i]); + if (itot != 0) + { + ctx.ierror = 1; + throw std::runtime_error("msho2d: connections array error (error 903)"); + } + }; + + // ---- label 500: check itri ---- + verifyConnectionsArray(); + + // ---- Save first solution ---- + if (firstSolution) + { + firstSolution = false; + npndef = npoint + 5 + npoint / 10; + npntmp = npoint; + neldef = nelem + 5 + nelem / 10; + neltmp = nelem; + + coortmp.resize(2 * npndef); + meshtmp.resize(3 * neldef); + for (int i = 0; i < npoint; ++i) + { coortmp[2*i] = coor[2*i]; coortmp[2*i+1] = coor[2*i+1]; } + for (int i = 0; i < nelem; ++i) + { meshtmp[3*i]=kmeshc[3*i]; meshtmp[3*i+1]=kmeshc[3*i+1]; meshtmp[3*i+2]=kmeshc[3*i+2]; } + ratiop = computeDismin(); + } + + // ---- label 540: post-processing loop (matches Fortran structure) ---- + // Each iteration: 3x (msho16 + msho29 compact), diagonal improvement, + // compare/save, repositioning (msho16). Repeat until nherha>=5 and ja==0 and ifill==0. + const int nrepos = 10 * npunt + 20; + std::vector iworkPost(maxPts, 0); + std::vector ibuurpPost(nrepos, 0); + + auto compactMesh = [&]() + { + for (int i = 0; i < npoint; ++i) itriArr[i] = 0; + for (int i = 0; i < nelem; ++i) + { itriArr[kmeshc[3*i]-1]=1; itriArr[kmeshc[3*i+1]-1]=1; itriArr[kmeshc[3*i+2]-1]=1; } + int itot = 0; + for (int i = 0; i < npoint; ++i) + { + if (itriArr[i] == 1 || i < nipnt) + { + ++itot; + coor[2*(itot-1)] = coor[2*i]; + coor[2*(itot-1)+1] = coor[2*i+1]; + itriArr[i] = itot; + } + } + npoint = itot; + for (int i = 0; i < nelem; ++i) + { + kmeshc[3*i] = itriArr[kmeshc[3*i]-1]; + kmeshc[3*i+1] = itriArr[kmeshc[3*i+1]-1]; + kmeshc[3*i+2] = itriArr[kmeshc[3*i+2]-1]; + } + }; + + int ifill = 0; + while (true) // label 540 + { + // Inner loop: 3 × (msho16 + msho29 + compact) + for (int ih = 0; ih < 3; ++ih) + { + int leng = nrepos; + msho16(kmeshc, nelem, npoint, nipnt, iworkPost, ibuurpPost, leng, ctx); + if (leng > nrepos) + { ctx.ierror = 1; throw std::runtime_error("msho2d: repositioning array too small (error 903)"); } + if (ctx.ierror != 0) return; + + int icancel = 0; + msho29(kmeshc, nelem, npoint, iworkPost, ibuurpPost, nipnt, coor, icancel); + if (ctx.ierror != 0) return; + compactMesh(); + } + + // Diagonal improvement + ifill = 0; + for (int ielem = nelemi; ielem < nelem; ++ielem) + { + int i1 = kmeshc[3*ielem], i2 = kmeshc[3*ielem+1], i3 = kmeshc[3*ielem+2]; + double adis = nodeDistance(i1, i2, coor); + double bdis = nodeDistance(i2, i3, coor); + double cdis2 = nodeDistance(i3, i1, coor); + const int icase = checkTriangleAngles(adis, bdis, cdis2); + + if (icase > 0) + { + int jelem = ielem; + int i4 = 0; + int j1 = i1, j2 = i2, j3 = i3, j4 = 0; + + if (icase == 1) + { + msho26(kmeshc, nelem, i2, i3, jelem, i4); + int ja = 0; msho42(std::span(kinbnd), lenbnd, i2, i3, ja); + if (ja) i4 = 0; + if (i4 > 0 && jelem != ielem) + { + j1 = i1; + msho27(coor, i1, i2, i3, i4, ctx); + if (j1 != i1) ifill = 1; + j1=i1; j2=i2; j3=i3; j4=i4; + kmeshc[3*ielem]=j1; kmeshc[3*ielem+1]=j2; kmeshc[3*ielem+2]=j3; + kmeshc[3*jelem]=j2; kmeshc[3*jelem+1]=j4; kmeshc[3*jelem+2]=j3; + } + } + else if (icase == 2) + { + msho26(kmeshc, nelem, i3, i1, jelem, i4); + int ja = 0; msho42(std::span(kinbnd), lenbnd, i3, i1, ja); + if (ja) i4 = 0; + if (i4 > 0 && jelem != ielem) + { + j2 = i2; + msho27(coor, i2, i3, i1, i4, ctx); + if (j2 != i2) ifill = 1; + j1=i2; j2=i3; j3=i1; j4=i4; + kmeshc[3*ielem]=j1; kmeshc[3*ielem+1]=j2; kmeshc[3*ielem+2]=j3; + kmeshc[3*jelem]=j2; kmeshc[3*jelem+1]=j4; kmeshc[3*jelem+2]=j3; + } + } + else if (icase == 3) + { + msho26(kmeshc, nelem, i1, i2, jelem, i4); + int ja = 0; msho42(std::span(kinbnd), lenbnd, i1, i2, ja); + if (ja) i4 = 0; + if (i4 > 0 && jelem != ielem) + { + j3 = i3; + msho27(coor, i3, i1, i2, i4, ctx); + if (j3 != i3) ifill = 1; + j1=i3; j2=i1; j3=i2; j4=i4; + kmeshc[3*ielem]=j1; kmeshc[3*ielem+1]=j2; kmeshc[3*ielem+2]=j3; + kmeshc[3*jelem]=j2; kmeshc[3*jelem+1]=j4; kmeshc[3*jelem+2]=j3; + } + } + } + } + if (ctx.ierror != 0) return; + + // Compare and save if better + { + const double dmin = computeDismin(); + if (dmin > ratiop) + { + ratiop = dmin; npntmp = npoint; + coortmp.resize(2 * npntmp); + for (int i = 0; i < npoint; ++i) + { coortmp[2*i] = coor[2*i]; coortmp[2*i+1] = coor[2*i+1]; } + neltmp = nelem; + meshtmp.resize(3 * neltmp); + for (int i = 0; i < nelem; ++i) + { meshtmp[3*i]=kmeshc[3*i]; meshtmp[3*i+1]=kmeshc[3*i+1]; meshtmp[3*i+2]=kmeshc[3*i+2]; } + } + } + + // Check if convergence is too slow → go to label 900 + if ((reposition && (nherha > 10 && ifill == 0)) || nherha > 20) break; + + // Repositioning: increment nherha and call msho16 + // (msho18 Laplacian is commented out in the Fortran and not called) + ++nherha; + { + int leng = nrepos; + msho16(kmeshc, nelem, npoint, nipnt, iworkPost, ibuurpPost, leng, ctx); + if (ctx.ierror != 0) return; + } + + // Fortran redivision loop (msho30 + goto 300): if an interior + // triangle is invalid/too distorted, rebuild the local front and + // restart the advancing-front phase. + bool restartedFromRedivision = false; + for (int ielem = nelemi; ielem < nelem; ++ielem) + { + const int i1 = kmeshc[3 * ielem]; + const int i2 = kmeshc[3 * ielem + 1]; + const int i3 = kmeshc[3 * ielem + 2]; + + // Check only fully interior triangles. + if (i1 <= nipnt || i2 <= nipnt || i3 <= nipnt) + continue; + + const double surf = triangleArea(coor, i1, i2, i3); + + auto cubeIndexForNode = [&](int node) -> int + { + const int stored = icubeSp[node - 1]; + if (stored > 0) + { + const int idx = stored - 1; + if (idx >= 0 && idx < ncube) return idx; + } + + const double x = coor[2 * (node - 1)]; + const double y = coor[2 * (node - 1) + 1]; + int n1c = static_cast((x - xstart) / dism); + int n2c = static_cast((y - ystart) / dism); + n1c = std::clamp(n1c, 0, nx - 1); + n2c = std::clamp(n2c, 0, ny - 1); + return n1c + n2c * nx; + }; + + const int c1 = cubeIndexForNode(i1); + const int c2 = cubeIndexForNode(i2); + const int c3 = cubeIndexForNode(i3); + + const double valare = (chelp[c1] + chelp[c2] + chelp[c3]) / 3.0; + const bool areaOutOfRange = + ((surf < 0.1 * valare) || (surf > 10.0 * valare)) && (nherha < 50); + + if (surf < 0.0 || areaOutOfRange) + { + int ielemForMsho30 = ielem + 1; // msho30 is 1-based for ielem + msho30(kmeshc, nelem, ielemForMsho30, + kstaplSp, kstap, npoint, itri, + nelemi); + if (ctx.ierror != 0) return; + + nochan = 0; + done = advanceFront(); + if (!done || ctx.ierror != 0) return; + verifyConnectionsArray(); + + restartedFromRedivision = true; + break; + } + } + + if (restartedFromRedivision) + continue; + + // Check nodes with fewer than 5 neighbours (ja check) + int ja = 0; + for (int i = nipnt + 1; i <= npoint; ++i) + { + const int istart = (i == 1) ? 0 : iworkPost[i - 2]; + const int iend = iworkPost[i - 1]; + if (iend - istart < 5) { ja = 1; break; } + } + + // Repeat if nherha < 5, or any interior node has < 5 neighbours, or ifill + if (nherha < 5 || ja == 1 || ifill == 1) continue; // goto 540 + break; // goto 900 + } + + // ---- label 900: check final vs saved, pick best ---- + { + const double dmin = computeDismin(); + if (dmin < ratiop - 100.0 * eps && !coortmp.empty()) + { + // Use saved best mesh + npoint = npntmp; + for (int i = 0; i < npoint; ++i) + { coor[2*i] = coortmp[2*i]; coor[2*i+1] = coortmp[2*i+1]; } + nelem = neltmp; + for (int i = 0; i < nelem; ++i) + { kmeshc[3*i]=meshtmp[3*i]; kmeshc[3*i+1]=meshtmp[3*i+1]; kmeshc[3*i+2]=meshtmp[3*i+2]; } + } + } + + // ---- Back-transform coordinates ---- + for (int i = 0; i < npoint; ++i) + { + coor[2*i] = (coor[2*i] - 1.0) * tran + xmint; + coor[2*i+1] = (coor[2*i+1] - 1.0) * tran + ymint; + } +} + +} // namespace sepran diff --git a/extern/sepran/Msho2d.hpp b/extern/sepran/Msho2d.hpp new file mode 100644 index 000000000..751e03ef6 --- /dev/null +++ b/extern/sepran/Msho2d.hpp @@ -0,0 +1,79 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of msho2d.for from the SEPRAN library +// ("Ingenieursbureau SEPRA", Niek Praagman, 1989-2011). + +#pragma once + +#include "SepranContext.hpp" + +#include + +namespace sepran +{ + +/// \brief Main advancing-front triangulation driver for a single 2D surface. +/// +/// Translated from Fortran \c msho2d (SEPRAN, Niek Praagman). +/// +/// \param coor i/o Interleaved flat coord array: coor[2*(k-1)]=x, coor[2*(k-1)+1]=y. +/// \param npoint i/o Number of nodes (in: boundary nodes; out: all nodes). +/// \param kbound i Flat boundary-edge pairs (1-based node indices), length 2*nbound. +/// \param nbound i Number of boundary edges. +/// \param kmeshc o Output triangle array: 3 node indices per element (1-based), flat. +/// \param nelem o Number of triangles generated. +/// \param boundary i Flat 2*numcrvboun array: [curveNr, startAddrInKbndpt] per curve. +/// \param numcrvboun i Number of curves in the boundary description. +/// \param npunt i Estimated total number of nodes in the final mesh. +/// \param inside i 1 = there are interior areas (holes/constraints). +/// \param holeinfo i Flat 2*(nholes+2) array with hole boundary info. +/// \param nholes i Number of holes. +/// \param reposition i Whether Laplacian repositioning is allowed. +/// \param kbndpt i Node-number sequence for boundary curves. +/// \param nbndpt i Length of kbndpt. +/// \param coar i Flat 3*ncoar array: [x, y, coarseness] per special point. +/// \param ncoar i Number of special (user coarseness) points. +/// \param userpoints i User-given sequence numbers for the ncoar special points. +/// \param cocurv i Flat 2*totalCurvNodes array of internal-curve node coordinates. +/// \param ncurvs i Number of internal curves. +/// \param curves i Node counts per internal curve (length ncurvs). +/// \param crvnrs i User-given curve numbers (length ncurvs). +/// \param istep i 1 = linear elements, 2 = quadratic. +/// \param extquanodes i Help array for quadratic internal line data. +/// \param isurnr i Surface sequence number (for diagnostics). +/// \param rinput i Real input array: [1..ndim*nuspnt+2+nuspnt] coarseness/user-data. +/// \param nuspnt i Number of user-prescribed nodes. +/// \param ndim i Spatial dimension of the original problem. +/// \param ctx i/o SEPRAN error/constant context. +void msho2d(std::span coor, + int& npoint, + std::span kbound, + int nbound, + std::span kmeshc, + int& nelem, + std::span boundary, + int numcrvboun, + int npunt, + int inside, + std::span holeinfo, + int nholes, + bool reposition, + std::span kbndpt, + int nbndpt, + std::span coar, + int ncoar, + std::span userpoints, + std::span cocurv, + int ncurvs, + std::span curves, + std::span crvnrs, + int istep, + std::span extquanodes, + int isurnr, + std::span rinput, + int nuspnt, + int ndim, + SepranContext& ctx); + +} // namespace sepran diff --git a/extern/sepran/Mshoce.cpp b/extern/sepran/Mshoce.cpp new file mode 100644 index 000000000..3fb1fdbde --- /dev/null +++ b/extern/sepran/Mshoce.cpp @@ -0,0 +1,198 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshoce.for from the SEPRAN library +// ("Ingenieursbureau SEPRA", Niek Praagman, 1989-2010). + +#include "Mshoce.hpp" + +#include "Msho2d.hpp" +#include "SepranBoundary.hpp" +#include "SepranContext.hpp" +#include "SepranQuadratic.hpp" + +#include +#include + +namespace sepran +{ + +void mshoce(bool jnew, + std::span coor, + std::span kmeshc, + int inpelm, + int nbound, + std::span bcord, + std::span kbndpt, + std::span boundary, + int numcurvboun, + int& npoint, + int& nelem, + std::span holeinfo, + int nholes, + int ncoar, + std::span coar, + std::span userpoints, + int isurnr, + int numextcurves, + std::span numnodextcurvs, + std::span curvenumbers, + std::span rinput, + int nuspnt, + int ndim, + SepranContext& ctx) +{ + // --- Estimated total node count (= capacity of coor array) + const int npunt = npoint; + + // --- Allocate local boundary-edge array + std::vector kbound(2 * npunt, 0); + + // --- Copy boundary coordinates into coor (output node array) + BoundaryCopyResult bcr = copyBoundary( + nbound, + bcord, + coor, + kbndpt, + std::span(kbound), + true, + ctx); + + if (ctx.ierror != 0) return; + + const int jpnt = bcr.jpnt; + const int inside = bcr.inside; + int nbn = bcr.nbn; + + if (jnew) + { + // ---- Generating a new mesh ---------------------------------------- + npoint = jpnt; + int istep = 1; + + // --- Allocate extquanodes help array + std::vector extquanodes; + + if (inpelm == 6 || inpelm == 7) + { + // Quadratic: double-up boundary connectivity (every other edge) + istep = 2; + nbn = nbn / 2; + + for (int i = 0; i < nbn; ++i) + { + kbound[2 * i] = kbound[4 * i]; + kbound[2 * i + 1] = kbound[4 * i + 3]; + } + + // Compute extra nodes on internal curves + int nnodes = 0; + for (int i = 0; i < numextcurves; ++i) + nnodes += numnodextcurvs[i]; + if (nnodes == 0) nnodes = 1; + + extquanodes.assign(2 * nnodes, 0); + extquanodes[0] = 0; + } + else + { + extquanodes.assign(1, 0); + } + + // --- Build internal-curve coordinate span + // bcord layout: [2*nbound outer nodes][2*totalInternalNodes internal nodes] + const std::span cocurv = bcord.subspan(2 * nbound); + + int nbndpt_loc = nbound; + + // --- Main triangulation + msho2d(coor, npoint, + std::span(kbound.data(), 2 * nbn), nbn, + kmeshc, nelem, + boundary, numcurvboun, + npunt, + inside, + holeinfo, nholes, + true, // reposition = .true. + kbndpt, nbndpt_loc, + coar, ncoar, + userpoints, + cocurv, + numextcurves, + numnodextcurvs, + curvenumbers, + istep, + std::span(extquanodes), + isurnr, + rinput, + nuspnt, ndim, + ctx); + + if (ctx.ierror != 0) return; + + // --- Upgrade to quadratic elements if needed + if (inpelm == 6 || inpelm == 7) + { + msho31(coor, npoint, kmeshc, nelem, + std::span(kbound.data(), 2 * nbn), nbn, + std::span(extquanodes), + ctx); + + if (ctx.ierror != 0) return; + // (inpelm==7 centroid placement omitted – not needed for MeshKernel) + } + } + else + { + // ---- Repositioning only (jnew == false) ----------------------------- + // mshrep is not translated; only handle quadratic renaming below. + + int nbndpt_loc2 = jpnt; + (void)nbndpt_loc2; + + if (inpelm == 6 || inpelm == 7) + { + int npunt_out = 0; + msho32(kmeshc, nelem, inpelm, npunt_out); + if (ctx.ierror != 0) return; + + npoint = (npunt_out > jpnt) ? npunt_out : jpnt; + nbn = nbn / 2; + + for (int i = 0; i < nbn; ++i) + { + kbound[2 * i] = kbound[4 * i]; + kbound[2 * i + 1] = kbound[4 * i + 3]; + } + + // Compute extra nodes + int nnodes = 0; + for (int i = 0; i < numextcurves; ++i) + nnodes += numnodextcurvs[i]; + if (nnodes == 0) nnodes = 1; + + std::vector extquanodes2(2 * nnodes, 0); + extquanodes2[0] = 0; + + msho31(coor, npoint, kmeshc, nelem, + std::span(kbound.data(), 2 * nbn), nbn, + std::span(extquanodes2), + ctx); + if (ctx.ierror != 0) return; + } + } + + // --- For quadratic elements: re-copy the boundary coords to get exact positions + if (ctx.igobs == 0 && inpelm > 4) + { + std::vector kboundTmp(2 * npunt, 0); + copyBoundary( + nbound, bcord, coor, + kbndpt, + std::span(kboundTmp), + false, + ctx); + } +} + +} // namespace sepran diff --git a/extern/sepran/Mshoce.hpp b/extern/sepran/Mshoce.hpp new file mode 100644 index 000000000..f2ba10121 --- /dev/null +++ b/extern/sepran/Mshoce.hpp @@ -0,0 +1,72 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshoce.for from the SEPRAN library. + +#pragma once + +#include "SepranContext.hpp" + +#include + +namespace sepran +{ + +/// \brief Main entry point for SEPRAN surface triangulation. +/// +/// Translated from Fortran \c mshoce (SEPRAN, Niek Praagman, 1989-2010). +/// +/// Orchestrates boundary copying, advancing-front triangulation (msho2d), +/// and optional upgrade to quadratic triangles (msho31). +/// +/// \param jnew i true = generate new mesh; false = reposition only. +/// \param coor o Flat interleaved output node coords (length >= 2*npunt). +/// \param kmeshc o Flat element array. Linear: 3 nodes/elem; quadratic: 6. +/// \param inpelm i Nodes per element: 3 (linear), 6 or 7 (quadratic). +/// \param nbound i Number of nodes described in bcord. +/// \param bcord i Flat 2*nbound boundary coord array: [x0,y0, x1,y1, ...]. +/// Internal-curve coords follow immediately at bcord[2*nbound+]. +/// \param kbndpt o Boundary-point node-number array (length >= nbound). +/// \param boundary i Flat 2*numcurvboun array: [curveNr, kbndptStart] per curve. +/// \param numcurvboun i Number of curves in the boundary description. +/// \param npoint o Number of nodes in the output mesh. +/// \param nelem o Number of elements in the output mesh. +/// \param holeinfo i Flat 2*(nholes+2) hole information array. +/// \param nholes i Number of holes. +/// \param ncoar i Number of internal coarseness-control points. +/// \param coar i Flat 3*ncoar array: [x, y, coarseness] per point. +/// \param userpoints i User sequence numbers for the ncoar special points. +/// \param isurnr i Surface sequence number (used for diagnostics). +/// \param numextcurves i Number of extra internal curves. +/// \param numnodextcurvs i Node counts per internal curve (length numextcurves). +/// \param curvenumbers i User curve numbers (length numextcurves). +/// \param rinput i Real input array with coarseness/user-data. +/// \param nuspnt i Number of user-prescribed nodes. +/// \param ndim i Spatial dimension of the original problem. +/// \param ctx i/o SEPRAN error/constant context. +void mshoce(bool jnew, + std::span coor, + std::span kmeshc, + int inpelm, + int nbound, + std::span bcord, + std::span kbndpt, + std::span boundary, + int numcurvboun, + int& npoint, + int& nelem, + std::span holeinfo, + int nholes, + int ncoar, + std::span coar, + std::span userpoints, + int isurnr, + int numextcurves, + std::span numnodextcurvs, + std::span curvenumbers, + std::span rinput, + int nuspnt, + int ndim, + SepranContext& ctx); + +} // namespace sepran diff --git a/extern/sepran/SepranBoundary.cpp b/extern/sepran/SepranBoundary.cpp new file mode 100644 index 000000000..88b22bc32 --- /dev/null +++ b/extern/sepran/SepranBoundary.cpp @@ -0,0 +1,189 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshcopyboun.for and mshchkstapl.for from the SEPRAN library. +// +// Original authors: +// mshcopyboun – Guus Segal, 1999-2001 +// mshchkstapl – Guus Segal, 2003 + +#include "SepranBoundary.hpp" +#include "SepranSort.hpp" + +#include +#include +#include +#include +#include +#include + +namespace sepran +{ + +// --------------------------------------------------------------------------- +// copyBoundary (mshcopyboun.for) +// --------------------------------------------------------------------------- + +BoundaryCopyResult copyBoundary(int nbound, + std::span bcord, + std::span coor, + std::span kbndpt, + std::span kbound, + bool fillKbound, + const SepranContext& /*ctx*/) +{ + // Initialize outputs + int nbn = 0; + int jpnt = 0; + int inside = -1; + + if (nbound == 0) + return {jpnt, inside, nbn}; + + // bcord is stored interleaved: bcord[2*i]=x, bcord[2*i+1]=y (0-based node i) + // Compute reference distance from first two points + const double dx = bcord[2] - bcord[0]; + const double dy = bcord[3] - bcord[1]; + const double ref = 1.0e-5 * std::sqrt(dx * dx + dy * dy); + + // ------------------------------------------------------------------- + // Detect closed-loop boundaries and store the index of the last node + // of each loop in ihelp. + // ------------------------------------------------------------------- + std::vector ihelp; // ihelp[j] = 0-based index of last node of loop j + ihelp.reserve(1 + nbound / 2); + + int ifirst = 0; + while (true) + { + const double xst = bcord[2 * ifirst]; + const double yst = bcord[2 * ifirst + 1]; + + // Find the last node that coincides with the starting node + int ilast = nbound - 1; + for (int i = ifirst + 1; i < nbound; ++i) + { + const double dxi = bcord[2 * i] - xst; + const double dyi = bcord[2 * i + 1] - yst; + if (std::sqrt(dxi * dxi + dyi * dyi) <= ref) + ilast = i; + } + + ihelp.push_back(ilast); + if (ilast == nbound - 1) + break; + ifirst = ilast + 1; + } + + const int nparts = static_cast(ihelp.size()); + + // ------------------------------------------------------------------- + // Loop over all closed parts + // ------------------------------------------------------------------- + int partStart = 0; // 0-based index of first node of current part + for (int j = 0; j < nparts; ++j) + { + const int partEnd = ihelp[j]; // 0-based index of last node of current part + + // Start of this part + const int jst = jpnt + 1; // 1-based first node number of this part + + for (int i = partStart; i <= partEnd; ++i) + { + const double xp = bcord[2 * i]; + const double yp = bcord[2 * i + 1]; + + if (i == partStart) + { + // First node of a new closed loop + if (inside < 1) ++inside; + ++jpnt; + coor[2 * (jpnt - 1)] = xp; // 1-based jpnt → 0-based index + coor[2 * (jpnt - 1) + 1] = yp; + if (fillKbound) + kbndpt[i] = jpnt; + } + else + { + // Subsequent node in the loop + if (fillKbound) + { + ++nbn; + kbound[2 * (nbn - 1)] = jpnt; + kbound[2 * (nbn - 1) + 1] = jpnt + 1; + } + + if (i == partEnd) + { + // Last node of closed loop — wraps back to first + if (fillKbound) + { + kbound[2 * (nbn - 1) + 1] = jst; + kbndpt[i] = jst; + } + } + else + { + ++jpnt; + coor[2 * (jpnt - 1)] = xp; + coor[2 * (jpnt - 1) + 1] = yp; + if (fillKbound) + kbndpt[i] = jpnt; + } + } + } + + partStart = partEnd + 1; + } + + return {jpnt, inside, nbn}; +} + +// --------------------------------------------------------------------------- +// checkStaple (mshchkstapl.for) +// --------------------------------------------------------------------------- + +void checkStaple(std::span kstapl, int lenkstapl, std::string_view text) +{ + if (lenkstapl == 0) + return; + + // kstapl is stored flat: [n1_0, n2_0, n1_1, n2_1, ...] + // Sort column 1 (first nodes) and column 2 (second nodes) separately, + // then check that they contain the same set of node numbers. + + std::vector iwork(lenkstapl); + std::vector ihelp(lenkstapl); + std::vector iseq1(lenkstapl); + std::vector iseq2(lenkstapl); + + // Column 1 + for (int i = 0; i < lenkstapl; ++i) + iwork[i] = kstapl[2 * i]; + heapSort(iwork, ihelp); + for (int i = 0; i < lenkstapl; ++i) + iseq1[i] = iwork[ihelp[i]]; + + // Column 2 + for (int i = 0; i < lenkstapl; ++i) + iwork[i] = kstapl[2 * i + 1]; + heapSort(iwork, ihelp); + for (int i = 0; i < lenkstapl; ++i) + iseq2[i] = iwork[ihelp[i]]; + + // Compare + for (int i = 0; i < lenkstapl; ++i) + { + if (iseq1[i] != iseq2[i]) + { + std::cerr << text << '\n' + << "Both columns of kstapl do not contain the same node numbers\n" + << "The " << i << "-th nodes are different\n"; + for (int k = 0; k < lenkstapl; ++k) + std::cerr << k << ": " << iseq1[k] << " " << iseq2[k] << '\n'; + break; // Diagnostic only; do not throw (matches Fortran behaviour) + } + } +} + +} // namespace sepran diff --git a/extern/sepran/SepranBoundary.hpp b/extern/sepran/SepranBoundary.hpp new file mode 100644 index 000000000..0038952e9 --- /dev/null +++ b/extern/sepran/SepranBoundary.hpp @@ -0,0 +1,68 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshcopyboun.for and mshchkstapl.for from the SEPRAN library. + +#pragma once + +#include "SepranContext.hpp" + +#include +#include + +namespace sepran +{ + +/// \brief Result of copyBoundary. +struct BoundaryCopyResult +{ + int jpnt; ///< Last node number used (1-based). + int inside; ///< Count of internal regions: -1 for outer only, 0+ with holes. + int nbn; ///< Number of boundary edges written into kbound. +}; + +/// \brief Copy boundary coordinates into the node coordinate array. +/// +/// Translated from Fortran \c mshcopyboun (SEPRAN, Guus Segal, 1999-2001). +/// +/// Fills \p coor (first nbn boundary nodes), \p kbndpt (boundary node numbers), +/// and \p kbound (boundary edge connectivity). +/// +/// Array index convention (same as Fortran): +/// - \p bcord and \p coor are stored interleaved: [x0,y0, x1,y1, ...] (0-based node access). +/// - Node number values stored in \p kbndpt and \p kbound are **1-based** (matching the +/// convention used throughout the SEPRAN internal arrays). +/// +/// \param nbound Number of nodes in bcord (boundary description). +/// \param bcord Flat boundary coordinate array (length 2*nbound), interleaved x,y. +/// \param coor Output node coordinate array (pre-allocated, length >= 2*nbound). +/// \param kbndpt Output: node number for each boundary description point (length nbound). +/// \param kbound Output: flat edge-node pairs, 1-based (length >= 2*nbound). +/// \param fillKbound If true, fill kbndpt and kbound; otherwise only fill coor. +/// \param ctx SEPRAN context. +/// \return BoundaryCopyResult with jpnt, inside, nbn. +BoundaryCopyResult copyBoundary(int nbound, + std::span bcord, + std::span coor, + std::span kbndpt, + std::span kbound, + bool fillKbound, + const SepranContext& ctx); + +/// \brief Consistency check on the kstapl (staple) array. +/// +/// Translated from Fortran \c mshchkstapl (SEPRAN, Guus Segal, 2003). +/// +/// Verifies that every node on the left-hand side of a kstapl pair also appears +/// on the right-hand side. Prints a diagnostic message if not (debug aid; does +/// not throw). +/// +/// \param kstapl Flat edge pairs, stored as [n1_0, n2_0, n1_1, n2_1, ...]. +/// Node indices are 1-based. Length 2*lenkstapl. +/// \param lenkstapl Number of pairs in kstapl. +/// \param text Descriptive label printed if an inconsistency is found. +void checkStaple(std::span kstapl, + int lenkstapl, + std::string_view text); + +} // namespace sepran diff --git a/extern/sepran/SepranContext.hpp b/extern/sepran/SepranContext.hpp new file mode 100644 index 000000000..6b20c664b --- /dev/null +++ b/extern/sepran/SepranContext.hpp @@ -0,0 +1,41 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of the Fortran module mshconstants.f90 and msherror module +// from the SEPRAN library ("Ingenieursbureau SEPRA"). +// +// This header is intentionally header-only (no .cpp needed). + +#pragma once + +namespace sepran +{ + +/// \brief Runtime context carrying numerical constants and error state. +/// +/// In the original Fortran this was split across two Fortran modules: +/// - mshconstants: EPSMAC, SQREPS, RINFIN, IREFWR, ITIME, IGOBS, JTIMES +/// - msherror: IERROR +/// +/// In C++ we combine both into a single context object that is passed (by +/// reference) through the call stack instead of being global module state. +struct SepranContext +{ + double epsmac = 1.0e-15; ///< Machine epsilon (EPSMAC in Fortran) + double sqreps = 1.0e-15; ///< Square root of machine epsilon (SQREPS) + double rinfin = 1.0e77; ///< Large sentinel value (RINFIN) + + int itime = 1; ///< Timing flag (ITIME) + int igobs = 1; ///< Observer flag (IGOBS) + int jtimes = 1; ///< Timing multiplier (JTIMES) + + int ierror = 0; ///< Error flag; non-zero indicates an error (IERROR) + + /// \brief Return a default-initialized context with the standard SEPRAN constants. + static SepranContext defaults() noexcept + { + return SepranContext{}; + } +}; + +} // namespace sepran diff --git a/extern/sepran/SepranCurveIntersection.cpp b/extern/sepran/SepranCurveIntersection.cpp new file mode 100644 index 000000000..9cfe08759 --- /dev/null +++ b/extern/sepran/SepranCurveIntersection.cpp @@ -0,0 +1,171 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshcurvinters.for, mshcurvinters1.for, and mshcurvinters2.for +// from the SEPRAN library. +// +// Original author: Guus Segal, 2005. + +#include "SepranCurveIntersection.hpp" +#include "SepranGeometry.hpp" + +#include +#include + +namespace sepran +{ + +// Helper: access the flat xbox 3D array stored in Fortran column-major order: +// xbox(coord, curve, minmax) → xbox[coord + 2*curve + 2*ncurvs*minmax] +// coord = 0 (x) or 1 (y) +// curve = 0-based curve index +// minmax = 0 (minimum) or 1 (maximum) +static double xboxAt(std::span xbox, int ncurvs, int coord, int curve, int minmax) +{ + return xbox[coord + 2 * curve + 2 * ncurvs * minmax]; +} + +// --------------------------------------------------------------------------- +// curvIntersectionPair (mshcurvinters1.for) +// --------------------------------------------------------------------------- + +void curvIntersectionPair(int icurnr, + int jcurnr, + std::span icurvs, + std::span curves, + SepranContext& ctx) +{ + if (ctx.ierror != 0) + return; + + const double eps = ctx.sqreps; + + // Start positions (0-based node index into flat curves array) + const int istart = (icurnr == 0) ? 0 : icurvs[icurnr - 1]; + const int inodes = icurvs[icurnr] - istart; + + const int jstart = (jcurnr == 0) ? 0 : icurvs[jcurnr - 1]; + const int jnodes = icurvs[jcurnr] - jstart; + + // curves is stored interleaved: x at [2*k], y at [2*k+1] (0-based node index k) + std::array x1{curves[2 * istart], curves[2 * istart + 1]}; + + for (int j = 1; j < inodes; ++j) + { + const std::array x2{curves[2 * (istart + j)], curves[2 * (istart + j) + 1]}; + + std::array x3{curves[2 * jstart], curves[2 * jstart + 1]}; + + for (int k = 1; k < jnodes; ++k) + { + const std::array x4{curves[2 * (jstart + k)], curves[2 * (jstart + k) + 1]}; + + double fact1, fact2; + crossLine1(x1, x2, x3, x4, fact1, fact2, eps, ctx); + + // Interior intersection only (not at shared endpoints) + if (fact1 > eps && fact1 < 1.0 - eps && + fact2 > eps && fact2 < 1.0 - eps) + { + ctx.ierror = 1; + throw std::runtime_error( + "SEPRAN: curves " + std::to_string(icurnr) + " and " + + std::to_string(jcurnr) + " intersect (error 2787)"); + } + + x3 = x4; + } + x1 = x2; + } +} + +// --------------------------------------------------------------------------- +// curvIntersectionCheck (mshcurvinters.for) +// --------------------------------------------------------------------------- + +void curvIntersectionCheck(int ncurvs, + std::span iwork, + std::span xbox, + std::span icurvs, + std::span curves, + SepranContext& ctx) +{ + if (ctx.ierror != 0) + return; + + for (int icurnr = 0; icurnr < ncurvs; ++icurnr) + { + if (iwork[icurnr] != 0) + continue; // Only process single curves + + for (int jcurnr = icurnr + 1; jcurnr < ncurvs; ++jcurnr) + { + if (iwork[jcurnr] != 0) + continue; + + // Quick bounding-box check (Fortran: go to 200 on no overlap) + if (xboxAt(xbox, ncurvs, 0, icurnr, 0) > xboxAt(xbox, ncurvs, 0, jcurnr, 1)) + continue; + if (xboxAt(xbox, ncurvs, 0, jcurnr, 0) > xboxAt(xbox, ncurvs, 0, icurnr, 1)) + continue; + if (xboxAt(xbox, ncurvs, 1, icurnr, 0) > xboxAt(xbox, ncurvs, 1, jcurnr, 1)) + continue; + if (xboxAt(xbox, ncurvs, 1, jcurnr, 0) > xboxAt(xbox, ncurvs, 1, icurnr, 1)) + continue; + + curvIntersectionPair(icurnr, jcurnr, icurvs, curves, ctx); + if (ctx.ierror != 0) + return; + } + } +} + +// --------------------------------------------------------------------------- +// boundarySelfIntersectionCheck (mshcurvinters2.for) +// --------------------------------------------------------------------------- + +void boundarySelfIntersectionCheck(std::span kbound, + int nbound, + std::span coor, + int isurnr, + SepranContext& ctx) +{ + if (ctx.ierror != 0) + return; + + constexpr double eps = 1.0e-3; + + for (int i = 0; i < nbound - 1; ++i) + { + // kbound stores 1-based node indices; convert to 0-based for coor access. + const int n1i = kbound[2 * i] - 1; // first node of edge i (0-based) + const int n2i = kbound[2 * i + 1] - 1; // second node of edge i (0-based) + + const std::array x1{coor[2 * n1i], coor[2 * n1i + 1]}; + const std::array x2{coor[2 * n2i], coor[2 * n2i + 1]}; + + for (int j = i + 1; j < nbound; ++j) + { + const int n1j = kbound[2 * j] - 1; + const int n2j = kbound[2 * j + 1] - 1; + + const std::array x3{coor[2 * n1j], coor[2 * n1j + 1]}; + const std::array x4{coor[2 * n2j], coor[2 * n2j + 1]}; + + double fact1, fact2; + crossLine1(x1, x2, x3, x4, fact1, fact2, eps, ctx); + + if (fact1 > eps && fact1 < 1.0 - eps && + fact2 > eps && fact2 < 1.0 - eps) + { + ctx.ierror = 1; + throw std::runtime_error( + "SEPRAN: boundary of surface " + std::to_string(isurnr) + + " intersects itself at edges " + std::to_string(i) + + " and " + std::to_string(j) + " (error 2788)"); + } + } + } +} + +} // namespace sepran diff --git a/extern/sepran/SepranCurveIntersection.hpp b/extern/sepran/SepranCurveIntersection.hpp new file mode 100644 index 000000000..ec3d1cae7 --- /dev/null +++ b/extern/sepran/SepranCurveIntersection.hpp @@ -0,0 +1,78 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshcurvinters.for, mshcurvinters1.for, and mshcurvinters2.for +// from the SEPRAN library. + +#pragma once + +#include "SepranContext.hpp" + +#include + +namespace sepran +{ + +/// \brief Check that no two curves in a set mutually intersect. +/// +/// Translated from Fortran \c mshcurvinters (SEPRAN, Guus Segal, 2005). +/// +/// \param ncurvs Number of curves. +/// \param iwork Work array of length ncurvs. +/// iwork[i] = -1: empty, 0: single, 1: compound. +/// \param xbox Flat 3D bounding-box array, column-major layout: +/// xbox[ 0 + 2*(j) + 2*ncurvs*0 ] = min-x of curve j (0-based j) +/// xbox[ 1 + 2*(j) + 2*ncurvs*0 ] = min-y of curve j +/// xbox[ 0 + 2*(j) + 2*ncurvs*1 ] = max-x of curve j +/// xbox[ 1 + 2*(j) + 2*ncurvs*1 ] = max-y of curve j +/// \param icurvs Accumulated node counts per curve (length ncurvs). +/// icurvs[j] is the total number of nodes in curves 0..j. +/// \param curves Flat coordinate array for all curve nodes, interleaved x,y, +/// 1-based node indices (length 2 * total_nodes). +/// \param ctx SEPRAN context (reads ctx.ierror; sets ctx.ierror on error). +void curvIntersectionCheck(int ncurvs, + std::span iwork, + std::span xbox, + std::span icurvs, + std::span curves, + SepranContext& ctx); + +/// \brief Check that two specific curves do not intersect edge-by-edge. +/// +/// Translated from Fortran \c mshcurvinters1 (SEPRAN, Guus Segal, 2005). +/// +/// Throws std::runtime_error if an intersection is detected. +/// +/// \param icurnr 0-based index of the first curve. +/// \param jcurnr 0-based index of the second curve. +/// \param icurvs Accumulated node counts per curve (length >= max(icurnr,jcurnr)+1). +/// \param curves Flat coord array (interleaved x,y), 1-based node access. +/// \param ctx SEPRAN context. +void curvIntersectionPair(int icurnr, + int jcurnr, + std::span icurvs, + std::span curves, + SepranContext& ctx); + +/// \brief Check that the boundary edges of a surface do not mutually intersect. +/// +/// Translated from Fortran \c mshcurvinters2 (SEPRAN, Guus Segal, 2005). +/// +/// Sets ctx.ierror and throws std::runtime_error if self-intersection is found. +/// +/// \param kbound Flat edge-node array (1-based node indices), length 2*nbound. +/// kbound[2*i] = first node of edge i (0-based i). +/// kbound[2*i+1] = second node of edge i. +/// \param nbound Number of boundary edges. +/// \param coor Flat node coordinate array, interleaved x,y (1-based node indices). +/// coor[2*(k-1)] = x of node k (1-based k). +/// coor[2*(k-1)+1] = y of node k. +/// \param isurnr Surface sequence number (used in error message). +/// \param ctx SEPRAN context. +void boundarySelfIntersectionCheck(std::span kbound, + int nbound, + std::span coor, + int isurnr, + SepranContext& ctx); + +} // namespace sepran diff --git a/extern/sepran/SepranFront.cpp b/extern/sepran/SepranFront.cpp new file mode 100644 index 000000000..0661b6c9d --- /dev/null +++ b/extern/sepran/SepranFront.cpp @@ -0,0 +1,2467 @@ +// SepranFront.cpp - all translated functions +// +// C++20 translation of msho01, msho09, msho11, msho12, msho13, msho14, +// msho17, msho20, msho21, msho24, msho25, msho26, msho27, msho28, msho29, +// msho30, msho33, msho34, msho39, msho41, msho42, msho75 +// from the SEPRAN library ("Ingenieursbureau SEPRA", Niek Praagman, 1989-2010). +// +// TRANSLATION CONVENTIONS (flat-span layout): +// coor : interleaved flat; coor[2*(k-1)] = x, coor[2*(k-1)+1] = y (1-based k) +// kstapl : flat pairs; kstapl[2*s]=n1, kstapl[2*s+1]=n2 (0-based edge s) +// kelem : flat triples; kelem[3*e], [3*e+1], [3*e+2] (0-based elem e) +// itri : flat; itri[k-1] for 1-based node k +// istart : CSR ptr; istart[i-1] = cumulative neighbour count through node i + +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares + +#include "SepranFront.hpp" +#include "SepranContext.hpp" +#include "SepranGeometry.hpp" +#include "SepranTopology.hpp" +#include "SepranBoundary.hpp" + +#include +#include +#include +#include +#include +#include +#include +#include + +namespace sepran +{ + +// --------------------------------------------------------------------------- +// Forward declaration of internal helper (msho75) +// --------------------------------------------------------------------------- +static void checkSegmentIntersection(double xi, double yi, double xj, double yj, + double x1, double y1, double x2, double y2, + int& ih, const SepranContext& ctx); + +// --------------------------------------------------------------------------- +// msho01 – Check boundary elements; fill coarse array for each point +// --------------------------------------------------------------------------- +// +// Parameters (C++ 0-based spans): +// kbound i flat boundary element pairs (kbound[2*e]=n1, [2*e+1]=n2) +// nbound i number of boundary line segments +// istart i/o CSR row-pointer array (length npoint) +// ibuur i/o CSR adjacency list (pre-allocated) +// coarse o coarseness value per node (length npoint) +// coor i node coordinate array (interleaved flat) +// npoint i number of nodes +// coarsemin o minimum boundary coarseness +// coarsemax o maximum boundary coarseness +// coar i/o special-point array coar[3*(i-1)+2] = coarseness (1-based i) +// ncoar i number of special points in coar +// --------------------------------------------------------------------------- +void msho01(std::span kbound, + int nbound, + std::span istart, + std::span ibuur, + std::span coarse, + std::span coor, + int npoint, + double& coarsemin, + double& coarsemax, + std::span coar, + int ncoar, + SepranContext& ctx) +{ + coarsemin = ctx.rinfin; + coarsemax = -ctx.rinfin; + + // --- Count neighbours: istart[i] = degree of node i+1 (temporarily) + for (int i = 0; i < npoint; ++i) istart[i] = 0; + + for (int e = 0; e < nbound; ++e) + { + const int i1 = kbound[2 * e]; + const int i2 = kbound[2 * e + 1]; + istart[i1 - 1]++; + istart[i2 - 1]++; + } + + // --- Convert counts to cumulative CSR pointers + int itotal = 0; + for (int i = 0; i < npoint; ++i) + { + itotal += istart[i]; + istart[i] = itotal; + } + + // --- Clear ibuur then fill via insertNeighbour + for (int k = 0; k < itotal; ++k) ibuur[k] = 0; + + for (int e = 0; e < nbound; ++e) + { + const int i1 = kbound[2 * e]; + const int i2 = kbound[2 * e + 1]; + insertNeighbour(istart, ibuur, i1, i2); + insertNeighbour(istart, ibuur, i2, i1); + } + + // --- Check neighbour counts and compute per-node coarseness + int no = 0; + for (int i = 1; i <= npoint; ++i) + { + const int ni = istart[i - 1]; + const int ntal = ni - no; + + if (ntal != 0 && ntal != 2) + { + ctx.ierror = 1; + throw std::runtime_error( + "msho01: boundary point has wrong number of neighbours (error 905)"); + } + + double afstan = 0.0; + if (ntal > 0) + { + for (int k = no; k < no + ntal; ++k) + { + const int jknoop = ibuur[k]; + if (jknoop > 0) + afstan += nodeDistance(i, jknoop, coor); + } + coarse[i - 1] = afstan / ntal; + coarsemin = std::min(coarsemin, coarse[i - 1]); + coarsemax = std::max(coarsemax, coarse[i - 1]); + } + else + { + coarse[i - 1] = 0.0; + } + no = ni; + } + + // --- Back-fill missing coarsenesses in coar + const double coarsemean = 0.5 * (coarsemin + coarsemax); + for (int i = 0; i < ncoar; ++i) + { + // coar(3,i+1) in Fortran (1-based) = coar[3*i + 2] in C++ + if (coar[3 * i + 2] <= 1.0e-6) coar[3 * i + 2] = coarsemean; + } +} + +// --------------------------------------------------------------------------- +// msho09 – Perpendicular unit vector and midpoint of segment i→j +// --------------------------------------------------------------------------- +// +// coor i node coordinate array (interleaved flat) +// i i first node (1-based) +// j i second node (1-based) +// e1 o x-component of unit perpendicular vector +// e2 o y-component of unit perpendicular vector +// xm o x-coordinate of midpoint (slightly offset toward i) +// ym o y-coordinate of midpoint +// --------------------------------------------------------------------------- +void msho09(std::span coor, + int i, + int j, + double& e1, + double& e2, + double& xm, + double& ym) +{ + const double xi = coor[2 * (i - 1)]; + const double yi = coor[2 * (i - 1) + 1]; + const double xj = coor[2 * (j - 1)]; + const double yj = coor[2 * (j - 1) + 1]; + + e1 = -(yj - yi); + e2 = xj - xi; + + const double eleng = std::sqrt(e1 * e1 + e2 * e2); + e1 /= eleng; + e2 /= eleng; + + // Slightly asymmetric midpoint (intentional — matches Fortran exactly) + xm = 0.5000001234 * xi + 0.4999998766 * xj; + ym = 0.5000001234 * yi + 0.4999998766 * yj; +} + +// --------------------------------------------------------------------------- +// msho11 – Cosine of angle between line (i1→i2) and line (i2→i3) +// --------------------------------------------------------------------------- +// +// i1, i2, i3 i node indices (1-based) +// coor i node coordinate array (interleaved flat) +// angle o dot product (cosine); set to -1.5 if points coincide +// --------------------------------------------------------------------------- +void msho11(int i1, + int i2, + int i3, + std::span coor, + double& angle, + const SepranContext& ctx) +{ + const double x1 = coor[2 * (i1 - 1)], y1 = coor[2 * (i1 - 1) + 1]; + const double x2 = coor[2 * (i2 - 1)], y2 = coor[2 * (i2 - 1) + 1]; + const double x3 = coor[2 * (i3 - 1)], y3 = coor[2 * (i3 - 1) + 1]; + + // Direction i2→i3 + double e1 = x3 - x2, e2 = y3 - y2; + double eleng = std::sqrt(e1 * e1 + e2 * e2); + double h1 = (x2 + x3) * 0.5; + double h2 = (y2 + y3) * 0.5; + double hnorm = std::sqrt(h1 * h1 + h2 * h2); + + if (eleng < 1.0e2 * ctx.epsmac * hnorm) + { + angle = -1.5; + return; + } + e1 /= eleng; e2 /= eleng; + + // Direction i2→i1 + double e3 = x1 - x2, e4 = y1 - y2; + eleng = std::sqrt(e3 * e3 + e4 * e4); + h1 = (x1 + x2) * 0.5; + h2 = (y1 + y2) * 0.5; + hnorm = std::sqrt(h1 * h1 + h2 * h2); + + if (eleng < 1.0e2 * ctx.epsmac * hnorm) + { + angle = -1.5; + return; + } + e3 /= eleng; e4 /= eleng; + + angle = e1 * e3 + e2 * e4; +} + +// --------------------------------------------------------------------------- +// msho12 – Adjacent-line search and angle computation at endpoints of i1–i2 +// --------------------------------------------------------------------------- +// +// coor i node coordinate array (interleaved flat) +// kstapl i boundary edge list (flat pairs, kstap edges) +// kstap i number of edges in kstapl +// i1 i first node of base edge (1-based) +// i2 i second node of base edge (1-based) +// iex1 o node of best adjacent edge at i1 +// iex2 o node of best adjacent edge at i2 +// angle1 o best angle at i1 +// angle2 o best angle at i2 +// --------------------------------------------------------------------------- +void msho12(std::span coor, + std::span kstapl, + int kstap, + int i1, + int i2, + int& iex1, + int& iex2, + double& angle1, + double& angle2, + SepranContext& ctx) +{ + iex1 = 0; iex2 = 0; + angle1 = -1.2; angle2 = -1.2; + + for (int s = 0; s < kstap; ++s) + { + const int ii1 = kstapl[2 * s]; + const int ii2 = kstapl[2 * s + 1]; + + // Check edge ii1→ii2: does it adjoin i1 (i.e. ii2 == i1)? + if (i1 == ii2) + { + const double surf = triangleArea(coor, ii1, i1, i2); + double angle; + if (surf <= 0.0) + angle = -1.1; + else + msho11(ii1, i1, i2, coor, angle, ctx); + + if (angle > angle1) + { + iex1 = ii1; + angle1 = angle; + } + } + + // Check edge ii1→ii2: does it adjoin i2 (i.e. ii1 == i2)? + if (i2 == ii1) + { + const double surf = triangleArea(coor, i1, i2, ii2); + double angle; + if (surf <= 0.0) + angle = -1.1; + else + msho11(i1, i2, ii2, coor, angle, ctx); + + if (angle > angle2) + { + iex2 = ii2; + angle2 = angle; + } + } + } + + if (iex1 == 0 || iex2 == 0) + { + ctx.ierror = 1; + throw std::runtime_error("msho12: internal error in triangle (error 2433)"); + } +} + +// --------------------------------------------------------------------------- +// msho13 – Check whether lines from i1/i2 to new point (xn,yn) cross +// any existing boundary edge. +// +// coor i node coordinate array (2-component interleaved flat) +// i1, i2 i base edge nodes (1-based) +// kdrie o index (1-based) of first crossing edge; 0 = none; -1 = ambiguous +// kstapl i boundary edge list (flat pairs) +// kstap i number of edges in kstapl +// xn, yn i proposed new point coordinates +// --------------------------------------------------------------------------- +void msho13(std::span coor, + int i1, + int i2, + int& kdrie, + std::span kstapl, + int kstap, + double xn, + double yn, + const SepranContext& ctx) +{ + const double eps = 1.0e4 * ctx.epsmac; + + const double xi1 = coor[2 * (i1 - 1)], yi1 = coor[2 * (i1 - 1) + 1]; + const double xi2 = coor[2 * (i2 - 1)], yi2 = coor[2 * (i2 - 1) + 1]; + + const double xmin = std::min({xi1, xi2, xn}); + const double xmax = std::max({xi1, xi2, xn}); + const double ymin = std::min({yi1, yi2, yn}); + const double ymax = std::max({yi1, yi2, yn}); + + kdrie = 0; + + // Helper: update kdrie when a new crossing is found at edge s (0-based) + // Returns true if an ambiguous double-crossing (-1) was detected. + auto updateKdrie = [&](int s, double xMid, double yMid) -> bool + { + const int oneBasedS = s + 1; + if (kdrie == 0) + { + kdrie = oneBasedS; + return false; + } + if (kdrie > 0 && kdrie != oneBasedS) + { + // Double crossing — pick the one whose midpoint is closer to edge i1-i2 midpoint + const int ipn1_k = kstapl[2 * (kdrie - 1)]; + const int ipn2_k = kstapl[2 * (kdrie - 1) + 1]; + const double xpn1_k = (coor[2*(ipn1_k-1)] + coor[2*(ipn2_k-1)]) * 0.5; + const double ypn1_k = (coor[2*(ipn1_k-1)+1] + coor[2*(ipn2_k-1)+1]) * 0.5; + const double xpn2 = (xi1 + xi2) * 0.5; + const double ypn2 = (yi1 + yi2) * 0.5; + const double dis1 = (xpn1_k - xpn2)*(xpn1_k - xpn2) + (ypn1_k - ypn2)*(ypn1_k - ypn2); + + const int ipn1_s = kstapl[2 * s]; + const int ipn2_s = kstapl[2 * s + 1]; + const double xpn1_s = (coor[2*(ipn1_s-1)] + coor[2*(ipn2_s-1)]) * 0.5; + const double ypn1_s = (coor[2*(ipn1_s-1)+1] + coor[2*(ipn2_s-1)+1]) * 0.5; + const double dis2 = (xpn1_s - xpn2)*(xpn1_s - xpn2) + (ypn1_s - ypn2)*(ypn1_s - ypn2); + + if (dis2 < (1.0 - eps) * dis1) + kdrie = oneBasedS; + else if (dis2 < (1.0 + eps) * dis1) + { + kdrie = -1; + return true; // ambiguous + } + // else keep old kdrie + } + return false; + (void)xMid; (void)yMid; + }; + + // Loop over boundary edges, skipping index 0 (the current base edge) + for (int s = 1; s < kstap; ++s) + { + const int ii1 = kstapl[2 * s]; + const int ii2 = kstapl[2 * s + 1]; + + const double x1 = coor[2 * (ii1 - 1)], y1 = coor[2 * (ii1 - 1) + 1]; + const double x2 = coor[2 * (ii2 - 1)], y2 = coor[2 * (ii2 - 1) + 1]; + + const double xmi = std::min(x1, x2), xma = std::max(x1, x2); + const double ymi = std::min(y1, y2), yma = std::max(y1, y2); + + if (xmi > xmax || xma < xmin || ymi > ymax || yma < ymin) + continue; + + // --- Check line i1 → new point + if (i1 != ii1 && i1 != ii2) + { + const double dis1 = std::abs(xi1 - x1) + std::abs(yi1 - y1); + const double dis2 = std::abs(xi1 - x2) + std::abs(yi1 - y2); + const double h1 = std::abs(xi1) + std::abs(x1) + std::abs(yi1) + std::abs(y1); + const double h2 = std::abs(xi1) + std::abs(x2) + std::abs(yi1) + std::abs(y2); + + if (dis1 > eps * h1 && dis2 > eps * h2) + { + int ih; + checkSegmentIntersection(xi1, yi1, xn, yn, x1, y1, x2, y2, ih, ctx); + if (ih == 0) + if (updateKdrie(s, 0, 0)) return; + } + } + + // --- Check line i2 → new point + if (i2 != ii1 && i2 != ii2) + { + const double dis1 = std::abs(xi2 - x1) + std::abs(yi2 - y1); + const double dis2 = std::abs(xi2 - x2) + std::abs(yi2 - y2); + const double h1 = std::abs(xi2) + std::abs(x1) + std::abs(yi2) + std::abs(y1); + const double h2 = std::abs(xi2) + std::abs(x2) + std::abs(yi2) + std::abs(y2); + + if (dis1 > eps * h1 && dis2 > eps * h2) + { + int ih; + checkSegmentIntersection(xi2, yi2, xn, yn, x1, y1, x2, y2, ih, ctx); + if (ih == 0) + if (updateKdrie(s, 0, 0)) return; + } + } + + // --- Check line midpoint(i1,i2) → new point + double xh = (xi1 + xi2) * 0.5; + double yh = (yi1 + yi2) * 0.5; + xh = eps * xn + (1.0 - eps) * xh; + yh = eps * yn + (1.0 - eps) * yh; + + { + int ih; + checkSegmentIntersection(xh, yh, xn, yn, x1, y1, x2, y2, ih, ctx); + if (ih == 0) + if (updateKdrie(s, 0, 0)) return; + } + } +} + +// --------------------------------------------------------------------------- +// msho14 – Find the nearest boundary point to proposed new point (xn, yn) +// +// coor i node coordinate array (interleaved flat) +// jpn o node number of nearest boundary point (1-based; 0 if none) +// npoint i total number of nodes +// itri i per-node boundary membership counter +// i1, i2 i base edge nodes (excluded from search) +// xn, yn i proposed new point +// dista i/o current best distance (updated if closer point found) +// --------------------------------------------------------------------------- +void msho14(std::span coor, + int& jpn, + int npoint, + std::span itri, + int i1, + int i2, + double xn, + double yn, + double& dista) +{ + jpn = 0; + for (int ih = 1; ih <= npoint; ++ih) + { + if (ih == i1 || ih == i2 || itri[ih - 1] == 0) continue; + + const double xi = coor[2 * (ih - 1)]; + const double yi = coor[2 * (ih - 1) + 1]; + const double dx = xn - xi; + const double dy = yn - yi; + const double dist = std::sqrt(dx * dx + dy * dy); + + if (dist < dista) + { + jpn = ih; + dista = dist; + } + } +} + +// --------------------------------------------------------------------------- +// msho17 – Insert neighbour ij into the ibuurp array for node ih +// (uses a different pointer structure than msho02/insertNeighbour) +// +// ibuurp i/o neighbour array +// iwork i row-pointer array; iwork[i-1] = end of neighbours for node i +// ih i node whose neighbour list is extended (1-based) +// ij i neighbour node to insert (1-based) +// --------------------------------------------------------------------------- +void msho17(std::span ibuurp, + std::span iwork, + int ih, + int ij) +{ + // jstart will be 1-based into ibuurp + int jstart = (ih != 1) ? iwork[ih - 2] : 0; + + for (;;) + { + ++jstart; + const int val = ibuurp[jstart - 1]; + if (val == ij) return; // already present + if (val != 0) continue; // slot occupied, advance + ibuurp[jstart - 1] = ij; // insert + return; + } +} + +// --------------------------------------------------------------------------- +// msho20 – Cyclic rotation of kstapl: move first edge to last position +// and update itri accordingly. +// +// kstapl i/o boundary edge list (flat pairs) +// kstap i number of edges +// itri i/o per-node boundary membership counter +// --------------------------------------------------------------------------- +void msho20(std::span kstapl, + int kstap, + std::span itri) +{ + const int i1 = kstapl[0]; + const int i2 = kstapl[1]; + + // Shift elements left by one position + for (int ikl = 1; ikl < kstap; ++ikl) + { + kstapl[2 * (ikl - 1)] = kstapl[2 * ikl]; + kstapl[2 * (ikl - 1) + 1] = kstapl[2 * ikl + 1]; + } + + kstapl[2 * (kstap - 1)] = i1; + kstapl[2 * (kstap - 1) + 1] = i2; + + itri[i1 - 1]++; + itri[i2 - 1]++; +} + +// --------------------------------------------------------------------------- +// msho21 – Compute reference triangle-area values for each cube cell +// +// cube i coarseness per cell (length ncube) +// ncube i number of cells +// refvol o reference surface value = 0.5 * coarseness^2 +// --------------------------------------------------------------------------- +void msho21(std::span cube, + int ncube, + std::span refvol) +{ + for (int i = 0; i < ncube; ++i) + refvol[i] = 0.5 * cube[i] * cube[i]; +} + +// --------------------------------------------------------------------------- +// msho24 – Check whether line i1–i2 shares a point with any boundary edge +// +// kstapl i boundary edge list (flat pairs, kstap edges) +// kstap i number of boundary edges +// coor i node coordinate array (interleaved flat) +// i1, i2 i line nodes (1-based) +// icheck o -1: only Plaxis endpoints coincide; +// 0: no common point found; +// >0: 1-based index of intersecting edge +// --------------------------------------------------------------------------- +void msho24(std::span kstapl, + int kstap, + std::span coor, + int i1, + int i2, + int& icheck, + const SepranContext& ctx) +{ + const double eps = 10.0 * ctx.epsmac; + + icheck = -1; + + const double x1 = coor[2 * (i1 - 1)], y1 = coor[2 * (i1 - 1) + 1]; + const double x2 = coor[2 * (i2 - 1)], y2 = coor[2 * (i2 - 1) + 1]; + + const double xmin = std::min(x1, x2), xmax = std::max(x1, x2); + const double ymin = std::min(y1, y2), ymax = std::max(y1, y2); + + for (int il = 0; il < kstap; ++il) + { + const int ia = kstapl[2 * il]; + const int ib = kstapl[2 * il + 1]; + + // Skip if boundary edge shares a node with i1–i2 + if (ia == i1 || ia == i2) continue; + if (ib == i1 || ib == i2) continue; + + const double xa = coor[2 * (ia - 1)], ya = coor[2 * (ia - 1) + 1]; + const double xb = coor[2 * (ib - 1)], yb = coor[2 * (ib - 1) + 1]; + + // Coincidence of ia with i1 + double dis = (x1 - xa)*(x1 - xa) + (y1 - ya)*(y1 - ya); + if (dis < eps) continue; + + // Coincidence of ia with i2 (Plaxis point) + dis = (x2 - xa)*(x2 - xa) + (y2 - ya)*(y2 - ya); + if (dis < eps) { icheck = il + 1; return; } + + // Coincidence of ib with i1 + dis = (x1 - xb)*(x1 - xb) + (y1 - yb)*(y1 - yb); + if (dis < eps) continue; + + // Coincidence of ib with i2 (Plaxis point) + dis = (x2 - xb)*(x2 - xb) + (y2 - yb)*(y2 - yb); + if (dis < eps) { icheck = il + 1; return; } + + // Bounding-box pre-check + if (std::min(xa, xb) > xmax) continue; + if (std::max(xa, xb) < xmin) continue; + if (std::min(ya, yb) > ymax) continue; + if (std::max(ya, yb) < ymin) continue; + + int ih; + checkSegmentIntersection(xa, ya, xb, yb, x1, y1, x2, y2, ih, ctx); + if (ih == 0) { icheck = il + 1; return; } + } + + icheck = 0; +} + +// --------------------------------------------------------------------------- +// msho25 – Move the shortest edge in kstapl to position 0 +// +// kstapl i/o boundary edge list (flat pairs) +// kstap i number of edges +// coor i node coordinate array (interleaved flat) +// --------------------------------------------------------------------------- +void msho25(std::span kstapl, + int kstap, + std::span coor, + const SepranContext& ctx) +{ + int ielem = -1; + double afref = ctx.rinfin; + + for (int il = 0; il < kstap; ++il) + { + const int ia = kstapl[2 * il]; + const int ib = kstapl[2 * il + 1]; + const double xa = coor[2 * (ia - 1)], ya = coor[2 * (ia - 1) + 1]; + const double xb = coor[2 * (ib - 1)], yb = coor[2 * (ib - 1) + 1]; + const double dx = xb - xa, dy = yb - ya; + const double afst = dx * dx + dy * dy; + + if (afst < 0.98 * afref) + { + afref = afst; + ielem = il; + } + } + + // Swap element ielem with element 0 (only if ielem is not already 0) + if (ielem > 0) + { + const int i1 = kstapl[2 * ielem]; + const int i2 = kstapl[2 * ielem + 1]; + kstapl[2 * ielem] = kstapl[0]; + kstapl[2 * ielem + 1] = kstapl[1]; + kstapl[0] = i1; + kstapl[1] = i2; + } +} + +// --------------------------------------------------------------------------- +// msho26 – Find the triangle (other than ielem) that has edge i2–i3 as a side +// +// kelem i element array (flat triples of 1-based node indices) +// nelem i number of elements +// i2 i first node of shared edge (1-based) +// i3 i second node of shared edge (1-based) +// jelem i/o i: known element containing i2–i3; o: neighbouring element (1-based; 0 if none) +// i4 o third node of the neighbouring triangle (1-based; 0 if not found) +// --------------------------------------------------------------------------- +void msho26(std::span kelem, + int nelem, + int i2, + int i3, + int& jelem, + int& i4) +{ + const int ielem = jelem; + jelem = 0; + i4 = 0; + + for (int j = 0; j < nelem; ++j) + { + if (j == ielem) continue; // skip known element (0-based) + + const int j1 = kelem[3 * j]; + const int j2 = kelem[3 * j + 1]; + const int j3 = kelem[3 * j + 2]; + + if (j1 == i3 && j2 == i2) { jelem = j; i4 = j3; return; } + else if (j2 == i3 && j3 == i2) { jelem = j; i4 = j1; return; } + else if (j3 == i3 && j1 == i2) { jelem = j; i4 = j2; return; } + } +} + +// --------------------------------------------------------------------------- +// msho27 – Select best diagonal in quadrilateral (i1,i2,i3,i4) +// Current diagonal is i2–i3; may be replaced by i1–i4. +// +// coor i/o node coordinate array (interleaved flat) +// i1,i2,i3,i4 i/o quadrilateral nodes; may be reordered on output +// --------------------------------------------------------------------------- +void msho27(std::span coor, + int& i1, + int& i2, + int& i3, + int& i4, + const SepranContext& ctx) +{ + const int j1 = i1, j2 = i2, j3 = i3, j4 = i4; + + const double xa = coor[2 * (i1 - 1)], ya = coor[2 * (i1 - 1) + 1]; + const double xb = coor[2 * (i2 - 1)], yb = coor[2 * (i2 - 1) + 1]; + const double xc = coor[2 * (i3 - 1)], yc = coor[2 * (i3 - 1) + 1]; + const double xd = coor[2 * (i4 - 1)], yd = coor[2 * (i4 - 1) + 1]; + + const double det = (xa - xb) * (ya - yc) - (xa - xc) * (ya - yb); + + if (std::abs(det) < 10.0 * ctx.epsmac) + { + // Triangle 1-2-3 degenerate — use diagonal 1–4 + i1 = j2; i2 = j4; i3 = j1; i4 = j3; + } + else + { + // Circumcentre of triangle i1-i2-i3 + const double xm = ((xa*xa + ya*ya) * (yb - yc) + + (xb*xb + yb*yb) * (yc - ya) + + (xc*xc + yc*yc) * (ya - yb)) / (2.0 * det); + const double ym = ((xa*xa + ya*ya) * (xb - xc) + + (xb*xb + yb*yb) * (xc - xa) + + (xc*xc + yc*yc) * (xa - xb)) / (-2.0 * det); + + const double af1 = (xa - xm)*(xa - xm) + (ya - ym)*(ya - ym); + const double af2 = (xd - xm)*(xd - xm) + (yd - ym)*(yd - ym); + + if (af2 < af1) + { + // d is inside circumcircle — swap diagonal + i1 = j2; i2 = j4; i3 = j1; i4 = j3; + } + } +} + +// --------------------------------------------------------------------------- +// msho28 – Check whether any boundary point lies strictly inside triangle +// (i1, i2, i3) or triangle (i1, i2, (xn,yn)) when i3==0. +// +// coor i node coordinate array (interleaved flat) +// i1,i2 i first two nodes (1-based) +// i3 i third node (1-based); if 0 use (xn,yn) instead +// xn, yn i coordinates of virtual third vertex (used when i3==0) +// npoint i total node count +// itri i per-node boundary membership counter +// iperm o 1 = at least one interior point found; 0 = none +// --------------------------------------------------------------------------- +void msho28(std::span coor, + int i1, + int i2, + int i3, + double xn, + double yn, + int npoint, + std::span itri, + int& iperm, + const SepranContext& ctx) +{ + iperm = 1; + const double eps = 1.0e-2 * ctx.epsmac; + + const double x1 = coor[2 * (i1 - 1)], y1 = coor[2 * (i1 - 1) + 1]; + const double x2 = coor[2 * (i2 - 1)], y2 = coor[2 * (i2 - 1) + 1]; + double x3, y3; + if (i3 == 0) { x3 = xn; y3 = yn; } + else { x3 = coor[2*(i3-1)]; y3 = coor[2*(i3-1)+1]; } + + const double norm = std::abs(x1)+std::abs(x2)+std::abs(x3)+ + std::abs(y1)+std::abs(y2)+std::abs(y3); + const double det = x1*(y2-y3) + x2*(y3-y1) + x3*(y1-y2); + + for (int i = 1; i <= npoint; ++i) + { + if (i == i1 || i == i2 || i == i3 || itri[i - 1] == 0) continue; + + const double xm = coor[2 * (i - 1)]; + const double ym = coor[2 * (i - 1) + 1]; + + double opp = (x1*(y2 - ym) + x2*(ym - y1) + xm*(y1 - y2)) / det; + if (opp < -eps || opp > 1.0 + eps) continue; + + opp = (x2*(y3 - ym) + x3*(ym - y2) + xm*(y2 - y3)) / det; + if (opp < -eps || opp > 1.0 + eps) continue; + + opp = (x3*(y1 - ym) + x1*(ym - y3) + xm*(y3 - y1)) / det; + if (opp < -eps || opp > 1.0 + eps) continue; + + // Check for "double" point coinciding with corner i1 + double dist = std::abs(x1 - xm) + std::abs(y1 - ym); + if (dist < eps * norm) continue; + + dist = std::abs(x2 - xm) + std::abs(y2 - ym); + if (dist < eps * norm) continue; + + // Point i is strictly inside and not a double — found + return; // iperm == 1 + } + + iperm = 0; // no interior point found +} + +// --------------------------------------------------------------------------- +// msho29 – Remove internal nodes that have exactly 3 or 4 neighbours +// +// kelem i/o element array (flat triples) +// nelem i/o number of elements +// npoint i total node count +// iwork i CSR row-pointer array for ibuurp (length npoint) +// ibuurp i CSR adjacency list (ibuurp[iwork[i-2]..iwork[i-1]-1] for node i) +// nipnt i number of boundary nodes (indices 1..nipnt are fixed) +// coor i node coordinate array (interleaved flat) +// icancel i/o counter of cancelled points +// --------------------------------------------------------------------------- +void msho29(std::span kelem, + int& nelem, + int npoint, + std::span iwork, + std::span ibuurp, + int nipnt, + std::span coor, + int& icancel) +{ + icancel = 0; + + for (int i = nipnt + 1; i <= npoint; ++i) + { + const int prevPtr = (i > 1) ? iwork[i - 2] : 0; + const int np = iwork[i - 1] - prevPtr; + + if (np == 3) + { + const int ia = ibuurp[prevPtr]; + const int ib = ibuurp[prevPtr + 1]; + const int ic = ibuurp[prevPtr + 2]; + + icancel++; + + // Remove all triangles containing node i; keep the rest + int nel = 0; + for (int j = 0; j < nelem; ++j) + { + const int e1 = kelem[3*j], e2 = kelem[3*j+1], e3 = kelem[3*j+2]; + if (e1 != i && e2 != i && e3 != i) + { + kelem[3*nel] = e1; + kelem[3*nel+1] = e2; + kelem[3*nel+2] = e3; + nel++; + } + } + + // Add one new triangle ia-ib-ic (with correct orientation) + const double opp = triangleArea(coor, ia, ib, ic); + if (opp > 0.0) + { + kelem[3*nel] = ia; + kelem[3*nel+1] = ib; + kelem[3*nel+2] = ic; + } + else + { + kelem[3*nel] = ia; + kelem[3*nel+1] = ic; + kelem[3*nel+2] = ib; + } + nelem = nel + 1; + } + else if (np == 4) + { + // Read the 4 neighbours for the neighbour-check only + const int ia_nb = ibuurp[prevPtr]; + const int ib_nb = ibuurp[prevPtr + 1]; + const int ic_nb = ibuurp[prevPtr + 2]; + const int id_nb = ibuurp[prevPtr + 3]; + + // Skip if any neighbour itself has 3 neighbours, or a lower-index + // neighbour with 4 (would already have been removed) + auto neighbourCheck = [&](int nx) -> bool + { + if (nx <= nipnt) return false; + const int prevNx = (nx > 1) ? iwork[nx - 2] : 0; + const int iex = iwork[nx - 1] - prevNx; + return (iex == 3 || (nx < i && iex == 4)); + }; + + if (neighbourCheck(ia_nb) || neighbourCheck(ib_nb) || + neighbourCheck(ic_nb) || neighbourCheck(id_nb)) + continue; + + // Snapshot before compacting so we can roll back if ring is degenerate. + const int nelemBefore = nelem; + std::vector kelemBackup(3 * nelemBefore); + std::copy_n(kelem.begin(), 3 * nelemBefore, kelemBackup.begin()); + + icancel += 1000; + + // Direct Fortran translation: compact kelem removing triangles that + // contain node i, and simultaneously find ia,ib (first triangle) and + // ic,id ("opposite" triangle – the one sharing neither ia nor ib). + int ia = 0, ib = 0, ic = 0, id = 0; + int iex = 0; + int nel = 0; + + for (int j = 0; j < nelem; ++j) + { + const int e1 = kelem[3*j], e2 = kelem[3*j+1], e3 = kelem[3*j+2]; + + if (e1 != i && e2 != i && e3 != i) + { + kelem[3*nel] = e1; + kelem[3*nel+1] = e2; + kelem[3*nel+2] = e3; + nel++; + } + else + { + // The two ring nodes in this triangle (CCW relative order) + int n1, n2; + if (e1 == i) { n1 = e2; n2 = e3; } + else if (e2 == i) { n1 = e3; n2 = e1; } + else { n1 = e1; n2 = e2; } + + if (iex == 0) + { + ia = n1; ib = n2; + iex = 1; + } + else if (iex == 1) + { + // Accept the "opposite" triangle: neither ring node may + // equal ia or ib (direct translation of Fortran condition). + if (n1 != ia && n1 != ib && n2 != ia && n2 != ib) + { + ic = n1; id = n2; + iex = 2; + } + } + } + } + + // Degenerate ring: restore and skip (Fortran logs error but we skip). + if (ia == 0 || ib == 0 || ic == 0 || id == 0) + { + std::copy_n(kelemBackup.begin(), 3 * nelemBefore, kelem.begin()); + nelem = nelemBefore; + icancel -= 1000; + continue; + } + + // Choose best diagonal and write two new triangles (Fortran §msho27) + msho27(coor, ia, ib, id, ic, SepranContext{}); + + kelem[3*nel] = ia; + kelem[3*nel+1] = ib; + kelem[3*nel+2] = id; + nel++; + + kelem[3*nel] = ib; + kelem[3*nel+1] = ic; + kelem[3*nel+2] = id; + nel++; + + nelem = nel; + } + } +} + +// --------------------------------------------------------------------------- +// msho30 – Refill kstapl and itri after removing triangle ielem and its +// neighbours. Elements nelmfix+1..nelem that share a node with +// ielem are removed; the remaining ones are kept. +// +// kelem i/o element array (flat triples) +// nelem i/o number of elements +// ielem i 1-based index of central triangle to remove +// kstapl o rebuilt boundary edge list (flat pairs) +// kstap o number of edges in kstapl +// npoint i total node count +// itri o per-node boundary membership counter (rebuilt) +// nelmfix i number of elements that are fixed (indices 1..nelmfix) +// --------------------------------------------------------------------------- +void msho30(std::span kelem, + int& nelem, + int ielem, + std::span kstapl, + int& kstap, + int npoint, + std::span itri, + int nelmfix) +{ + const int ia = kelem[3 * (ielem - 1)]; + const int ib = kelem[3 * (ielem - 1) + 1]; + const int ic = kelem[3 * (ielem - 1) + 2]; + + kstap = 0; + int nextra = nelmfix; + + // Helper: add or cancel an edge in kstapl + // Adds edge (n1→n2); if reverse (n2→n1) already in kstapl it removes it. + auto addOrCancelEdge = [&](int n1, int n2) + { + // Handle Plaxis negative nodes: add directly + if (n1 <= -1 && n2 <= -1) + { + kstapl[2 * kstap] = n1; + kstapl[2 * kstap + 1] = n2; + kstap++; + return; + } + + // Check for reverse edge + int jtal = 0; + bool cancelled = false; + for (int is = 0; is < kstap; ++is) + { + const int j1 = kstapl[2 * is]; + const int j2 = kstapl[2 * is + 1]; + if (j1 == n2 && j2 == n1) + { + cancelled = true; // remove this edge (don't copy) + } + else + { + kstapl[2 * jtal] = j1; + kstapl[2 * jtal + 1] = j2; + jtal++; + } + } + kstap = jtal; + if (!cancelled) + { + kstapl[2 * kstap] = n1; + kstapl[2 * kstap + 1] = n2; + kstap++; + } + }; + + for (int i = nelmfix; i < nelem; ++i) // 0-based; Fortran: nelmfix+1..nelem + { + const int i1 = kelem[3 * i]; + const int i2 = kelem[3 * i + 1]; + const int i3 = kelem[3 * i + 2]; + + const bool shared = (i1 == ia || i1 == ib || i1 == ic || + i2 == ia || i2 == ib || i2 == ic || + i3 == ia || i3 == ib || i3 == ic); + + if (shared) + { + addOrCancelEdge(i1, i2); + addOrCancelEdge(i2, i3); + addOrCancelEdge(i3, i1); + } + else + { + // Keep this element in the nextra zone + kelem[3 * nextra] = i1; + kelem[3 * nextra + 1] = i2; + kelem[3 * nextra + 2] = i3; + nextra++; + } + } + nelem = nextra; + + // Rebuild itri from kstapl + for (int i = 0; i < npoint; ++i) itri[i] = 0; + for (int s = 0; s < kstap; ++s) + { + itri[kstapl[2*s] - 1]++; + itri[kstapl[2*s + 1] - 1]++; + } +} + +// --------------------------------------------------------------------------- +// msho33 – Triangle quality ratio: 2 * r_in / r_out +// +// coor i node coordinate array (interleaved flat) +// i1, i2, i3 i triangle nodes (1-based) +// ratio o quality measure in [0,1]; equilateral → 1 +// --------------------------------------------------------------------------- +void msho33(std::span coor, + double& ratio, + int i1, + int i2, + int i3) +{ + const double x1 = coor[2*(i1-1)], y1 = coor[2*(i1-1)+1]; + const double x2 = coor[2*(i2-1)], y2 = coor[2*(i2-1)+1]; + const double x3 = coor[2*(i3-1)], y3 = coor[2*(i3-1)+1]; + + const double s1 = std::sqrt((x2-x1)*(x2-x1) + (y2-y1)*(y2-y1)); + const double s2 = std::sqrt((x3-x2)*(x3-x2) + (y3-y2)*(y3-y2)); + const double s3 = std::sqrt((x1-x3)*(x1-x3) + (y1-y3)*(y1-y3)); + + const double s = 0.5 * (s1 + s2 + s3); + const double opp = std::sqrt(s * (s - s1) * (s - s2) * (s - s3)); + + const double ro = (s1 * s2 * s3) / (4.0 * opp); + const double ri = opp / s; + + ratio = 2.0 * ri / ro; +} + +// --------------------------------------------------------------------------- +// msho34 – Find the user-point indices ius1, ius2 of the start and end of +// the boundary curve on which node kpoint lies. +// +// kpoint i node with overly large coarseness (1-based) +// coor i node coordinate array (interleaved flat) +// ncurvs i number of internal curves +// curves i node counts per internal curve +// kbndpt i ordered boundary node array (all curves concatenated) +// nbndpt i length of kbndpt +// numcurvboun i number of boundary curves +// boundary i flat (2×(numcurvboun+...)) start/end indices into kbndpt +// boundary[2*(i-1)] = curve number, +// boundary[2*(i-1)+1] = start position in kbndpt +// nbound i number of nodes in boundary curves - 1 +// nholes i number of holes +// userco i user-specified coordinates (2-component interleaved) +// nuspnt i number of user points +// coaval i coarseness values (length nuspnt+1) +// ius1 o start user-point index (1-based) +// ius2 o end user-point index (1-based) +// --------------------------------------------------------------------------- +void msho34(int kpoint, + std::span coor, + int ncurvs, + std::span curves, + std::span kbndpt, + int nbndpt, + int numcurvboun, + std::span boundary, + int nbound, + int nholes, + std::span userco, + int nuspnt, + std::span coaval, + int& ius1, + int& ius2) +{ + (void)nbndpt; (void)coaval; // unused in this path + + const double xk = coor[2*(kpoint-1)]; + const double yk = coor[2*(kpoint-1)+1]; + (void)xk; (void)yk; + + bool found = false; + int bndStart = 0; // renamed from local 'istart' to avoid confusion + double xst = 9999.0, yst = 9999.0; + double xen = 9999.0, yen = 9999.0; + + int n2_prev = 0; // tracks n2 across loops for the internal-curves continuation + + // --- Search through boundary curves + for (int i = 1; i <= numcurvboun && !found; ++i) + { + int n1, n2; + if (i < numcurvboun) + { + // boundary(2,i) and boundary(2,i+1) in Fortran + n1 = boundary[2*(i-1) + 1]; + n2 = boundary[2*i + 1]; + } + else + { + n1 = boundary[2*(i-1) + 1]; + n2 = nbound + 1 + nholes; + } + + if (bndStart == 0) bndStart = kbndpt[n1 - 1]; // kbndpt(n1) 1-based + + if (n2 > n1 + 1 && kbndpt[n2 - 2] == bndStart) // kbndpt(n2-1) + { + n2 = n2 - 1; + bndStart = 0; + } + + for (int j = n1; j <= n2; ++j) + { + if (kpoint == kbndpt[j - 1]) // kbndpt(j) 1-based + { + xst = coor[2*(kbndpt[n1-1]-1)]; + yst = coor[2*(kbndpt[n1-1]-1)+1]; + xen = coor[2*(kbndpt[n2-1]-1)]; + yen = coor[2*(kbndpt[n2-1]-1)+1]; + found = true; + break; + } + } + n2_prev = n2; + } + + // --- If not found on boundary curves, search internal curves + for (int i = 1; i <= ncurvs && !found; ++i) + { + const int n1 = n2_prev + 1; + const int n2 = n1 + curves[i - 1] - 1; + + for (int j = n1; j <= n2; ++j) + { + if (kpoint == kbndpt[j - 1]) + { + xst = coor[2*(kbndpt[n1-1]-1)]; + yst = coor[2*(kbndpt[n1-1]-1)+1]; + xen = coor[2*(kbndpt[n2-1]-1)]; + yen = coor[2*(kbndpt[n2-1]-1)+1]; + found = true; + break; + } + } + n2_prev = n2; + } + + if (!found) + throw std::runtime_error("msho34: node kpoint not found on any curve"); + + // --- Map start/end coordinates to user-point indices + ius1 = 0; ius2 = 0; + for (int i = 1; i <= nuspnt; ++i) + { + const double xt = userco[2*(i-1)]; + const double yt = userco[2*(i-1)+1]; + + if (std::sqrt((xst-xt)*(xst-xt)+(yst-yt)*(yst-yt)) < 1.0e-8) ius1 = i; + if (std::sqrt((xen-xt)*(xen-xt)+(yen-yt)*(yen-yt)) < 1.0e-8) ius2 = i; + } +} + +// --------------------------------------------------------------------------- +// msho39 – Check whether coarsenesses cmin and cmax at two endpoints that +// are dist apart are geometrically compatible. +// +// cmax i/o coarseness at far end; may be reduced if not compatible +// cmin i coarseness at near end +// dist i Euclidean distance between the two points +// maxratio i maximum allowed ratio between successive element lengths +// iallow o 1 = compatible; 0 = cmax was adjusted +// --------------------------------------------------------------------------- +void msho39(double& cmax, + double cmin, + double dist, + double maxratio, + int& iallow) +{ + iallow = 1; + + if (dist < cmin) + { + iallow = 0; + cmax = dist; + } + else if (dist > cmin) + { + double afst = 0.6 * cmin; + double som = afst; + while (som < dist) + { + afst *= maxratio; + som += afst; + } + if (afst < 0.5 * cmax) + { + iallow = 0; + cmax = afst; + } + } +} + +// --------------------------------------------------------------------------- +// msho41 – Compute the maximum allowed coarseness cmax in point B given +// coarseness cmin in point A at Euclidean distance dist. +// +// cmin i coarseness at A +// cmax i/o i: user-given coarseness at B; o: adjusted max allowed +// dist i Euclidean distance A→B +// maxratio i maximum ratio between consecutive element lengths +// --------------------------------------------------------------------------- +void msho41(double cmin, + double& cmax, + double dist, + double maxratio) +{ + if (dist < cmin) + { + cmax = cmin; + } + else if (dist > cmin) + { + double afst = 0.65 * cmin; + double som = afst; + while (som < dist) + { + afst *= maxratio; + som += afst; + } + if (afst < cmax) cmax = afst; + } +} + +// --------------------------------------------------------------------------- +// msho42 – Check whether the line segment i→j is part of an internal boundary +// +// kbndpt i flat array of internal boundary pairs (node-pair sequence) +// lenbnd i length of kbndpt +// i i first node (1-based) +// j i second node (1-based) +// ja o 1 = i–j is an internal boundary segment; 0 = not +// --------------------------------------------------------------------------- +void msho42(std::span kbndpt, + int lenbnd, + int i, + int j, + int& ja) +{ + ja = 0; + for (int k = 0; k + 1 < lenbnd; k += 2) + { + const int ia = kbndpt[k]; + const int ib = kbndpt[k + 1]; + if ((ia == i && ib == j) || (ia == j && ib == i)) + { + ja = 1; + return; + } + } +} + +// --------------------------------------------------------------------------- +// msho75 (internal) – Check whether line segment (xi,yi)→(xj,yj) and +// segment (x1,y1)→(x2,y2) share an interior point. +// +// ih o 0 = common point exists; 1 = no common point +// --------------------------------------------------------------------------- +static void checkSegmentIntersection(double xi, + double yi, + double xj, + double yj, + double x1, + double y1, + double x2, + double y2, + int& ih, + const SepranContext& ctx) +{ + const double eps = 10.0 * ctx.epsmac; + ih = 1; // default: no intersection + + // Bounding-box pre-check + const double xmin = std::min(xi, xj), xmax = std::max(xi, xj); + const double ymin = std::min(yi, yj), ymax = std::max(yi, yj); + const double xmi = std::min(x1, x2), xma = std::max(x1, x2); + const double ymi = std::min(y1, y2), yma = std::max(y1, y2); + + if (xmi > xmax || xma < xmin || ymi > ymax || yma < ymin) return; + + const bool xiNeqXj = std::abs(xi - xj) > eps * (std::abs(xi) + std::abs(xj)); + const bool x1NeqX2 = std::abs(x1 - x2) > eps * (std::abs(x1) + std::abs(x2)); + + if (xiNeqXj) + { + if (x1NeqX2) + { + // General case: neither line is vertical + const double r1 = (y1*x2 - y2*x1) / (x2 - x1); + const double r2 = (yi*xj - yj*xi) / (xj - xi); + const double r3 = (yj - yi) / (xj - xi); + const double r4 = (y2 - y1) / (x2 - x1); + + if (std::abs(r3 - r4) > eps) + { + const double xs = (r1 - r2) / (r3 - r4); + const bool inIJ = (xi < xs && xj > xs) || (xj < xs && xi > xs) || + std::abs(xi - xs) < eps || std::abs(xj - xs) < eps; + const bool in12 = (x1 < xs && x2 > xs) || (x2 < xs && x1 > xs) || + std::abs(x1 - xs) < eps || std::abs(x2 - xs) < eps; + if (inIJ && in12) ih = 0; + } + } + else + { + // x1 == x2: line 1-2 is vertical, line i-j is not + if (std::abs(yi - yj) < eps) + { + // i-j is horizontal, 1-2 is vertical + const double xs = x1, ys = yi; + const bool ok = !((xi < xs && xj < xs) || (xi > xs && xj > xs) || + (y1 < ys && y2 < ys) || (y1 > ys && y2 > ys)); + if (ok) ih = 0; + } + else + { + // General vertical 1-2 case + const double ys = ((yj - yi) * x1 + yi * xj - yj * xi) / (xj - xi); + const bool in12 = (y1 < ys && y2 > ys) || (y2 < ys && y1 > ys) || + std::abs(y1 - ys) < eps || std::abs(y2 - ys) < eps; + const bool inIJ = (yi < ys && yj > ys) || (yj < ys && yi > ys) || + std::abs(yi - ys) < eps || std::abs(yj - ys) < eps; + if (in12 && inIJ) ih = 0; + } + } + } + else + { + // xi == xj: line i-j is vertical + if (x1NeqX2) + { + if (std::abs(y1 - y2) < eps) + { + // i-j vertical, 1-2 horizontal + const double xs = xi, ys = y1; + const bool ok = !((yi < ys && yj < ys) || (yi > ys && yj > ys) || + (x1 < xs && x2 < xs) || (x1 > xs && x2 > xs)); + if (ok) ih = 0; + } + else + { + const double ys = ((y2 - y1) * xi + y1*x2 - y2*x1) / (x2 - x1); + const bool inIJ = (yi < ys && yj > ys) || (yj < ys && yi > ys) || + std::abs(yi - ys) < eps || std::abs(yj - ys) < eps; + const bool in12 = (y1 < ys && y2 > ys) || (y2 < ys && y1 > ys) || + std::abs(y1 - ys) < eps || std::abs(y2 - ys) < eps; + if (inIJ && in12) ih = 0; + } + } + else + { + // Both lines are vertical + if (std::abs(x1 - xi) < eps * (std::abs(x1) + std::abs(xi))) ih = 0; + } + } +} + +// --------------------------------------------------------------------------- +// msho04 – Bounding box of all npoint nodes +// --------------------------------------------------------------------------- +void msho04(std::span coor, + int npoint, + double& xmin, double& xmax, + double& ymin, double& ymax, + const SepranContext& ctx) +{ + xmax = -ctx.rinfin; xmin = ctx.rinfin; + ymax = -ctx.rinfin; ymin = ctx.rinfin; + + for (int i = 0; i < npoint; ++i) + { + const double x = coor[2 * i]; + const double y = coor[2 * i + 1]; + xmin = std::min(xmin, x); xmax = std::max(xmax, x); + ymin = std::min(ymin, y); ymax = std::max(ymax, y); + } +} + +// --------------------------------------------------------------------------- +// msho05 – Extreme coarsenesses in dist array +// --------------------------------------------------------------------------- +void msho05(std::span dist, + int npoint, + double& dismin, double& dismax, + const SepranContext& ctx) +{ + const double eps = 10.0 * ctx.epsmac; + dismin = ctx.rinfin; + dismax = -ctx.rinfin; + + for (int i = 0; i < npoint; ++i) + { + const double d = dist[i]; + if (d > eps) { dismin = std::min(dismin, d); dismax = std::max(dismax, d); } + } +} + +// --------------------------------------------------------------------------- +// msho06 – Fill coarseness grid (cube/jcube) from boundary and internal data +// --------------------------------------------------------------------------- +void msho06(int npoint, + std::span coor, + double dist, double xstart, double ystart, + int nx, int ny, + std::span icube, + std::span chelp, + std::span cube, + std::span jcube, + std::span kbound, + int nbound, + std::span coar, + int ncoar, + int ncurvs, + std::span curves, + std::span cocurvs, + const SepranContext& ctx) +{ + const double eps = 10.0 * ctx.epsmac; + double coa = ctx.rinfin; + + // --- Assign each boundary node to a cube + for (int i = 0; i < npoint; ++i) + { + const double xp = coor[2 * i]; + const double yp = coor[2 * i + 1]; + const int n1 = static_cast((xp - xstart) / dist); + const int n2 = static_cast((yp - ystart) / dist); + const int nc = 1 + n1 + n2 * nx; + icube[i] = nc; + if (chelp[i] > eps && chelp[i] < coa) coa = chelp[i]; + } + + // --- Initialise cube coarsenesses: average chelp of nodes in each cube + for (int i = 0; i < nx * ny; ++i) { jcube[i] = 0; cube[i] = 0.0; } + + for (int i = 0; i < nx * ny; ++i) + { + int ntal = 0; + double coarse = 0.0; + for (int ik = 0; ik < npoint; ++ik) + { + if (chelp[ik] > eps && icube[ik] == i + 1) + { + ++ntal; + coarse += chelp[ik]; + } + } + if (ntal > 0) { cube[i] = coarse / ntal; jcube[i] = 1; } + } + + // --- Fill boundary-edge cubes along path of each edge + for (int e = 0; e < nbound; ++e) + { + const int i1 = kbound[2 * e]; + const int i2 = kbound[2 * e + 1]; + const double cgem = (chelp[i1 - 1] + chelp[i2 - 1]) * 0.5; + + const int n1i1 = static_cast((coor[2*(i1-1)] - xstart) / dist); + const int n2i1 = static_cast((coor[2*(i1-1)+1] - ystart) / dist); + const int n1i2 = static_cast((coor[2*(i2-1)] - xstart) / dist); + const int n2i2 = static_cast((coor[2*(i2-1)+1] - ystart) / dist); + + for (int n1 = std::min(n1i1,n1i2); n1 <= std::max(n1i1,n1i2); ++n1) + for (int n2 = std::min(n2i1,n2i2); n2 <= std::max(n2i1,n2i2); ++n2) + { + const int nc = 1 + n1 + n2 * nx; + if (cube[nc-1] < eps) { cube[nc-1] = cgem; jcube[nc-1] = 1; } + } + } + + // --- Internal curves + if (ncurvs > 0) + { + int nnodes = 0; + for (int i = 0; i < ncurvs; ++i) + { + for (int j = nnodes; j < nnodes + curves[i] - 1; ++j) + { + const double dx = cocurvs[2*(j+1)] - cocurvs[2*j]; + const double dy = cocurvs[2*(j+1)+1] - cocurvs[2*j+1]; + const double afst = std::sqrt(dx*dx + dy*dy); + const double xp = (cocurvs[2*(j+1)] + cocurvs[2*j]) * 0.5; + const double yp = (cocurvs[2*(j+1)+1] + cocurvs[2*j+1]) * 0.5; + const int n1 = static_cast((xp - xstart) / dist); + const int n2 = static_cast((yp - ystart) / dist); + const int nc = 1 + n1 + n2 * nx; + if (jcube[nc-1] == 0) { cube[nc-1] = afst; jcube[nc-1] = 1; } + else if (jcube[nc-1] > 0) { cube[nc-1] = (cube[nc-1] + afst) * 0.5; } + } + nnodes += curves[i]; + } + } + + // --- Extra coarseness points + for (int i = 0; i < ncoar; ++i) + { + const double xp = coar[3*i]; + const double yp = coar[3*i+1]; + const int n1 = static_cast((xp - xstart) / dist); + const int n2 = static_cast((yp - ystart) / dist); + const int nc = 1 + n1 + n2 * nx; + cube[nc-1] = coar[3*i+2]; + jcube[nc-1] = 1; + } + + // --- Interpolate empty interior cubes + for (int i = 1; i <= nx; ++i) + for (int j = 1; j <= ny; ++j) + { + const int nrkube = i + (j-1)*nx; + if (jcube[nrkube-1] != 0 || cube[nrkube-1] >= eps) continue; + + double coxmin = coa, coxmax = coa; + int ikxmin = 0, ikxmax = 0; + + for (int ik = (j-1)*nx + 1; ik < nrkube; ++ik) + if (jcube[ik-1]==1) { ikxmin = ik; coxmin = cube[ik-1]; } + for (int ik = j*nx; ik > nrkube; --ik) + if (jcube[ik-1]==1) { ikxmax = ik; coxmax = cube[ik-1]; break; } + + double coymin = coa, coymax = coa; + int ikymin = 0, ikymax = 0; + + for (int ik = i; ik < nrkube; ik += nx) + if (jcube[ik-1]==1) { ikymin = ik; coymin = cube[ik-1]; } + for (int ik = i + (ny-1)*nx; ik > nrkube; ik -= nx) + if (jcube[ik-1]==1) { ikymax = ik; coymax = cube[ik-1]; break; } + + double deel = 0.0, cox = 0.0, coy = 0.0; + const int jblokx = ikxmax * ikxmin; + if (jblokx != 0) + { + if (jblokx > 0) + { + const double alpha = std::pow(coxmax/coxmin, 1.0/(ikxmax-ikxmin)); + cox = coxmin * std::pow(alpha, static_cast(nrkube-ikxmin)); + } + else + { + const double alpha = (nrkube-ikxmin) * (1.0/(ikxmax-ikxmin)); + cox = coxmin + alpha * (coxmax-coxmin); + } + ++deel; + cube[nrkube-1] = cox; + } + + const int jbloky = ikymax * ikymin; + if (jbloky != 0) + { + if (jbloky > 0) + { + const double alpha = std::pow(coymax/coymin, + 1.0/(static_cast(ikymax-ikymin)/nx)); + coy = coymin * std::pow(alpha, static_cast(nrkube-ikymin)/nx); + } + else + { + const double alpha = (nrkube-ikymin) * (1.0/(ikymax-ikymin)); + coy = coymin + alpha * (coymax-coymin); + } + ++deel; + cube[nrkube-1] = (cube[nrkube-1] + coy) / deel; + } + + if (deel > 0.5) jcube[nrkube-1] = 2; + } + + // --- Fill empty cubes with a background value + double valmin = ctx.rinfin, valmax = 0.0; + for (int i = 0; i < nx*ny; ++i) + { + if (cube[i] > eps) { valmin = std::min(valmin,cube[i]); valmax = std::max(valmax,cube[i]); } + } + coa = (valmax + 3.0*valmin) / 4.0; + for (int i = 0; i < nx*ny; ++i) + if (cube[i] < valmin) cube[i] = coa; + + // --- Clamp: no cube may exceed 2.75× its minimum neighbour + bool changed = true; + while (changed && nx > 2 && ny > 2) + { + changed = false; + for (int i = nx-2; i >= 1; --i) + for (int j = ny-2; j >= 1; --j) + { + const int nrkube = i + j*nx; // 0-based + if (jcube[nrkube] != 2) continue; + const double vmin = std::min({cube[nrkube-nx], cube[nrkube-1], + cube[nrkube+1], cube[nrkube+nx]}); + if (cube[nrkube] > 2.75*vmin) { cube[nrkube] = 2.75*vmin; changed = true; } + } + } +} + +// --------------------------------------------------------------------------- +// msho07 – Point-in-polygon test via ray casting +// --------------------------------------------------------------------------- +void msho07(double xcub, double ycub, + double xmini, + std::span coor, + std::span kbound, + int nbound, + int& ja, + const SepranContext& ctx) +{ + const double xleft = xmini - 10.0; + const double yleft = ycub; + int isnij = 0; + ja = 0; + + for (int i = 0; i < nbound; ++i) + { + const int i1 = kbound[2 * i]; + const int i2 = kbound[2 * i + 1]; + + const double x1 = coor[2*(i1-1)], y1 = coor[2*(i1-1)+1]; + const double x2 = coor[2*(i2-1)], y2 = coor[2*(i2-1)+1]; + + const double xmin = std::min(x1,x2); + const double ymin = std::min(y1,y2); + const double ymax = std::max(y1,y2); + + if (xcub < xmin) continue; + if (ycub < ymin) continue; + if (ycub > ymax) continue; + + if (!segmentsIntersect(x1, y1, x2, y2, xleft, yleft, xcub, ycub, ctx)) + continue; + + ++isnij; + } + + if ((isnij % 2) != 0) ja = 1; +} + +// --------------------------------------------------------------------------- +// msho08 – Check and fix orientation of front edges +// --------------------------------------------------------------------------- +void msho08(std::span kstapl, + int kstap, + std::span coor, + double xstart, double dismin, + std::span holeinfo, + int nholes, + bool check, + SepranContext& ctx) +{ + constexpr double eps = 1.0e-5; + int icount = 0; + + for (int i = 0; i < kstap; ++i) + { + const int i1 = kstapl[2 * i]; + const int i2 = kstapl[2 * i + 1]; + + kstapl[2 * kstap + i] = 0; + + double e1, e2, xm, ym; + msho09(coor, i1, i2, e1, e2, xm, ym); + + double xn = xm + eps * e1 * dismin; + double yn = ym + eps * e2 * dismin; + + int ja = 0; + msho07(xn, yn, xstart, coor, kstapl.subspan(0, 2 * kstap), kstap, ja, ctx); + + if (ja == 0) + { + if (check) + { + ctx.ierror = 1; + throw std::runtime_error( + "msho08: boundary edge (" + std::to_string(i1) + "," + + std::to_string(i2) + ") has wrong orientation (error 2434)"); + } + std::swap(kstapl[2 * i], kstapl[2 * i + 1]); + } + + if (icount < nholes && holeinfo[2 * icount + 1] == i1) // holeinfo(2,icount) 1-based + { + if (ja == 0) holeinfo[2 * icount] = -holeinfo[2 * icount]; // negate + if (icount < nholes) ++icount; + } + + if (ja == 1) + { + xn = xm - eps * e1 * dismin; + yn = ym - eps * e2 * dismin; + ja = 0; + msho07(xn, yn, xstart, coor, kstapl.subspan(0, 2 * kstap), kstap, ja, ctx); + if (ja == 1) kstapl[2 * kstap + i] = 1; // double edge + } + } + + // --- Repair connectivity for double (internal) edges + int iloop = 0; + int ichange = 1; + + while (ichange == 1) + { + ichange = 0; + + for (int i = 0; i < kstap - 1; ++i) + { + if (kstapl[2 * kstap + i] != 0) continue; + + const int i1 = kstapl[2 * i]; + const int i2 = kstapl[2 * i + 1]; + + int ih1 = 1, ih2 = 1; + + for (int j = 0; j < kstap; ++j) + { + if (kstapl[2 * kstap + j] != 0 || j == i) continue; + const int j1 = kstapl[2 * j]; + const int j2 = kstapl[2 * j + 1]; + if (j1 == i2) ih2 = 0; + if (j2 == i1) ih1 = 0; + } + + if (ih1 + ih2 > 0) + { + for (int j = 0; j < kstap; ++j) + { + if (kstapl[2 * kstap + j] != 1) continue; + + const int j1 = kstapl[2 * j]; + const int j2 = kstapl[2 * j + 1]; + + if ((j1 == i2 && ih2 > 0) || (j2 == i1 && ih1 > 0)) + { + kstapl[2 * kstap + j] = 0; + ih1 = 0; ih2 = 0; + } + else if ((j1 == i1 && ih1 > 0) || (j2 == i2 && ih2 > 0)) + { + kstapl[2 * kstap + j] = 0; + std::swap(kstapl[2 * j], kstapl[2 * j + 1]); + ichange = 1; + ih1 = 0; ih2 = 0; + } + } + } + } + + ++iloop; + if (iloop > 1000) + { + ctx.ierror = 1; + throw std::runtime_error("msho08: internal error - failed to repair front connectivity (error 1274)"); + } + } + + checkStaple(kstapl.subspan(0, 2 * kstap), kstap, "Final check in msho08"); +} + +// --------------------------------------------------------------------------- +// msho15 – Commit new node and triangle; update kstapl and itri +// --------------------------------------------------------------------------- +void msho15(std::span coor, + int& npoint, + std::span kelem, + int& nelem, + std::span kstapl, + int& kstap, + std::span itri, + int i1, int i2, + double xnx, double yny) +{ + ++npoint; + coor[2 * (npoint - 1)] = xnx; + coor[2 * (npoint - 1) + 1] = yny; + + ++nelem; + kelem[3 * (nelem - 1)] = i1; + kelem[3 * (nelem - 1) + 1] = i2; + kelem[3 * (nelem - 1) + 2] = npoint; + + // Remove first edge (left-shift by one pair) + const int twoKstap = 2 * kstap; + for (int ib = 0; ib < twoKstap - 2; ++ib) + kstapl[ib] = kstapl[ib + 2]; + + const int base = twoKstap - 2; + ++kstap; + kstapl[base] = i1; + kstapl[base + 1] = npoint; + kstapl[base + 2] = npoint; + kstapl[base + 3] = i2; + + itri[npoint - 1] = 2; + ++itri[i1 - 1]; + ++itri[i2 - 1]; +} + +// --------------------------------------------------------------------------- +// msho16 – Build full CSR neighbour structure for all mesh nodes +// --------------------------------------------------------------------------- +void msho16(std::span kelem, + int nelem, int npoint, int nipnt, + std::span iwork, + std::span ibuurp, + int& leng, + SepranContext& ctx) +{ + // Count appearances per node in element array + for (int i = 0; i < npoint; ++i) iwork[i] = 0; + + for (int i = 0; i < nelem * 3; ++i) + iwork[kelem[i] - 1]++; // 1-based node index + + // Add 1 for every boundary node + for (int i = 0; i < nipnt; ++i) + iwork[i]++; + + // Convert to cumulative CSR pointers + int isum = 0; + for (int i = 0; i < npoint; ++i) + { + iwork[i] += isum; + isum = iwork[i]; + } + + if (isum > leng) + { + ctx.ierror = 1; + throw std::runtime_error("msho16: declared length of ibuurp is too small (error 903)"); + } + + for (int i = 0; i < isum; ++i) ibuurp[i] = 0; + leng = isum; + + // Fill ibuurp with unique neighbours + for (int i = 0; i < nelem; ++i) + { + const int is = 3 * i; + const int i1 = kelem[is]; + const int i2 = kelem[is + 1]; + const int i3 = kelem[is + 2]; + msho17(ibuurp, iwork, i1, i2); + msho17(ibuurp, iwork, i1, i3); + msho17(ibuurp, iwork, i2, i1); + msho17(ibuurp, iwork, i2, i3); + msho17(ibuurp, iwork, i3, i1); + msho17(ibuurp, iwork, i3, i2); + } +} + +// --------------------------------------------------------------------------- +// msho35 – Place fixed hexagonal clusters for user coarseness points. +// +// Translated from Fortran msho35 (SEPRAN, Niek Praagman, 2005-2008). +// For each special coarseness point in coar[], place the centre node plus +// 6 ring nodes in coor, then add 6 triangles and 6 front edges. +// --------------------------------------------------------------------------- +void msho35(int npoint, + std::span coor, + double xstart, + double ystart, + double dismax, + std::span coar, + int ncoar, + std::span icube, + int nx, + std::span kelem, + int& nelem, + std::span kstapl, + int& kstap, + std::span itri, + int isurnr, + std::span userpoints, + std::span kbndpt, + int& nbndpt, + SepranContext& ctx) +{ + const int npoin = npoint; + // npoint will be incremented as we add nodes; track via local counters + int np = npoint + ncoar; // centre nodes are placed at npoin+1 .. npoin+ncoar + + for (int i = 1; i <= ncoar; ++i) + { + if (ctx.ierror != 0) return; + + // --- Index of 6 ring nodes for coar-point i (0-based i here) + const int npoine = npoin + ncoar + (i - 1) * 6; + + const double dist = coar[3 * (i - 1) + 2]; + const double xp = coar[3 * (i - 1)]; + const double yp = coar[3 * (i - 1) + 1]; + const double eps = 1.0e-10 * dist; + + // --- Check point inside domain + int ja = 0; + msho07(xp + eps, yp + eps, xstart, coor, kstapl.subspan(0, 2 * kstap), kstap, ja, ctx); + + if (ja == 0) + { + ctx.ierror = 1; + throw std::runtime_error( + "msho35: user point " + std::to_string(userpoints[i - 1]) + + " (surface " + std::to_string(isurnr) + ") not inside region (error 1344)"); + } + + // --- Store centre node + nbndpt++; + kbndpt[nbndpt - 1] = npoin + i; + + coor[2 * (npoin + i - 1)] = xp; + coor[2 * (npoin + i - 1) + 1] = yp; + + const int n1 = static_cast((xp - xstart) / dismax); + const int n2 = static_cast((yp - ystart) / dismax); + icube[npoin + i - 1] = 1 + n1 + n2 * nx; + + // --- Six ring points: clockwise hexagon + const std::array offsets = { + -0.40, +0.67, +0.40, +0.67, -0.80, 0.0, + +0.80, 0.0, -0.40, -0.67, +0.40, -0.67 + }; + + for (int k = 0; k < 6; ++k) + { + const double xpoin = xp + offsets[2 * k] * dist; + const double ypoin = yp + offsets[2 * k + 1] * dist; + + ja = 0; + msho07(xpoin + eps, ypoin + eps, xstart, coor, + kstapl.subspan(0, 2 * kstap), kstap, ja, ctx); + + if (ja == 0) + { + ctx.ierror = 1; + throw std::runtime_error( + "msho35: user point " + std::to_string(userpoints[i - 1]) + + " (surface " + std::to_string(isurnr) + ") ring node " + + std::to_string(k + 1) + " outside region (error 1346)"); + } + + ++np; + coor[2 * (np - 1)] = xpoin; + coor[2 * (np - 1) + 1] = ypoin; + icube[np - 1] = 1 + n1 + n2 * nx; + } + + // --- Add 6 triangles (Fortran kelem is 1-based column-major, same node numbering) + // Ring order (1-based relative to npoine): 1,3,5,6,4,2 + const std::array ring = { npoine + 1, npoine + 3, npoine + 5, + npoine + 6, npoine + 4, npoine + 2 }; + const int centre = npoin + i; + + for (int k = 0; k < 6; ++k) + { + const int r1 = ring[k]; + const int r2 = ring[(k + 1) % 6]; + ++nelem; + kelem[3 * (nelem - 1)] = centre; + kelem[3 * (nelem - 1) + 1] = r1; + kelem[3 * (nelem - 1) + 2] = r2; + } + + // --- Adjust boundary array (6 new front edges = ring perimeter) + for (int k = 0; k < 6; ++k) + { + const int r1 = ring[k]; + const int r2 = ring[(k + 1) % 6]; + ++kstap; + kstapl[2 * (kstap - 1)] = r1; + kstapl[2 * (kstap - 1) + 1] = r2; + } + + for (int k = 0; k < 6; ++k) + itri[npoine + k] = 2; + } +} + +// --------------------------------------------------------------------------- +// msho36 – Register internal curve nodes into coor, kstapl, kbndpt. +// +// Translated from Fortran msho36 (SEPRAN, Niek Praagman, 2008-2009). +// --------------------------------------------------------------------------- +void msho36(std::span coor, + int& npoint, + int istep, + int ncurvs, + std::span curves, + std::span cocurvs, + std::span kstapl, + int& kstap, + std::span kbndpt, + int& nbndpt, + double coarsemin, + std::span extquanodes, + std::span coarse, + SepranContext& ctx) +{ + const double eps = 1.0e-6 * coarsemin; + int nnodes = 0; + int ibound = 1; // 1-based index into extquanodes (for quadratic) + + for (int i = 0; i < ncurvs; ++i) + { + if (ctx.ierror != 0) return; + + // Loop over edges of curve i (node indices are 0-based into cocurvs) + for (int j = nnodes; j < nnodes + curves[i] - 1; j += istep) + { + ++npoint; + ++nbndpt; + kbndpt[nbndpt - 1] = npoint; + + coor[2 * (npoint - 1)] = cocurvs[2 * j]; + coor[2 * (npoint - 1) + 1] = cocurvs[2 * j + 1]; + + const double x = cocurvs[2 * j]; + const double y = cocurvs[2 * j + 1]; + + const double dx = cocurvs[2 * (j + 1)] - x; + const double dy = cocurvs[2 * (j + 1) + 1] - y; + coarse[npoint - 1] = std::sqrt(dx * dx + dy * dy); + + // Check for coincidence with earlier node + int npn = 0; + for (int iext = 0; iext < npoint - 1; ++iext) + { + const double ddx = x - coor[2 * iext]; + const double ddy = y - coor[2 * iext + 1]; + if (std::sqrt(ddx * ddx + ddy * ddy) < eps && npn == 0) + { + npn = iext + 1; // 1-based + --npoint; + kbndpt[nbndpt - 1] = npn; + } + } + + // For quadratic: extra midpoint + if (istep == 2) + { + ++npoint; + ++nbndpt; + kbndpt[nbndpt - 1] = npoint; + coor[2 * (npoint - 1)] = cocurvs[2 * (j + 1)]; + coor[2 * (npoint - 1) + 1] = cocurvs[2 * (j + 1) + 1]; + } + + // Augment kstapl (front) in both directions + ++kstap; + if (npn > 0) + { + kstapl[2 * (kstap - 1)] = npn; + kstapl[2 * (kstap - 1) + 1] = npoint + 1; + ++kstap; + kstapl[2 * (kstap - 1)] = npoint + 1; + kstapl[2 * (kstap - 1) + 1] = npn; + + if (istep == 2) + { + extquanodes[ibound + 1] = npn; + extquanodes[ibound + 2] = npoint; + extquanodes[ibound + 3] = npoint + 1; + ibound += 3; + } + } + else + { + kstapl[2 * (kstap - 1)] = npoint + 1 - istep; + kstapl[2 * (kstap - 1) + 1] = npoint + 1; + ++kstap; + kstapl[2 * (kstap - 1)] = npoint + 1; + kstapl[2 * (kstap - 1) + 1] = npoint + 1 - istep; + + if (istep == 2) + { + extquanodes[ibound + 1] = npoint - 1; + extquanodes[ibound + 2] = npoint; + extquanodes[ibound + 3] = npoint + 1; + ibound += 3; + } + } + } + + // --- Last node of curve i + const int jlast = nnodes + curves[i] - 1; // 0-based + const double xlast = cocurvs[2 * jlast]; + const double ylast = cocurvs[2 * jlast + 1]; + + int npn = 0; + for (int iext = 0; iext < npoint - 1; ++iext) + { + const double ddx = xlast - coor[2 * iext]; + const double ddy = ylast - coor[2 * iext + 1]; + if (std::sqrt(ddx * ddx + ddy * ddy) < eps && npn == 0) + npn = iext + 1; // 1-based + } + + if (npn == 0) + { + ++npoint; + ++nbndpt; + kbndpt[nbndpt - 1] = npoint; + coor[2 * (npoint - 1)] = xlast; + coor[2 * (npoint - 1) + 1] = ylast; + + // Coarseness = distance from previous to last + const int jprev = jlast - 1; + const double dx = xlast - cocurvs[2 * jprev]; + const double dy = ylast - cocurvs[2 * jprev + 1]; + coarse[npoint - 1] = std::sqrt(dx * dx + dy * dy); + } + else + { + ++nbndpt; + kbndpt[nbndpt - 1] = npn; + + // Adjust last pair in kstapl: endpoint was written as npoint+1 + // but the real node is npn + kstapl[2 * (kstap - 1)] = npn; + kstapl[2 * (kstap - 2) + 1] = npn; + } + + nnodes += curves[i]; + } + + if (istep == 2 && !extquanodes.empty()) + extquanodes[0] = ibound; +} + +// --------------------------------------------------------------------------- +// msho38 – Check/adjust coarseness smoothness for all boundary and internal +// curves and user-specified coarseness points. +// +// Translated from Fortran msho38 (SEPRAN, Niek Praagman, 2009). +// --------------------------------------------------------------------------- +void msho38(int npoint, + std::span coor, + double dist, + double xstart, + double ystart, + std::span kbndpt, + int nbndpt, + int numcurvboun, + std::span boundary, + int nbound, + int nholes, + int nx, + int ny, + std::span icube, + std::span coarse, + std::span cube, + std::span jcube, + std::span kstapl, + int kstap, + int ncurvs, + std::span curves, + std::span cocurv, + int isurnr, + std::span userco, + int nuspnt, + std::span coaval, + double tran, + const SepranContext& ctx) +{ + (void)dist; (void)xstart; (void)ystart; + (void)nx; (void)ny; + (void)icube; (void)cube; (void)jcube; + (void)ncurvs; (void)cocurv; + (void)isurnr; + + const double eps = 1.0e-9 * coaval[0]; + + // maxratio stored in coaval[nuspnt+1] (0-based, matching coaval(nuspnt+2) Fortran) + const double maxratio = coaval[nuspnt + 1]; + const double csmall = [&]() + { + double v = ctx.rinfin; + for (int i = 0; i < nx * ny; ++i) + if (cube[i] < v && jcube[i] > 0) v = cube[i]; + return v; + }(); + + int iperm = 1; + (void)iperm; + + for (int i = 0; i < npoint - 1; ++i) + for (int j = i + 1; j < npoint; ++j) + { + if (coarse[i] <= eps || coarse[j] <= eps) continue; + + // Euclidean distance + const double afst = nodeDistance(i + 1, j + 1, coor); // 1-based + + double cmax, cmin; + int kpoint; + if (coarse[i] > coarse[j]) + { cmax = coarse[i]; cmin = coarse[j]; kpoint = i + 1; } + else + { cmax = coarse[j]; cmin = coarse[i]; kpoint = j + 1; } + + const double coa = std::abs((cmax - cmin) / (cmax + cmin)); + + if (afst < 0.2 * csmall) + { + int icheck = 0; + msho24(kstapl, kstap, coor, i + 1, j + 1, icheck, ctx); + if (icheck == 0) + { + int ius1 = 0, ius2 = 0; + msho34(kpoint, coor, ncurvs, curves, kbndpt, nbndpt, + numcurvboun, boundary, nbound, nholes, + userco, nuspnt, coaval, ius1, ius2); + // warning, no coaval adjustment for too-small distance + } + } + else if (coa > 0.1) + { + int iallow = 1; + msho39(cmax, cmin, afst, maxratio, iallow); + + int icheck = 0; + if (iallow == 0) + msho24(kstapl, kstap, coor, i + 1, j + 1, icheck, ctx); + + if (iallow == 0 && icheck == 0) + { + iperm = 0; + + msho41(cmin, cmax, afst, maxratio); + + int ius1 = 0, ius2 = 0; + msho34(kpoint, coor, ncurvs, curves, kbndpt, nbndpt, + numcurvboun, boundary, nbound, nholes, + userco, nuspnt, coaval, ius1, ius2); + + if (ius1 == 0 || ius2 == 0) continue; + + const double val1 = coaval[0] * coaval[ius1] / tran; + const double val2 = coaval[0] * coaval[ius2] / tran; + + if (cmax < val1 && cmax < val2) + { + coaval[ius1] = cmax * tran / coaval[0]; + coaval[ius2] = cmax * tran / coaval[0]; + } + else + { + const double x1 = userco[2 * (ius1 - 1)]; + const double y1 = userco[2 * (ius1 - 1) + 1]; + const double x2 = coor[2 * (kpoint - 1)]; + const double y2 = coor[2 * (kpoint - 1) + 1]; + const double x3 = userco[2 * (ius2 - 1)]; + const double y3 = userco[2 * (ius2 - 1) + 1]; + + const double af1 = std::sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1)); + const double af2 = std::sqrt((x2-x3)*(x2-x3)+(y2-y3)*(y2-y3)); + double dif = val1 + af1 * (val2 - val1) / (af1 + af2) - cmax; + + double v1 = val1, v2 = val2; + if (v1 - dif < 0.5 * cmax) v1 = dif + 0.5 * cmax; + if (v2 - dif < 0.5 * cmax) v2 = dif + 0.5 * cmax; + + coaval[ius1] = tran / coaval[0] * (v1 - dif); + coaval[ius2] = tran / coaval[0] * (v2 - dif); + } + } + } + } +} + +// --------------------------------------------------------------------------- +// msho40 – Full mesh self-intersection check. +// +// Translated from Fortran msho40 (SEPRAN, Niek Praagman, 2009-2010). +// Returns iperm = 1 if intersections are found, 0 if clean. +// --------------------------------------------------------------------------- +void msho40(std::span coor, + std::span kelem, + int npoint, int nelem, + int& iperm) +{ + constexpr double eps = 1.0e-5; + iperm = 0; + + // --- Barycentre check: no barycentre of one triangle may lie inside another + for (int ie = 0; ie < nelem; ++ie) + { + const int i1 = kelem[3 * ie]; + const int i2 = kelem[3 * ie + 1]; + const int i3 = kelem[3 * ie + 2]; + + const double x1 = coor[2*(i1-1)], y1 = coor[2*(i1-1)+1]; + const double x2 = coor[2*(i2-1)], y2 = coor[2*(i2-1)+1]; + const double x3 = coor[2*(i3-1)], y3 = coor[2*(i3-1)+1]; + + const double xm = (x1 + x2 + x3) / 3.0; + const double ym = (y1 + y2 + y3) / 3.0; + + for (int je = 0; je < nelem; ++je) + { + if (je == ie) continue; + + const int j1 = kelem[3 * je]; + const int j2 = kelem[3 * je + 1]; + const int j3 = kelem[3 * je + 2]; + + const double a1 = coor[2*(j1-1)], b1 = coor[2*(j1-1)+1]; + const double a2 = coor[2*(j2-1)], b2 = coor[2*(j2-1)+1]; + const double a3 = coor[2*(j3-1)], b3 = coor[2*(j3-1)+1]; + + const double det = a1*(b2-b3) + a2*(b3-b1) + a3*(b1-b2); + if (std::abs(det) < eps * eps) continue; + + const double o1 = (a1*(b2-ym) + a2*(ym-b1) + xm*(b1-b2)) / det; + if (o1 < -eps || o1 > 1.0 + eps) continue; + const double o2 = (a2*(b3-ym) + a3*(ym-b2) + xm*(b2-b3)) / det; + if (o2 < -eps || o2 > 1.0 + eps) continue; + const double o3 = (a3*(b1-ym) + a1*(ym-b3) + xm*(b3-b1)) / det; + if (o3 < -eps || o3 > 1.0 + eps) continue; + + // Barycentre is inside triangle je + iperm = 1; + } + } + + if (iperm == 1) return; + + // --- Node check: no node may lie strictly inside a triangle + for (int i = 0; i < npoint; ++i) + { + const double xm = coor[2 * i]; + const double ym = coor[2 * i + 1]; + + for (int ie = 0; ie < nelem; ++ie) + { + const int i1 = kelem[3 * ie]; + const int i2 = kelem[3 * ie + 1]; + const int i3 = kelem[3 * ie + 2]; + + // Node is a vertex of this element – skip + if (i + 1 == i1 || i + 1 == i2 || i + 1 == i3) continue; + + const double x1 = coor[2*(i1-1)], y1 = coor[2*(i1-1)+1]; + const double x2 = coor[2*(i2-1)], y2 = coor[2*(i2-1)+1]; + const double x3 = coor[2*(i3-1)], y3 = coor[2*(i3-1)+1]; + + // Skip if node is numerically identical to a vertex (Plaxis double pts) + const double d1 = (x1-xm)*(x1-xm)+(y1-ym)*(y1-ym); + if (d1 < eps*(std::abs(x1)+std::abs(xm)+std::abs(y1)+std::abs(ym))) continue; + const double d2 = (x2-xm)*(x2-xm)+(y2-ym)*(y2-ym); + if (d2 < eps*(std::abs(x2)+std::abs(xm)+std::abs(y2)+std::abs(ym))) continue; + const double d3 = (x3-xm)*(x3-xm)+(y3-ym)*(y3-ym); + if (d3 < eps*(std::abs(x3)+std::abs(xm)+std::abs(y3)+std::abs(ym))) continue; + + const double det = x1*(y2-y3) + x2*(y3-y1) + x3*(y1-y2); + if (std::abs(det) < eps * eps) continue; + + const double o1 = (x1*(y2-ym) + x2*(ym-y1) + xm*(y1-y2)) / det; + if (o1 < -eps || o1 > 1.0 + eps) continue; + const double o2 = (x2*(y3-ym) + x3*(ym-y2) + xm*(y2-y3)) / det; + if (o2 < -eps || o2 > 1.0 + eps) continue; + const double o3 = (x3*(y1-ym) + x1*(ym-y3) + xm*(y3-y1)) / det; + if (o3 < -eps || o3 > 1.0 + eps) continue; + + iperm = 1; + } + + if (iperm == 1) return; + } +} + +} // namespace sepran diff --git a/extern/sepran/SepranFront.hpp b/extern/sepran/SepranFront.hpp new file mode 100644 index 000000000..63f863085 --- /dev/null +++ b/extern/sepran/SepranFront.hpp @@ -0,0 +1,386 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of msho01, msho09, msho11-msho14, msho17, msho20-msho21, +// msho24-msho30, msho33-msho35, msho36, msho38-msho42 +// from the SEPRAN library ("Ingenieursbureau SEPRA", Niek Praagman, 1989-2010). + +#pragma once + +#include "SepranContext.hpp" + +#include +#include + +namespace sepran +{ + +// --------------------------------------------------------------------------- +// Array/index conventions (used throughout this module): +// coor – interleaved flat: coor[2*(k-1)] = x, coor[2*(k-1)+1] = y (1-based k) +// kstapl – flat edge pairs: kstapl[2*s]=n1, kstapl[2*s+1]=n2 (0-based s) +// kelem – flat triples: kelem[3*e], [3*e+1], [3*e+2] (0-based e) +// itri – flat: itri[k-1] for 1-based node k +// istart – CSR: istart[i-1] = cumulative neighbour count through node i +// --------------------------------------------------------------------------- + +/// \brief Check boundary elements and fill per-node coarsenesses. +/// +/// Translated from Fortran \c msho01 (SEPRAN, Niek Praagman, 1989-2008). +void msho01(std::span kbound, + int nbound, + std::span istart, + std::span ibuur, + std::span coarse, + std::span coor, + int npoint, + double& coarsemin, + double& coarsemax, + std::span coar, + int ncoar, + SepranContext& ctx); + +/// \brief Compute the unit perpendicular and midpoint of segment i→j. +/// +/// Translated from Fortran \c msho09. +void msho09(std::span coor, + int i, int j, + double& e1, double& e2, + double& xm, double& ym); + +/// \brief Compute the cosine of the angle at vertex i2 between lines i2→i1 and i2→i3. +/// +/// Translated from Fortran \c msho11. +void msho11(int i1, int i2, int i3, + std::span coor, + double& angle, + const SepranContext& ctx); + +/// \brief Find the best adjacent front edges at the endpoints of base edge i1–i2. +/// +/// Translated from Fortran \c msho12. +void msho12(std::span coor, + std::span kstapl, + int kstap, + int i1, int i2, + int& iex1, int& iex2, + double& angle1, double& angle2, + SepranContext& ctx); + +/// \brief Check whether lines from i1 or i2 to new point (xn,yn) cross any front edge. +/// +/// Translated from Fortran \c msho13. +/// kdrie: 0=none, -1=ambiguous, >0 = 1-based index of crossing edge. +void msho13(std::span coor, + int i1, int i2, + int& kdrie, + std::span kstapl, + int kstap, + double xn, double yn, + const SepranContext& ctx); + +/// \brief Find the nearest front node to (xn,yn). +/// +/// Translated from Fortran \c msho14. +void msho14(std::span coor, + int& jpn, + int npoint, + std::span itri, + int i1, int i2, + double xn, double yn, + double& dista); + +/// \brief Commit a new node and triangle, update kstapl and itri. +/// +/// Translated from Fortran \c msho15. +void msho15(std::span coor, + int& npoint, + std::span kelem, + int& nelem, + std::span kstapl, + int& kstap, + std::span itri, + int i1, int i2, + double xnx, double yny); + +/// \brief Build the full CSR neighbour structure for all mesh nodes. +/// +/// Translated from Fortran \c msho16. +void msho16(std::span kelem, + int nelem, int npoint, int nipnt, + std::span iwork, + std::span ibuurp, + int& leng, + SepranContext& ctx); + +/// \brief Insert neighbour ij into the CSR neighbour list for node ih. +/// +/// Translated from Fortran \c msho17. +void msho17(std::span ibuurp, + std::span iwork, + int ih, int ij); + +/// \brief Rotate kstapl left by one edge (first edge moved to end) and update itri. +/// +/// Translated from Fortran \c msho20. +void msho20(std::span kstapl, + int kstap, + std::span itri); + +/// \brief Compute reference triangle-area values for each coarseness-grid cell. +/// +/// Translated from Fortran \c msho21. +void msho21(std::span cube, + int ncube, + std::span refvol); + +/// \brief Check whether segment i1–i2 crosses any front edge. +/// +/// Translated from Fortran \c msho24. +/// icheck: -1 = Plaxis duplicate coincidence; 0 = clear; >0 = crossing edge index. +void msho24(std::span kstapl, + int kstap, + std::span coor, + int i1, int i2, + int& icheck, + const SepranContext& ctx); + +/// \brief Move the shortest front edge to position 0 in kstapl. +/// +/// Translated from Fortran \c msho25. +void msho25(std::span kstapl, + int kstap, + std::span coor, + const SepranContext& ctx); + +/// \brief Find the triangle (other than jelem) sharing edge i2–i3. +/// +/// Translated from Fortran \c msho26. +void msho26(std::span kelem, + int nelem, + int i2, int i3, + int& jelem, + int& i4); + +/// \brief Select the best diagonal in quadrilateral (i1,i2,i3,i4) using Delaunay criterion. +/// +/// Translated from Fortran \c msho27. +void msho27(std::span coor, + int& i1, int& i2, int& i3, int& i4, + const SepranContext& ctx); + +/// \brief Check whether any front node lies strictly inside triangle (i1,i2,i3). +/// +/// Translated from Fortran \c msho28. +void msho28(std::span coor, + int i1, int i2, int i3, + double xn, double yn, + int npoint, + std::span itri, + int& iperm, + const SepranContext& ctx); + +/// \brief Remove over-refined interior nodes with 3 or 4 neighbours. +/// +/// Translated from Fortran \c msho29. +void msho29(std::span kelem, + int& nelem, + int npoint, + std::span iwork, + std::span ibuurp, + int nipnt, + std::span coor, + int& icancel); + +/// \brief Recover from triangulation error: remove ielem and rebuild front. +/// +/// Translated from Fortran \c msho30. +void msho30(std::span kelem, + int& nelem, + int ielem, + std::span kstapl, + int& kstap, + int npoint, + std::span itri, + int nelmfix); + +/// \brief Compute the triangle quality ratio 2·r_in/r_out. +/// +/// Translated from Fortran \c msho33. +void msho33(std::span coor, + double& ratio, + int i1, int i2, int i3); + +/// \brief Locate user-point curve endpoints for a given node. +/// +/// Translated from Fortran \c msho34. +void msho34(int kpoint, + std::span coor, + int ncurvs, + std::span curves, + std::span kbndpt, + int nbndpt, + int numcurvboun, + std::span boundary, + int nbound, + int nholes, + std::span userco, + int nuspnt, + std::span coaval, + int& ius1, + int& ius2); + +/// \brief Check coarseness compatibility and clamp cmax if transition is infeasible. +/// +/// Translated from Fortran \c msho39. +void msho39(double& cmax, + double cmin, + double dist, + double maxratio, + int& iallow); + +/// \brief Compute the maximum allowed coarseness over distance dist from cmin. +/// +/// Translated from Fortran \c msho41. +void msho41(double cmin, double& cmax, double dist, double maxratio); + +/// \brief Check whether edge i–j is an internal boundary segment. +/// +/// Translated from Fortran \c msho42. +void msho42(std::span kbndpt, + int lenbnd, + int i, int j, + int& ja); + +// --------------------------------------------------------------------------- +// Wrappers for msho04, msho05, msho06, msho07, msho08 – larger functions +// defined in SepranFront.cpp +// --------------------------------------------------------------------------- + +/// \brief Compute bounding box of npoint nodes. +/// +/// Translated from Fortran \c msho04. +void msho04(std::span coor, + int npoint, + double& xmin, double& xmax, + double& ymin, double& ymax, + const SepranContext& ctx); + +/// \brief Compute extreme coarsenesses. +/// +/// Translated from Fortran \c msho05. +void msho05(std::span dist, + int npoint, + double& dismin, double& dismax, + const SepranContext& ctx); + +/// \brief Determine per-quad coarsenesses and type flags. +/// +/// Translated from Fortran \c msho06. +void msho06(int npoint, + std::span coor, + double dist, double xstart, double ystart, + int nx, int ny, + std::span icube, + std::span chelp, + std::span cube, + std::span jcube, + std::span kbound, + int nbound, + std::span coar, + int ncoar, + int ncurvs, + std::span curves, + std::span cocurvs, + const SepranContext& ctx); + +/// \brief Point-in-polygon test (ray casting). +/// +/// Translated from Fortran \c msho07. +void msho07(double xcub, double ycub, + double xmini, + std::span coor, + std::span kbound, + int nbound, + int& ja, + const SepranContext& ctx); + +/// \brief Check and fix orientation of all front edges. +/// +/// Translated from Fortran \c msho08. +void msho08(std::span kstapl, + int kstap, + std::span coor, + double xstart, double dismin, + std::span holeinfo, + int nholes, + bool check, + SepranContext& ctx); + +/// \brief Place fixed hexagonal clusters for user coarseness points. +/// +/// Translated from Fortran \c msho35. +void msho35(int npoint, + std::span coor, + double xstart, double ystart, double dismax, + std::span coar, int ncoar, + std::span icube, int nx, + std::span kelem, int& nelem, + std::span kstapl, int& kstap, + std::span itri, + int isurnr, + std::span userpoints, + std::span kbndpt, int& nbndpt, + SepranContext& ctx); + +/// \brief Register internal curve nodes into coor, kstapl, kbndpt. +/// +/// Translated from Fortran \c msho36. +void msho36(std::span coor, + int& npoint, + int istep, int ncurvs, + std::span curves, + std::span cocurvs, + std::span kstapl, int& kstap, + std::span kbndpt, int& nbndpt, + double coarsemin, + std::span extquanodes, + std::span coarse, + SepranContext& ctx); + +/// \brief Check/adjust coarseness smoothness. +/// +/// Translated from Fortran \c msho38. +void msho38(int npoint, + std::span coor, + double dist, double xstart, double ystart, + std::span kbndpt, int nbndpt, + int numcurvboun, + std::span boundary, + int nbound, int nholes, + int nx, int ny, + std::span icube, + std::span coarse, + std::span cube, + std::span jcube, + std::span kstapl, int kstap, + int ncurvs, + std::span curves, + std::span cocurv, + int isurnr, + std::span userco, + int nuspnt, + std::span coaval, + double tran, + const SepranContext& ctx); + +/// \brief Full mesh self-intersection check. +/// +/// Translated from Fortran \c msho40. +/// iperm = 1 if intersections found, 0 if clean. +void msho40(std::span coor, + std::span kelem, + int npoint, int nelem, + int& iperm); + +} // namespace sepran diff --git a/extern/sepran/SepranGeometry.cpp b/extern/sepran/SepranGeometry.cpp new file mode 100644 index 000000000..9c2abd736 --- /dev/null +++ b/extern/sepran/SepranGeometry.cpp @@ -0,0 +1,205 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshcrossline.for, mshcrossline1.for, and msho75.for +// from the SEPRAN library. +// +// Original authors: +// mshcrossline – Guus Segal, 2000-2008 +// mshcrossline1 – Guus Segal, 2003 +// msho75 – Niek Praagman, 1996-2008 + +#include "SepranGeometry.hpp" + +#include +#include + +namespace sepran +{ + +// --------------------------------------------------------------------------- +// crossLine (mshcrossline.for) +// --------------------------------------------------------------------------- + +void crossLine(const std::array& x1, + const std::array& x2, + const std::array& x3, + const std::array& x4, + double& fact1, + double& fact2, + double eps, + const SepranContext& ctx) +{ + const double det = (x2[0] - x1[0]) * (x4[1] - x3[1]) + - (x4[0] - x3[0]) * (x2[1] - x1[1]); + + const double amax = std::max({std::abs(x1[0]), std::abs(x1[1]), + std::abs(x2[0]), std::abs(x2[1]), + std::abs(x3[0]), std::abs(x3[1]), + std::abs(x4[0]), std::abs(x4[1])}); + + if (std::abs(det) <= ctx.epsmac * amax * 100.0) + { + fact1 = -ctx.rinfin; + fact2 = -ctx.rinfin; + } + else + { + fact1 = ((x4[1] - x3[1]) * (x3[0] - x1[0]) + + (x3[0] - x4[0]) * (x3[1] - x1[1])) / det; + + if (fact1 >= -eps && fact1 <= 1.0 + eps) + { + fact2 = -((x1[1] - x2[1]) * (x3[0] - x1[0]) + + (x2[0] - x1[0]) * (x3[1] - x1[1])) / det; + } + else + { + fact2 = -ctx.rinfin; + } + } +} + +// --------------------------------------------------------------------------- +// crossLine1 (mshcrossline1.for) +// --------------------------------------------------------------------------- + +void crossLine1(const std::array& x1, + const std::array& x2, + const std::array& x3, + const std::array& x4, + double& fact1, + double& fact2, + double eps, + const SepranContext& ctx) +{ + fact1 = -ctx.rinfin; + fact2 = -ctx.rinfin; + + const double xmin1 = std::min(x1[0], x2[0]); + const double xmax1 = std::max(x1[0], x2[0]); + const double ymin1 = std::min(x1[1], x2[1]); + const double ymax1 = std::max(x1[1], x2[1]); + + const double xmin2 = std::min(x3[0], x4[0]); + const double xmax2 = std::max(x3[0], x4[0]); + const double ymin2 = std::min(x3[1], x4[1]); + const double ymax2 = std::max(x3[1], x4[1]); + + if (xmax1 < xmin2 - eps || xmin1 > xmax2 + eps || + ymax1 < ymin2 - eps || ymin1 > ymax2 + eps) + { + return; // Bounding boxes don't overlap — no intersection + } + + crossLine(x1, x2, x3, x4, fact1, fact2, eps, ctx); +} + +// --------------------------------------------------------------------------- +// segmentsIntersect (msho75.for) +// --------------------------------------------------------------------------- + +bool segmentsIntersect(double xi, double yi, + double xj, double yj, + double x1, double y1, + double x2, double y2, + const SepranContext& ctx) +{ + const double eps = 10.0 * ctx.epsmac; + + // Check bounding boxes first + const double xmin = std::min(xi, xj); + const double xmax = std::max(xi, xj); + const double ymin = std::min(yi, yj); + const double ymax = std::max(yi, yj); + + const double xmi = std::min(x1, x2); + const double xma = std::max(x1, x2); + const double ymi = std::min(y1, y2); + const double yma = std::max(y1, y2); + + if (xmi > xmax || xma < xmin || ymi > ymax || yma < ymin) + return false; // Boxes disjoint + + if (std::abs(xi - xj) > eps * (std::abs(xi) + std::abs(xj))) + { + // xi != xj + if (std::abs(x1 - x2) > eps * (std::abs(x1) + std::abs(x2))) + { + // xi!=xj, x1!=x2: determine x-coordinate of intersection + const double r1 = (y1 * x2 - y2 * x1) / (x2 - x1); + const double r2 = (yi * xj - yj * xi) / (xj - xi); + const double r3 = (yj - yi) / (xj - xi); + const double r4 = (y2 - y1) / (x2 - x1); + if (std::abs(r3 - r4) > eps) + { + const double xs = (r1 - r2) / (r3 - r4); + const bool onIJ = (xi < xs && xj > xs) || (xj < xs && xi > xs) + || std::abs(xi - xs) < eps || std::abs(xj - xs) < eps; + const bool on12 = (x1 < xs && x2 > xs) || (x2 < xs && x1 > xs) + || std::abs(x1 - xs) < eps || std::abs(x2 - xs) < eps; + if (onIJ && on12) + return true; + } + } + else + { + // x1 == x2: vertical line + if (std::abs(yi - yj) < eps) + { + // yi == yj as well + const double xs = x1; + const double ys = yi; + if (!((xi < xs && xj < xs) || (xi > xs && xj > xs) || + (y1 < ys && y2 < ys) || (y1 > ys && y2 > ys))) + return true; + } + else + { + const double ys = ((yj - yi) * x1 + yi * xj - yj * xi) / (xj - xi); + const bool on12 = (y1 < ys && y2 > ys) || (y2 < ys && y1 > ys) + || std::abs(y1 - ys) < eps || std::abs(y2 - ys) < eps; + const bool onIJ = (yi < ys && yj > ys) || (yj < ys && yi > ys) + || std::abs(yi - ys) < eps || std::abs(yj - ys) < eps; + if (on12 && onIJ) + return true; + } + } + } + else + { + // xi == xj: vertical line + if (std::abs(x1 - x2) > eps * (std::abs(x1) + std::abs(x2))) + { + // xi==xj, x1!=x2 + if (std::abs(y1 - y2) < eps) + { + const double xs = xi; + const double ys = y1; + if (!((yi < ys && yj < ys) || (yi > ys && yj > ys) || + (x1 < xs && x2 < xs) || (x1 > xs && x2 > xs))) + return true; + } + else + { + const double ys = ((y2 - y1) * xi + y1 * x2 - y2 * x1) / (x2 - x1); + const bool onIJ = (yi < ys && yj > ys) || (yi > ys && yj < ys) + || std::abs(yi - ys) < eps || std::abs(yj - ys) < eps; + const bool on12 = (y1 < ys && y2 > ys) || (y2 < ys && y1 > ys) + || std::abs(y1 - ys) < eps || std::abs(y2 - ys) < eps; + if (onIJ && on12) + return true; + } + } + else + { + // Both lines vertical (x1==x2 and xi==xj) + if (std::abs(x1 - xi) < eps * (std::abs(x1) + std::abs(xi))) + return true; + } + } + + return false; +} + +} // namespace sepran diff --git a/extern/sepran/SepranGeometry.hpp b/extern/sepran/SepranGeometry.hpp new file mode 100644 index 000000000..b4a5ef7f6 --- /dev/null +++ b/extern/sepran/SepranGeometry.hpp @@ -0,0 +1,72 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshcrossline.for, mshcrossline1.for, and msho75.for +// from the SEPRAN library. + +#pragma once + +#include "SepranContext.hpp" + +#include + +namespace sepran +{ + +/// \brief Find the parametric intersection of the infinite lines x1–x2 and x3–x4. +/// +/// Translated from Fortran \c mshcrossline (SEPRAN, Guus Segal, 2000-2008). +/// +/// The intersection point on the first line is defined by x1 + fact1*(x2-x1). +/// The intersection point on the second line is defined by x3 + fact2*(x4-x3). +/// If the lines are (nearly) parallel, both facts are set to -ctx.rinfin. +/// +/// \param x1, x2 Endpoints of first line segment (2D coordinates). +/// \param x3, x4 Endpoints of second line segment (2D coordinates). +/// \param fact1 Output: parametric factor for x1–x2. +/// \param fact2 Output: parametric factor for x3–x4. +/// \param eps Local accuracy tolerance. +/// \param ctx SEPRAN context (reads ctx.epsmac, ctx.rinfin). +void crossLine(const std::array& x1, + const std::array& x2, + const std::array& x3, + const std::array& x4, + double& fact1, + double& fact2, + double eps, + const SepranContext& ctx); + +/// \brief Like crossLine, but first tests whether the bounding rectangles overlap. +/// +/// Translated from Fortran \c mshcrossline1 (SEPRAN, Guus Segal, 2003). +/// +/// If the bounding boxes of x1–x2 and x3–x4 do not overlap, both facts are +/// returned as -ctx.rinfin without calling the full intersection computation. +/// +/// \param x1, x2 Endpoints of first line segment. +/// \param x3, x4 Endpoints of second line segment. +/// \param fact1 Output: parametric factor for x1–x2. +/// \param fact2 Output: parametric factor for x3–x4. +/// \param eps Local accuracy tolerance. +/// \param ctx SEPRAN context. +void crossLine1(const std::array& x1, + const std::array& x2, + const std::array& x3, + const std::array& x4, + double& fact1, + double& fact2, + double eps, + const SepranContext& ctx); + +/// \brief Check whether line segment i–j and line segment 1–2 share a common point. +/// +/// Translated from Fortran \c msho75 (SEPRAN, Niek Praagman, 1996-2008). +/// +/// \return true if the two segments intersect (ih==0 in Fortran), false otherwise. +bool segmentsIntersect(double xi, double yi, + double xj, double yj, + double x1, double y1, + double x2, double y2, + const SepranContext& ctx); + +} // namespace sepran diff --git a/extern/sepran/SepranQuadratic.cpp b/extern/sepran/SepranQuadratic.cpp new file mode 100644 index 000000000..2bb08b9b6 --- /dev/null +++ b/extern/sepran/SepranQuadratic.cpp @@ -0,0 +1,445 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of msho31.for, msho32.for, msh401-403/406/416 from SEPRAN. +// +// TRANSLATION CONVENTIONS: +// coor : coor[2*(k-1)] = x, coor[2*(k-1)+1] = y (1-based k) +// kelem : flat, kelem[3*e], [3*e+1], [3*e+2] (0-based e, 1-based nodes) +// kbound : kbound[2*e], kbound[2*e+1] (0-based e, 1-based nodes) + +#include "SepranQuadratic.hpp" +#include "SepranContext.hpp" + +#include +#include +#include +#include +#include + +namespace sepran +{ + +// --------------------------------------------------------------------------- +// Internal helpers (translated from msh402, msh403, msh406, msh416) +// --------------------------------------------------------------------------- + +/// msh416 – Diagonal endpoints of quadrilateral i1-i2-i3-i4. +/// Returns (ie,it) where ie=min, it=max of the chosen diagonal. +static void msh416(int i1, int i2, int i3, int i4, int& ie, int& it) +{ + const int im = std::min({i1, i2, i3, i4}); + if (im == i1 || im == i3) { ie = std::min(i1,i3); it = std::max(i1,i3); } + else { ie = std::min(i2,i4); it = std::max(i2,i4); } +} + +/// msh402 – Store the pair (ilow,ihigh) in the neighbour arrays. +/// +/// istart[ihigh-1] is a count of neighbours stored so far when ja==1 +/// (the "fill" phase); when ja==0 (the "query" phase after compaction), +/// istart holds CSR start addresses. +/// +/// kelemh[0] is the count of overflow entries; overflow pairs are stored +/// from kelemh[2] onward as (ihigh, ilow) pairs. +static void msh402(int npoint, + int ibrp, + std::span ibrpnt, + std::span istart, + int i1, int i2, + std::span kelemh, + SepranContext& ctx) +{ + int ja; + if (i1 < 0) { ja = 0; i1 = -i1; } + else { ja = 1; } + + // Determine low and high node numbers + int ilow, ihigh; + if (i1 > i2) + { + if (i1 > npoint) { ilow = i1; ihigh = i2; } + else { ilow = i2; ihigh = i1; } + } + else + { + if (i2 > npoint) { ilow = i2; ihigh = i1; } + else { ilow = i1; ihigh = i2; } + } + + int jstart, jstend; + if (ja == 1) + { + jstart = ibrp * (ihigh - 1); // 0-based index + jstend = jstart + ibrp - 1; + } + else + { + jstart = istart[ihigh - 1] - 1; // 0-based + jstend = istart[ihigh] - 2; // 0-based + } + + for (;;) + { + const int ih = ibrpnt[jstart]; + + if (ih == 0) + { + // empty slot – store here + ibrpnt[jstart] = ilow; + if (ja == 1) istart[ihigh - 1]++; + return; + } + + if (ih == ilow) return; // already stored + + ++jstart; + + if (jstart > jstend) + { + if (ja == 0) + { + ctx.ierror = 1; + throw std::runtime_error("msh402: no place left for neighbour (error 1274)"); + } + + // Overflow: use kelemh + int j = kelemh[0]; + // Check if already in kelemh + for (int il = 0; il < j; ++il) + { + if (std::abs(kelemh[2*(il+1)] - ihigh) == 0 && + std::abs(kelemh[2*(il+1)+1] - ilow ) == 0) + return; + } + kelemh[2 * (j + 1)] = ihigh; + kelemh[2 * (j + 1) + 1] = ilow; + kelemh[0] = j + 1; + istart[ihigh - 1]++; + return; + } + } +} + +/// msh403 – Find the mid-side node between i1 and i3 in ibrpnt. +static void msh403(int npoint, int i1, int i3, + std::span ibrpnt, + std::span istart, + int& i2, + SepranContext& ctx) +{ + i2 = 0; + + int ilow, ihigh; + if (i1 > i3) + { + if (i1 > npoint) { ilow = i1; ihigh = i3; } + else { ilow = i3; ihigh = i1; } + } + else + { + if (i3 > npoint) { ilow = i3; ihigh = i1; } + else { ilow = i1; ihigh = i3; } + } + + int jstart = istart[ihigh - 1] - 1; // 0-based + const int jstend = istart[ihigh] - 2; // 0-based + + while (jstart <= jstend) + { + if (ibrpnt[jstart] == ilow) + { + i2 = ibrpnt[jstart + 1]; + return; + } + jstart += 2; + } + + // Not found + ctx.ierror = 1; + throw std::runtime_error("msh403: intermediate neighbour not found (error 949)"); +} + +/// msh406 – Write 6 node numbers into a quadratic-triangle element. +/// kelem layout: flat, 6 entries per element (0-based element j). +static void msh406(std::span kelem, int j, + int i1, int i2, int i3, int i4, int i5, int i6) +{ + const int base = 6 * j; + kelem[base + 0] = i1; + kelem[base + 1] = i2; + kelem[base + 2] = i3; + kelem[base + 3] = i4; + kelem[base + 4] = i5; + kelem[base + 5] = i6; +} + +/// msh401 – Fill neighbour arrays for all linear triangles (ishape=3). +static void msh401(int npoint, + std::span kmeshc, + int nelem, + std::span istart, + int ibrp, + std::span ibrpnt, + std::span kelemh, + SepranContext& ctx) +{ + for (int ielem = 0; ielem < nelem; ++ielem) + { + const int base = 3 * ielem; + const int n1 = kmeshc[base]; + const int n2 = kmeshc[base + 1]; + const int n3 = kmeshc[base + 2]; + + msh402(npoint, ibrp, ibrpnt, istart, n1, n2, kelemh, ctx); + msh402(npoint, ibrp, ibrpnt, istart, n2, n3, kelemh, ctx); + msh402(npoint, ibrp, ibrpnt, istart, n3, n1, kelemh, ctx); + if (ctx.ierror != 0) return; + } +} + +// --------------------------------------------------------------------------- +// msho31 – Linear to quadratic triangles +// --------------------------------------------------------------------------- +void msho31(std::span coor, + int& npoint, + std::span kelem, + int nelem, + std::span kbound, + int nbn, + std::span extquanodes, + SepranContext& ctx) +{ + const int ibrp = 10; + const int ibrlen = ibrp * (npoint + 1); + + std::vector istart (npoint + 2, 0); + std::vector ibrpnt (ibrlen, 0); + std::vector kelemh (npoint + 2, 0); + + // --- Fill neighbour graph + msh401(npoint, kelem, nelem, istart, ibrp, ibrpnt, kelemh, ctx); + if (ctx.ierror != 0) return; + + // --- Compact: collect all non-zero neighbours into a contiguous prefix + int nummer = 0; + for (int i = 0; i < npoint; ++i) + { + const int jstart = ibrp * i; + const int jstend = jstart + ibrp; + for (int ii = jstart; ii < jstend; ++ii) + { + if (ibrpnt[ii] != 0) + { + ibrpnt[nummer] = ibrpnt[ii]; + ++nummer; + } + } + } + const int itotalCompact = nummer; + + if (ibrlen < 2 * itotalCompact) + { + ctx.ierror = 1; + throw std::runtime_error( + "msho31: not enough space for neighbours (error 1275). Need " + + std::to_string(2 * itotalCompact) + ", have " + std::to_string(ibrlen)); + } + + // --- Shift to upper half of ibrpnt and rebuild istart as CSR pointers + int npt = ibrlen - 1; // 0-based end + nummer = itotalCompact - 1; + int iextra = 0; + + for (int i = npoint - 1; i >= 0; --i) + { + int nbr = istart[i]; + + if (nbr > ibrp) + { + iextra = 1; + for (int ib = 0; ib < nbr - ibrp; ++ib) + { + ibrpnt[npt] = 0; + --npt; + } + nbr = ibrp; + } + + for (int ib = 0; ib < nbr; ++ib) + { + ibrpnt[npt] = ibrpnt[nummer]; + --npt; + --nummer; + } + + if (npt < nummer) + { + ctx.ierror = 1; + throw std::runtime_error("msho31: too few positions in ibrpnt (error 1274)"); + } + } + + // Account for extra neighbours in kelemh + int itotal = itotalCompact; + if (kelemh[0] != 0) + { + if (iextra == 0) + { + ctx.ierror = 1; + throw std::runtime_error("msho31: extra points not recognised (error 1274)"); + } + itotal = kelemh[0] + itotalCompact; + for (int i = 0; i < kelemh[0]; ++i) + { + const int ia = -kelemh[2*(i+1)]; // negative flag for msh402 + const int ib = kelemh[2*(i+1) + 1]; + msh402(npoint, ibrp, ibrpnt, istart, ia, ib, kelemh, ctx); + if (ctx.ierror != 0) return; + } + } + + if (ibrlen < 2 * itotal) + { + ctx.ierror = 1; + throw std::runtime_error("msho31: not enough space for neighbours (error 1275)"); + } + + // --- Convert istart to proper CSR pointers + itotal = istart[npoint] - 1; // total edges + int jstend = 0; + for (int i = 0; i < npoint; ++i) + { + const int jstart = jstend + 1; + jstend += istart[i]; + istart[i] = jstart; + } + istart[npoint] = jstend + 1; + + // --- Expand: shift pairs to make room for new-node slot + // ibrpnt[2*k-2] = neighbour, ibrpnt[2*k-1] = midnode (initially 0) + for (int i = itotal; i >= 1; --i) + { + ibrpnt[2 * i - 1] = 0; + ibrpnt[2 * i - 2] = ibrpnt[i - 1 + npt + 1]; // reindex from compacted region + } + + // Adjust istart to 2-based offsets + for (int i = 1; i <= npoint; ++i) + istart[i] = 2 * istart[i] - 1; // 1-based Fortran style; adjust for 0-based below + + // Actually, let's do this cleanly: offset all istart so [i-1] points correctly + // istart is still 1-based internally; convert to 0-based access: + // We'll use a lambda to abstract the conversion. + + // --- Reuse existing mid-side nodes on boundary + for (int i = 0; i < nbn; ++i) + { + int ip1 = kbound[2 * i]; + int ip2 = kbound[2 * i + 1]; + int ip3 = ip1 + 1; // pre-existing midpoint assumed to be ip1+1 + + // larger node is "ihigh" + if (ip1 < ip2) { std::swap(ip1, ip2); } + + const int js = istart[ip1 - 1] - 1; // 0-based + const int jse = istart[ip1] - 2; // 0-based + for (int ii = js; ii <= jse; ii += 2) + { + if (ibrpnt[ii] == ip2) + { + ibrpnt[ii + 1] = ip3; + break; + } + } + } + + // --- Reuse existing mid-side nodes on internal quadratic lines + if (!extquanodes.empty() && extquanodes[0] > 1) + { + const int ileng = (extquanodes[0] - 1) / 3; + for (int i = 0; i < ileng; ++i) + { + int ip1 = extquanodes[3 * i + 1]; // start node + int ip2 = extquanodes[3 * i + 3]; // end node + int ip3 = extquanodes[3 * i + 2]; // mid node + + if (ip1 < ip2) { std::swap(ip1, ip2); } + + const int js = istart[ip1 - 1] - 1; + const int jse = istart[ip1] - 2; + for (int ii = js; ii <= jse; ii += 2) + { + if (ibrpnt[ii] == ip2) + { + ibrpnt[ii + 1] = ip3; + break; + } + } + } + } + + // --- Create new mid-side nodes for all internal edges + const int npnold = npoint; + for (int i = 0; i < npnold; ++i) + { + const int jstart_i = istart[i] - 1; // 0-based + const int jstend_i = istart[i + 1] - 2; + for (int ii = jstart_i; ii <= jstend_i; ii += 2) + { + const int ip2 = ibrpnt[ii]; + const int ip3 = ibrpnt[ii + 1]; + + if (ip2 > 0 && ip3 == 0) + { + ++npoint; + ibrpnt[ii + 1] = npoint; + + // Midpoint coordinates (1-based node indices) + coor[2 * (npoint - 1)] = (coor[2 * i] + coor[2 * (ip2 - 1)]) / 2.0; + coor[2 * (npoint - 1) + 1] = (coor[2 * i + 1] + coor[2 * (ip2 - 1) + 1]) / 2.0; + } + } + } + + // --- Build quadratic elements (backward so we don't clobber linear data) + // The input kelem has 3 entries per element; we need 6. + // Process backward: fill kelem[6*(i-1)..6*i-1] from kelem[3*(i-1)..3*i-1] + for (int i = nelem - 1; i >= 0; --i) + { + int ip[7] = {}; + ip[1] = kelem[3 * i]; + ip[3] = kelem[3 * i + 1]; + ip[5] = kelem[3 * i + 2]; + + msh403(npnold, ip[1], ip[3], ibrpnt, istart, ip[2], ctx); + msh403(npnold, ip[3], ip[5], ibrpnt, istart, ip[4], ctx); + msh403(npnold, ip[5], ip[1], ibrpnt, istart, ip[6], ctx); + if (ctx.ierror != 0) return; + + msh406(kelem, i, ip[1], ip[2], ip[3], ip[4], ip[5], ip[6]); + } +} + +// --------------------------------------------------------------------------- +// msho32 – Recover linear triangles from quadratic element array +// --------------------------------------------------------------------------- +void msho32(std::span kelem, + int nelem, + int inpelm, + int& npunt) +{ + for (int i = 0; i < nelem; ++i) + { + const int lin = 3 * i; + const int qua = inpelm * i; + kelem[lin] = kelem[qua]; + kelem[lin + 1] = kelem[qua + 2]; + kelem[lin + 2] = kelem[qua + 4]; + } + + npunt = 0; + for (int i = 0; i < 3 * nelem; ++i) + if (kelem[i] > npunt) npunt = kelem[i]; +} + +} // namespace sepran diff --git a/extern/sepran/SepranQuadratic.hpp b/extern/sepran/SepranQuadratic.hpp new file mode 100644 index 000000000..363a2654a --- /dev/null +++ b/extern/sepran/SepranQuadratic.hpp @@ -0,0 +1,62 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of msho31.for, msho32.for, msh401.for, msh402.for, +// msh403.for, msh406.for, msh416.for from the SEPRAN library. + +#pragma once + +#include "SepranContext.hpp" + +#include + +namespace sepran +{ + +/// \brief Convert linear triangle mesh to quadratic (6-node) triangles. +/// +/// Translated from Fortran \c msho31 (SEPRAN, Niek Praagman, 1990-2010). +/// +/// New mid-side nodes are added to \p coor; \p kelem is expanded from +/// 3 to 6 nodes per element. Already-existing mid-side nodes on the +/// boundary (given in \p kbound) and on internal quadratic lines +/// (\p extquanodes) are reused. +/// +/// On entry \p kelem holds 3 node-indices per element (flat, 0-based element, +/// 1-based node values). On exit it holds 6 node-indices per element +/// (must be pre-allocated to at least 6*nelem entries). +/// +/// \param coor i/o Interleaved coords (extended in place). +/// \param npoint i/o Node count (extended). +/// \param kelem i/o Element connectivity array. +/// \param nelem i Number of linear triangles. +/// \param kbound i Flat boundary-edge pairs (1-based), length 2*nbn. +/// \param nbn i Number of boundary edges. +/// \param extquanodes i Quadratic-internal-line data (from msho36). +/// \param ctx i/o SEPRAN context. +void msho31(std::span coor, + int& npoint, + std::span kelem, + int nelem, + std::span kbound, + int nbn, + std::span extquanodes, + SepranContext& ctx); + +/// \brief Recover linear triangles from a quadratic element array. +/// +/// Translated from Fortran \c msho32 (SEPRAN, Niek Praagman, 1991-2005). +/// +/// Squashes \p kelem from \p inpelm nodes per element to 3, retaining only +/// vertices 1, 3, 5 (0-based positions 0, 2, 4) per element. +/// +/// \param kelem i/o Element array (inpelm*nelem entries; overwritten with 3*nelem). +/// \param nelem i Number of elements. +/// \param inpelm i Nodes per quadratic element (typically 6). +/// \param npunt o Highest node number in the resulting linear mesh. +void msho32(std::span kelem, + int nelem, + int inpelm, + int& npunt); + +} // namespace sepran diff --git a/extern/sepran/SepranSort.cpp b/extern/sepran/SepranSort.cpp new file mode 100644 index 000000000..831987054 --- /dev/null +++ b/extern/sepran/SepranSort.cpp @@ -0,0 +1,84 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of chsort.for from the SEPRAN library. +// +// Original Fortran: chsort (programmer Jos van Kan / Onno Hoitinga, 1987-1998) +// Numerical-Recipes heap sort algorithm (Cambridge University Press, 1989). + +#include "SepranSort.hpp" + +#include +#include +#include + +namespace sepran +{ + +void heapSort(std::span keysrt, std::span kgrad) +{ + const int n = static_cast(keysrt.size()); + assert(kgrad.size() == keysrt.size()); + + // Initialise permutation to identity (Fortran: do j=1,npoint kgrad(j)=j) + std::iota(kgrad.begin(), kgrad.end(), 0); + + if (n <= 1) + return; + + // Heap sort — direct translation of the Fortran, converted to 0-based indices. + // The Fortran algorithm works on a 1-based kgrad array; here every index is + // decremented by 1. + int l = n / 2; // Fortran: l = npoint/2+1, then l=l-1 on first entry → same + int ir = n - 1; // Fortran: ir = npoint (0-based: n-1) + + while (true) + { + int kgradt; + int q; + + if (l > 0) + { + --l; + kgradt = kgrad[l]; + q = keysrt[kgradt]; + } + else + { + kgradt = kgrad[ir]; + q = keysrt[kgradt]; + kgrad[ir] = kgrad[0]; + --ir; + if (ir == 0) + { + kgrad[0] = kgradt; + return; + } + } + + int i = l; + int j = l + l + 1; // Fortran j = l+l, but kgrad is 0-based → j = 2*l+1 + + while (j <= ir) + { + if (j < ir) + { + if (keysrt[kgrad[j]] < keysrt[kgrad[j + 1]]) + ++j; + } + if (q < keysrt[kgrad[j]]) + { + kgrad[i] = kgrad[j]; + i = j; + j = j + j + 1; + } + else + { + break; + } + } + kgrad[i] = kgradt; + } +} + +} // namespace sepran diff --git a/extern/sepran/SepranSort.hpp b/extern/sepran/SepranSort.hpp new file mode 100644 index 000000000..0bde9b52d --- /dev/null +++ b/extern/sepran/SepranSort.hpp @@ -0,0 +1,22 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of chsort.for from the SEPRAN library. + +#pragma once + +#include + +namespace sepran +{ + +/// \brief Compute a permutation index that sorts keysrt in ascending order. +/// +/// Translated from Fortran \c chsort (SEPRAN library, Numerical-Recipes heap sort). +/// +/// \param keysrt Integer sort keys (0-based, length n). +/// \param kgrad Output permutation: kgrad[i] is the 0-based index of the +/// i-th element in sorted order. Must be the same size as keysrt. +void heapSort(std::span keysrt, std::span kgrad); + +} // namespace sepran diff --git a/extern/sepran/SepranTopology.cpp b/extern/sepran/SepranTopology.cpp new file mode 100644 index 000000000..5d8dd9f2d --- /dev/null +++ b/extern/sepran/SepranTopology.cpp @@ -0,0 +1,301 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of msho02, msho03, msho10, msho18, msho19, msho22 +// from the SEPRAN library. +// +// Original author: Niek Praagman, 1989-2010. + +#include "SepranTopology.hpp" + +#include +#include + +namespace sepran +{ + +// --------------------------------------------------------------------------- +// insertNeighbour (msho02.for) +// --------------------------------------------------------------------------- + +void insertNeighbour(std::span istart, + std::span ibuur, + int i, + int j) +{ + // Range of neighbour slots for node i (1-based i) + const int ist = (i == 1) ? 0 : istart[i - 2]; // 0-based start + const int ien = istart[i - 1]; // exclusive end + + for (int kn = ist; kn < ien; ++kn) + { + const int ib = ibuur[kn]; + if (ib == 0) + { + ibuur[kn] = j; + return; + } + if (ib == j) + return; // Already present — double line, do nothing + } +} + +// --------------------------------------------------------------------------- +// nodeDistance (msho03.for) +// --------------------------------------------------------------------------- + +double nodeDistance(int i, int j, std::span coor) +{ + const double dx = coor[2 * (i - 1)] - coor[2 * (j - 1)]; + const double dy = coor[2 * (i - 1) + 1] - coor[2 * (j - 1) + 1]; + return std::sqrt(dx * dx + dy * dy); +} + +// --------------------------------------------------------------------------- +// addElement (msho10.for) +// --------------------------------------------------------------------------- + +void addElement(std::span kelem, int& nelem, + int i1, int i2, int jpn, + std::span kstapl, int& kstap, + std::span itri) +{ + // Append the new element + kelem[3 * nelem] = i1; + kelem[3 * nelem + 1] = i2; + kelem[3 * nelem + 2] = jpn; + ++nelem; + + // Walk through kstapl (skip slot 0 — Fortran starts at index 2) + // Remove edges i2-jpn and jpn-i1 if present; otherwise they are new. + int idrie = 0; // Number of surviving edges + int ieen = 1; // 1 = edge jpn-i2 is new (needs adding) + int itwe = 1; // 1 = edge i1-jpn is new (needs adding) + + for (int ks = 1; ks < kstap; ++ks) // Fortran: do ks = 2, kstap + { + const int ia = kstapl[2 * ks]; + const int ib = kstapl[2 * ks + 1]; + if (ia == i2 && ib == jpn) + { + ieen = 0; + } + else if (ia == jpn && ib == i1) + { + itwe = 0; + } + else + { + kstapl[2 * idrie] = ia; + kstapl[2 * idrie + 1] = ib; + ++idrie; + } + } + + if (ieen == 1) + { + kstapl[2 * idrie] = jpn; + kstapl[2 * idrie + 1] = i2; + ++idrie; + ++itri[i2 - 1]; + ++itri[jpn - 1]; + } + else + { + --itri[i2 - 1]; + --itri[jpn - 1]; + } + + if (itwe == 1) + { + kstapl[2 * idrie] = i1; + kstapl[2 * idrie + 1] = jpn; + ++idrie; + ++itri[jpn - 1]; + ++itri[i1 - 1]; + } + else + { + --itri[jpn - 1]; + --itri[i1 - 1]; + } + + kstap = idrie; +} + +// --------------------------------------------------------------------------- +// triangleArea (msho19.for) +// --------------------------------------------------------------------------- + +double triangleArea(std::span coor, int i1, int i2, int i3) +{ + const double x1 = coor[2 * (i1 - 1)]; + const double y1 = coor[2 * (i1 - 1) + 1]; + const double x2 = coor[2 * (i2 - 1)]; + const double y2 = coor[2 * (i2 - 1) + 1]; + const double x3 = coor[2 * (i3 - 1)]; + const double y3 = coor[2 * (i3 - 1) + 1]; + return (x1 * (y2 - y3) + x2 * (y3 - y1) + x3 * (y1 - y2)) / 2.0; +} + +// --------------------------------------------------------------------------- +// checkTriangleAngles (msho22.for) +// --------------------------------------------------------------------------- + +int checkTriangleAngles(double a, double b, double c) +{ + const double aa = a * a; + const double bb = b * b; + const double cc = c * c; + + constexpr double q = -0.01; + + const double angle1 = (cc + aa - bb) / (2.0 * c * a); + const double angle2 = (aa + bb - cc) / (2.0 * a * b); + const double angle3 = (bb + cc - aa) / (2.0 * b * c); + + if (angle1 < q) return 1; + else if (angle2 < q) return 2; + else if (angle3 < q) return 3; + return 0; +} + +// --------------------------------------------------------------------------- +// laplacianSmoothing (msho18.for) +// --------------------------------------------------------------------------- + +void laplacianSmoothing(std::span kelem, int nelem, + std::span coor, int npoint, int nipnt, + std::span iwork, + std::span ibuurp, + double& coars, + SepranContext& ctx) +{ + coars = 0.02 * coars; + + int jr = 1; + bool finished = false; + + while (!finished) + { + ++jr; + double afstnd = 0.0; + + for (int ikn = nipnt + 1; ikn <= npoint; ++ikn) // 1-based node index + { + // Compute total surface of all elements containing ikn + double surf = 0.0; + double surf1 = 0.0; + + const double xh = coor[2 * (ikn - 1)]; + const double yh = coor[2 * (ikn - 1) + 1]; + + for (int i = 0; i < nelem; ++i) + { + const int ia = kelem[3 * i]; + const int ib = kelem[3 * i + 1]; + const int ic = kelem[3 * i + 2]; + if (ia == ikn || ib == ikn || ic == ikn) + { + surf1 = triangleArea(coor, ia, ib, ic); + surf += surf1; + } + } + + const double surfre = surf; + + // CSR start/end for node ikn + const int jstart = (ikn == 1) ? 0 : iwork[ikn - 2]; + const int jeind = iwork[ikn - 1]; + + if (jstart >= jeind) + continue; + + // Compute barycentre of neighbours + double xz = 0.0; + double yz = 0.0; + int nbuur = jeind - jstart; + + for (int i = jstart; i < jeind; ++i) + { + const int jkn = ibuurp[i]; + if (jkn > 0) + { + xz += coor[2 * (jkn - 1)]; + yz += coor[2 * (jkn - 1) + 1]; + } + else + { + --nbuur; + } + } + xz /= nbuur; + yz /= nbuur; + + // Try over-relaxed move + const double xn = xh + 1.62 * (xz - xh); + const double yn = yh + 1.62 * (yz - yh); + + coor[2 * (ikn - 1)] = xn; + coor[2 * (ikn - 1) + 1] = yn; + + // Recompute surface and check validity + surf = 0.0; + for (int i = 0; i < nelem; ++i) + { + const int ia = kelem[3 * i]; + const int ib = kelem[3 * i + 1]; + const int ic = kelem[3 * i + 2]; + if (ia == ikn || ib == ikn || ic == ikn) + { + surf1 = triangleArea(coor, ia, ib, ic); + surf += std::abs(surf1); + } + } + + int iallow = 0; + if (std::abs(surf - surfre) < 100.0 * ctx.epsmac) + iallow = 2; + + if (iallow != 2) + { + // Over-relaxation not accepted — try barycentre + coor[2 * (ikn - 1)] = xz; + coor[2 * (ikn - 1) + 1] = yz; + + surf = 0.0; + for (int i = 0; i < nelem; ++i) + { + const int ia = kelem[3 * i]; + const int ib = kelem[3 * i + 1]; + const int ic = kelem[3 * i + 2]; + if (ia == ikn || ib == ikn || ic == ikn) + { + surf1 = triangleArea(coor, ia, ib, ic); + surf += surf1; + } + } + if (std::abs(surf - surfre) < 100.0 * ctx.epsmac) + iallow = 1; + + if (iallow == 0) + { + // Neither move is valid — restore old position + coor[2 * (ikn - 1)] = xh; + coor[2 * (ikn - 1) + 1] = yh; + } + } + + // Track maximum displacement + const double cx = coor[2 * (ikn - 1)]; + const double cy = coor[2 * (ikn - 1) + 1]; + const double af = (xh - cx) * (xh - cx) + (yh - cy) * (yh - cy); + if (af > afstnd) afstnd = af; + } + + if (jr > 2 && std::sqrt(afstnd) < coars) finished = true; + if (jr == 20) finished = true; + } +} + +} // namespace sepran diff --git a/extern/sepran/SepranTopology.hpp b/extern/sepran/SepranTopology.hpp new file mode 100644 index 000000000..bb2d3eceb --- /dev/null +++ b/extern/sepran/SepranTopology.hpp @@ -0,0 +1,130 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of msho02, msho03, msho10, msho18, msho19, msho22 +// from the SEPRAN library. + +#pragma once + +#include "SepranContext.hpp" + +#include + +namespace sepran +{ + +// --------------------------------------------------------------------------- +// Array conventions used throughout sepran topology: +// +// coor – interleaved flat: coor[2*(k-1)] = x, coor[2*(k-1)+1] = y +// k is a 1-based node index. +// +// istart – CSR row-pointer array of length npoint. +// istart[i-1] (1-based i) = total number of neighbours for nodes 1..i. +// Neighbours of node i are at ibuur[istart[i-2] .. istart[i-1]-1] +// (with istart[-1] := 0). +// +// ibuur – CSR adjacency list; ibuur[j] is the 1-based node index of a +// neighbour. +// +// kelem – element (triangle) array, flat: kelem[3*e], kelem[3*e+1], +// kelem[3*e+2] are the 1-based node indices of element e (0-based e). +// +// kstapl – advancing-front edge list, flat pairs: kstapl[2*k]=n1, +// kstapl[2*k+1]=n2 (1-based node indices), k is 0-based. +// +// itri – per-node front-membership counter; itri[k-1] for 1-based node k. +// --------------------------------------------------------------------------- + +/// \brief Insert neighbour j into the CSR adjacency list of node i. +/// +/// Translated from Fortran \c msho02 (SEPRAN, Niek Praagman, 1989-1997). +/// +/// \param istart CSR row-pointer array (length npoint, 1-based nodes). +/// \param ibuur CSR adjacency list (pre-allocated). +/// \param i Source node (1-based). +/// \param j Neighbour node to insert (1-based). +void insertNeighbour(std::span istart, + std::span ibuur, + int i, + int j); + +/// \brief Compute the Euclidean distance between two nodes. +/// +/// Translated from Fortran \c msho03 (SEPRAN, Niek Praagman, 1989-1994). +/// +/// \param i First node (1-based). +/// \param j Second node (1-based). +/// \param coor Node coordinate array. +/// \return Euclidean distance ||node_i - node_j||. +double nodeDistance(int i, int j, std::span coor); + +/// \brief Add a new triangle element and update the advancing-front arrays. +/// +/// Translated from Fortran \c msho10 (SEPRAN, Niek Praagman, 1989-2003). +/// +/// Appends element (i1, i2, jpn) to \p kelem, removes edges i2-jpn and +/// jpn-i1 from \p kstapl if they were already on the front, or adds them if +/// not, and updates \p itri accordingly. +/// +/// \param kelem Element array (flat, 3 entries per element). Must be +/// pre-allocated to maximum capacity. +/// \param nelem Current element count (in-out). +/// \param i1 First node of new triangle (1-based). +/// \param i2 Second node of new triangle (1-based). +/// \param jpn Third node of new triangle (1-based). +/// \param kstapl Advancing-front edge list (flat pairs, 1-based nodes). +/// \param kstap Current length of kstapl (number of edges) (in-out). +/// \param itri Per-node front-membership counter (1-based index − 1). +void addElement(std::span kelem, int& nelem, + int i1, int i2, int jpn, + std::span kstapl, int& kstap, + std::span itri); + +/// \brief Compute the signed area of triangle (i1, i2, i3). +/// +/// Translated from Fortran \c msho19 (SEPRAN, Niek Praagman, 1989-2005). +/// +/// Returns a positive value for counter-clockwise orientation. +/// +/// \param coor Node coordinate array. +/// \param i1, i2, i3 Node indices (1-based). +/// \return Signed area = ((x1*(y2-y3)+x2*(y3-y1)+x3*(y1-y2)) / 2). +double triangleArea(std::span coor, int i1, int i2, int i3); + +/// \brief Check triangle angles; return which angle (if any) exceeds 90°. +/// +/// Translated from Fortran \c msho22 (SEPRAN, Niek Praagman, 1989-2010). +/// +/// \param a Length of side a. +/// \param b Length of side b. +/// \param c Length of side c. +/// \return 0 if all angles ≤ 90°; 1/2/3 indicating which vertex has the +/// obtuse angle. +int checkTriangleAngles(double a, double b, double c); + +/// \brief Laplacian smoothing of interior nodes. +/// +/// Translated from Fortran \c msho18 (SEPRAN, Niek Praagman, 1989-2010). +/// +/// Iteratively moves interior nodes (indices nipnt+1 .. npoint, 1-based) +/// toward the barycentre of their neighbours, accepting moves that preserve +/// positive triangle areas. +/// +/// \param kelem Element array (flat, 3 entries per element). +/// \param nelem Number of elements. +/// \param coor Node coordinate array (in-out). +/// \param npoint Total node count. +/// \param nipnt Number of boundary (fixed) nodes (1-based indices 1..nipnt). +/// \param iwork CSR row-pointer array for ibuurp (length npoint). +/// \param ibuurp CSR adjacency list of all nodes (length iwork[npoint-1]). +/// \param coars Reference coarseness / stopping distance (in-out; halved inside). +/// \param ctx SEPRAN context. +void laplacianSmoothing(std::span kelem, int nelem, + std::span coor, int npoint, int nipnt, + std::span iwork, + std::span ibuurp, + double& coars, + SepranContext& ctx); + +} // namespace sepran diff --git a/extern/sepran/SepranTransform.cpp b/extern/sepran/SepranTransform.cpp new file mode 100644 index 000000000..227446e21 --- /dev/null +++ b/extern/sepran/SepranTransform.cpp @@ -0,0 +1,100 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshtrans2dsur.for from the SEPRAN library. +// +// Original author: Guus Segal, 2009. + +#include "SepranTransform.hpp" + +#include +#include + +namespace sepran +{ + +TransformParams transform2DSurface(std::span coor, + int npoint, + std::span coar, + int ncoar, + std::span curves, + int ncurvs, + std::span cocurvs, + std::span userco, + int nuspnt, + SepranContext& ctx) +{ + if (ctx.ierror != 0) + return {}; + + // --- Find bounding box of all boundary nodes --- + double xmint = ctx.rinfin; + double xmax = -ctx.rinfin; + double ymint = ctx.rinfin; + double ymax = -ctx.rinfin; + + for (int i = 0; i < npoint; ++i) + { + xmint = std::min(xmint, coor[2 * i]); + xmax = std::max(xmax, coor[2 * i]); + ymint = std::min(ymint, coor[2 * i + 1]); + ymax = std::max(ymax, coor[2 * i + 1]); + } + + // --- Choose uniform scale factor --- + const double tran = (xmax - xmint > ymax - ymint) ? (xmax - xmint) : (ymax - ymint); + + // --- Scale boundary node coordinates --- + for (int i = 0; i < npoint; ++i) + { + coor[2 * i] = 1.0 + (coor[2 * i] - xmint) / tran; + coor[2 * i + 1] = 1.0 + (coor[2 * i + 1] - ymint) / tran; + } + + // --- Scale user points --- + for (int i = 0; i < nuspnt; ++i) + { + userco[2 * i] = 1.0 + (userco[2 * i] - xmint) / tran; + userco[2 * i + 1] = 1.0 + (userco[2 * i + 1] - ymint) / tran; + } + + // --- Scale internal coarseness points --- + // coar layout: [x0,y0,c0, x1,y1,c1, ...] (0-based) + for (int i = 0; i < ncoar; ++i) + { + coar[3 * i] = 1.0 + (coar[3 * i] - xmint) / tran; + coar[3 * i + 1] = 1.0 + (coar[3 * i + 1] - ymint) / tran; + coar[3 * i + 2] /= tran; // scale the coarseness value itself + } + + // --- Scale internal curve nodes --- + // curves[i] = node count of curve i (0-based). + // cocurvs stores all curve nodes concatenated, interleaved x,y. + if (ncurvs > 0) + { + int offset = 0; + for (int i = 0; i < ncurvs; ++i) + { + const int nnodes = curves[i]; + for (int k = 0; k < nnodes; ++k) + { + cocurvs[2 * (offset + k)] = 1.0 + (cocurvs[2 * (offset + k)] - xmint) / tran; + cocurvs[2 * (offset + k) + 1] = 1.0 + (cocurvs[2 * (offset + k) + 1] - ymint) / tran; + } + offset += nnodes; + } + } + + return {xmint, ymint, tran}; +} + +void reverseTransform2DSurface(std::span coor, int npoint, const TransformParams& tp) +{ + for (int i = 0; i < npoint; ++i) + { + coor[2 * i] = tp.xmint + (coor[2 * i] - 1.0) * tp.tran; + coor[2 * i + 1] = tp.ymint + (coor[2 * i + 1] - 1.0) * tp.tran; + } +} + +} // namespace sepran diff --git a/extern/sepran/SepranTransform.hpp b/extern/sepran/SepranTransform.hpp new file mode 100644 index 000000000..46977f52e --- /dev/null +++ b/extern/sepran/SepranTransform.hpp @@ -0,0 +1,71 @@ +// SPDX-License-Identifier: GPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Stichting Deltares +// +// C++20 translation of mshtrans2dsur.for from the SEPRAN library. + +#pragma once + +#include "SepranContext.hpp" + +#include + +namespace sepran +{ + +/// \brief Parameters computed by the 2D coordinate normalisation step. +struct TransformParams +{ + double xmint; ///< X translation (minimum x before scaling). + double ymint; ///< Y translation (minimum y before scaling). + double tran; ///< Scale factor (maximum extent in either dimension). +}; + +/// \brief Normalise coordinates so the domain fits in the first quadrant with +/// unit extent. +/// +/// Translated from Fortran \c mshtrans2dsur (SEPRAN, Guus Segal, 2009). +/// +/// All coordinate arrays are modified in-place. After the call, every +/// coordinate c becomes 1 + (c - cmin) / tran. +/// +/// Array conventions (shared with the rest of sepran): +/// - \p coor: interleaved flat [x0,y0, x1,y1, ...], 0-based, length 2*npoint. +/// - \p coar: flat [x0,y0,coarseness0, x1,y1,coarseness1, ...], length 3*ncoar. +/// - \p cocurvs: interleaved flat, length 2 * total_curve_nodes. +/// - \p userco: interleaved flat, length 2*nuspnt. +/// - \p curves: node counts per internal curve, length ncurvs. +/// +/// \param coor Node coordinates to normalise (in-out). +/// \param npoint Number of nodes in coor. +/// \param coar Internal-point coordinate + coarseness array (in-out). +/// \param ncoar Number of entries in coar. +/// \param curves Node count per internal curve (length ncurvs). +/// \param ncurvs Number of internal curves. +/// \param cocurvs Coordinates of nodes on internal curves (in-out). +/// \param userco User-prescribed node coordinates (in-out), length 2*nuspnt. +/// \param nuspnt Number of user points. +/// \param ctx SEPRAN context. +/// \return TransformParams with xmint, ymint and tran. +TransformParams transform2DSurface(std::span coor, + int npoint, + std::span coar, + int ncoar, + std::span curves, + int ncurvs, + std::span cocurvs, + std::span userco, + int nuspnt, + SepranContext& ctx); + +/// \brief Reverse the transformation applied by transform2DSurface. +/// +/// Applies the inverse: c_orig = xmint + (c_scaled - 1) * tran. +/// +/// \param coor Node coordinate array to reverse-transform (in-out). +/// \param npoint Number of nodes. +/// \param tp Parameters returned by transform2DSurface. +void reverseTransform2DSurface(std::span coor, + int npoint, + const TransformParams& tp); + +} // namespace sepran diff --git a/libs/MeshKernel/CMakeLists.txt b/libs/MeshKernel/CMakeLists.txt index 89fa7a5e8..2fb3902ad 100644 --- a/libs/MeshKernel/CMakeLists.txt +++ b/libs/MeshKernel/CMakeLists.txt @@ -350,6 +350,7 @@ find_package(OpenMP REQUIRED) target_link_libraries( ${TARGET_NAME} LINK_PUBLIC + Sepran Triangle OpenMP::OpenMP_CXX Eigen3::Eigen diff --git a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp index 1921ea1e1..90aef45fa 100644 --- a/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp +++ b/libs/MeshKernel/include/MeshKernel/TriangulationGenerator.hpp @@ -32,41 +32,6 @@ #include "MeshKernel/Mesh2D.hpp" #include "MeshKernel/Polygons.hpp" -extern "C" -{ - - /// \brief SEPRAN function for triangulation of a polygonal region - extern void mshoce( - const int* jnew, // Input: Reset indicator (Fortran Logical pointer) - double* coor, // Output: Flattened array of node coordinates - int* kmeshc, // Output: Connectivity/topology grid matrix - const int* inpelm, // Input: Element type identifier - const int* nbound, // Input: Number of boundary elements - double* bcord, // Input: Coordinates of boundary control nodes - - int* kbndpt, // Input: Type flags for boundary nodes - int* boundary, // Input: Edge-to-node connectivity map - const int* numcurvboun, // Input: Total count of curved boundary segments - int* npoint, // Output: Count of generated points - int* nelem, // Output: Count of generated elements - - int* holeinfo, // Input: Structural layout parameters for holes - const int* nholes, // Input: Total count of internal holes - const int* ncoar, // Input: Quantity of sizing descriptors passed - double* coar, // Input: Target element sizing arrays - int* userpoints, // Input: Fixed target internal points - - int* isurnr, // Output: Surface structural adjacency mapping register - const int* numextcurves, // Input: Auxiliary alignment curve flags - int* numnodextcurvs, // Input: Node mappings for alignment paths - - int* curvenumbers, // Input: Curve curvature flags - double* rinput, // Input: Supplementary sizing/weighting matrices - const int* nuspnt, // Input: Count of forced target control nodes - const int* ndim // Input: Domain spatial dimension identifier - ); -} - namespace meshkernel { diff --git a/libs/MeshKernel/src/TriangulationGenerator.cpp b/libs/MeshKernel/src/TriangulationGenerator.cpp index a5192c5f2..e4482f17e 100644 --- a/libs/MeshKernel/src/TriangulationGenerator.cpp +++ b/libs/MeshKernel/src/TriangulationGenerator.cpp @@ -1,7 +1,10 @@ #include "MeshKernel/TriangulationGenerator.hpp" +#include "Mshoce.hpp" + #include #include +#include #include std::vector meshkernel::SimpleTriangulationGenerator::generatePoints(const Polygons& polygon) const @@ -200,11 +203,33 @@ std::unique_ptr meshkernel::SepranTriangulationGenerator::ge int numberOfPoints = maximumNumberOfNodes; int numberOfElements = maximumNumberOfElements; - mshoce(&newMesh, triangulationNodes.data(), triangulationElementNodes.data(), &elementIdentifier, &numberOfBoundaryNodes, boundaryCoordinates.data(), - edgeNodeConnectivity.data(), boundaryConnectivity.data(), &numberOfPolygons, &numberOfPoints, &numberOfElements, - holeinfo.data(), &numberOfHoles, &numberElementSizing, elementSizing.data(), userpoints.data(), - &surfaceSequenceNumber, &auxiliaryAlignment, numnodextcurvs.data(), curvenumbers.data(), - rinput.data(), &forcedControlPoints, &dimension); + sepran::SepranContext ctx = sepran::SepranContext::defaults(); + + sepran::mshoce( + newMesh != 0, + std::span(triangulationNodes), + std::span(triangulationElementNodes), + elementIdentifier, + numberOfBoundaryNodes, + std::span(boundaryCoordinates), + std::span(edgeNodeConnectivity), + std::span(boundaryConnectivity), + numberOfPolygons, + numberOfPoints, + numberOfElements, + std::span(holeinfo), + numberOfHoles, + numberElementSizing, + std::span(elementSizing), + std::span(userpoints), + surfaceSequenceNumber, + auxiliaryAlignment, + std::span(numnodextcurvs), + std::span(curvenumbers), + std::span(rinput), + forcedControlPoints, + dimension, + ctx); // Recover array of Points std::vector meshNodes(pointsFromFlatArray(triangulationNodes, numberOfPoints)); diff --git a/libs/MeshKernel/tests/CMakeLists.txt b/libs/MeshKernel/tests/CMakeLists.txt index d5c192f9f..81cca6b35 100644 --- a/libs/MeshKernel/tests/CMakeLists.txt +++ b/libs/MeshKernel/tests/CMakeLists.txt @@ -75,7 +75,6 @@ target_link_libraries( MeshKernelTestUtils gmock gtest_main - -Wl,-force_load Sepran ) # Make sure that coverage information is produced when using gcc diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index 3850cee8a..389020d50 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -181,15 +181,16 @@ TEST(Mesh, TriangulateGridWithHoleSepran) meshkernel::SepranTriangulationGenerator generator; auto mesh2 = generator.generate(polygons); - std::vector expectedEdgeStart{0, 0, 0, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 8, 8, 9, 9, 9, 10, 10, 10, 11, 11, 11, 12, 13, 13, 13, 14, 14, 15, 15, 16, 16, 17, 18, 18, 19, 19, 19, 20, 20, 20, 20, 21, 22, 23, 24, 24, 24, 25, 26}; - std::vector expectedEdgeEnd{1, 15, 16, 2, 16, 17, 3, 17, 18, 4, 5, 18, 22, 5, 6, 22, 23, 7, 23, 24, 27, 8, 27, 9, 27, 10, 26, 27, 11, 25, 26, 12, 13, 25, 13, 14, 21, 25, 15, 21, 16, 21, 17, 21, 18, 19, 22, 20, 22, 23, 21, 23, 24, 25, 25, 23, 24, 25, 26, 27, 26, 27}; + std::vector expectedEdgeStart{0, 0, 0, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 3, 4, 5, 5, 6, 6, 6, 6, 6, 7, 7, 8, 8, 9, 9, 9, 10, 10, 10, 11, 11, 11, 12, 13, 13, 13, 14, 14, 15, 15, 16, 16, 17, 18, 18, 19, 19, 19, 20, 20, 20, 20, 21, 22, 22, 23, 23, 25, 25, 25, 26, 27}; - std::vector expectedNodeX{0, 2.5, 5, 7.5, 10, 10, 10, 10, 10, 7.5, 5, 2.5, 0, 0, 0, 0, 2, 3.5, 5, 5, 5, 2, 6.967815551, 7.104568177, 6.730464586, 4.552597509, 6.301132176, 8.595816778}; - std::vector expectedNodeY{0, 0, 0, 0, 0, 2.5, 5, 7.5, 10, 10, 10, 10, 10, 7.5, 5, 2.5, 2, 2, 2, 3.5, 5, 5, 2.750000179, 4.250000179, 6.528037461, 7.250544703, 8.877539953, 8.082877681}; + std::vector expectedEdgeEnd{1, 15, 16, 2, 16, 17, 3, 17, 18, 4, 5, 18, 22, 24, 5, 6, 24, 7, 23, 24, 25, 28, 8, 28, 9, 28, 10, 27, 28, 11, 26, 27, 12, 13, 26, 13, 14, 21, 26, 15, 21, 16, 21, 17, 21, 18, 19, 22, 20, 22, 23, 21, 23, 25, 26, 26, 23, 24, 24, 25, 26, 27, 28, 27, 28}; - ASSERT_EQ(mesh2->GetNumNodes(), 28); - ASSERT_EQ(mesh2->GetNumEdges(), 62); - ASSERT_EQ(mesh2->GetNumFaces(), 34); + std::vector expectedNodeX{0, 2.5, 5, 7.5, 10, 10, 10, 10, 10, 7.5, 5, 2.5, 0, 0, 0, 0, 2, 3.5, 5, 5, 5, 2, 6.6875, 6.875, 8.974717773, 6.709407692, 4.603616331, 6.211802214, 8.535641403}; + std::vector expectedNodeY{0, 0, 0, 0, 0, 2.5, 5, 7.5, 10, 10, 10, 10, 10, 7.5, 5, 2.5, 2, 2, 2, 3.5, 5, 5, 2.750000185, 4.250000185, 3.225816901, 6.554770469, 7.15290529, 8.808791614, 8.139873532}; + + ASSERT_EQ(mesh2->GetNumNodes(), 29); + ASSERT_EQ(mesh2->GetNumEdges(), 65); + ASSERT_EQ(mesh2->GetNumFaces(), 36); const double tolerance = 1.0e-8; @@ -206,6 +207,20 @@ TEST(Mesh, TriangulateGridWithHoleSepran) } } +TEST(Mesh, TriangulateGridFromRealisticPolygon) +{ + + std::string fileName (TEST_FOLDER + "/data/northbank_001b.pol"); + + auto poly = ReadPolygons(fileName, meshkernel::Projection::cartesian); + + meshkernel::SepranTriangulationGenerator generator; + auto mesh2 = generator.generate(*poly); + ASSERT_EQ(mesh2->GetNumFaces(), 3080); + ASSERT_EQ(mesh2->GetNumEdges(), 4733); + ASSERT_EQ(mesh2->GetNumNodes(), 1654); +} + TEST(Mesh, TwoTrianglesDuplicatedEdges) { // 1 Setup From 4d70be091cfde2a1277f05bfb7be89f715312f39 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Wed, 10 Jun 2026 11:38:43 +0200 Subject: [PATCH 35/43] GRIDEDIT-2102 Fixed clang formatting warning --- libs/MeshKernel/tests/src/MeshTests.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index 389020d50..90843054a 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -210,7 +210,7 @@ TEST(Mesh, TriangulateGridWithHoleSepran) TEST(Mesh, TriangulateGridFromRealisticPolygon) { - std::string fileName (TEST_FOLDER + "/data/northbank_001b.pol"); + std::string fileName(TEST_FOLDER + "/data/northbank_001b.pol"); auto poly = ReadPolygons(fileName, meshkernel::Projection::cartesian); From b1f5cf3a4643519deff288728d53e697a019d441 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Wed, 10 Jun 2026 11:43:40 +0200 Subject: [PATCH 36/43] GRIDEDIT-2102 Fixed windows build failure --- extern/sepran/Msho2d.cpp | 1 + extern/sepran/SepranCurveIntersection.cpp | 1 + extern/sepran/SepranFront.cpp | 1 + extern/sepran/SepranQuadratic.cpp | 1 + 4 files changed, 4 insertions(+) diff --git a/extern/sepran/Msho2d.cpp b/extern/sepran/Msho2d.cpp index 5b42d37fb..14ec7ab18 100644 --- a/extern/sepran/Msho2d.cpp +++ b/extern/sepran/Msho2d.cpp @@ -26,6 +26,7 @@ #include #include #include +#include #include namespace sepran diff --git a/extern/sepran/SepranCurveIntersection.cpp b/extern/sepran/SepranCurveIntersection.cpp index 9cfe08759..a3199a870 100644 --- a/extern/sepran/SepranCurveIntersection.cpp +++ b/extern/sepran/SepranCurveIntersection.cpp @@ -11,6 +11,7 @@ #include #include +#include namespace sepran { diff --git a/extern/sepran/SepranFront.cpp b/extern/sepran/SepranFront.cpp index 0661b6c9d..b83b05f51 100644 --- a/extern/sepran/SepranFront.cpp +++ b/extern/sepran/SepranFront.cpp @@ -27,6 +27,7 @@ #include #include #include +#include #include #include diff --git a/extern/sepran/SepranQuadratic.cpp b/extern/sepran/SepranQuadratic.cpp index 2bb08b9b6..c6a950780 100644 --- a/extern/sepran/SepranQuadratic.cpp +++ b/extern/sepran/SepranQuadratic.cpp @@ -15,6 +15,7 @@ #include #include #include +#include #include namespace sepran From 489d7e1b4a955cc81ed691cb3d04857c976d9175 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Wed, 10 Jun 2026 13:10:09 +0200 Subject: [PATCH 37/43] GRIDEDIT-2102 Fixed windows build failure --- libs/MeshKernel/tests/src/MeshTests.cpp | 4 ++-- libs/MeshKernelApi/src/MeshKernel.cpp | 12 ++++++------ libs/MeshKernelApi/tests/src/ApiTest.cpp | 6 ++++++ 3 files changed, 14 insertions(+), 8 deletions(-) diff --git a/libs/MeshKernel/tests/src/MeshTests.cpp b/libs/MeshKernel/tests/src/MeshTests.cpp index 90843054a..bc394494a 100644 --- a/libs/MeshKernel/tests/src/MeshTests.cpp +++ b/libs/MeshKernel/tests/src/MeshTests.cpp @@ -194,13 +194,13 @@ TEST(Mesh, TriangulateGridWithHoleSepran) const double tolerance = 1.0e-8; - for (size_t i = 0; i < mesh2->GetNumNodes(); ++i) + for (meshkernel::UInt i = 0; i < mesh2->GetNumNodes(); ++i) { EXPECT_NEAR(expectedNodeX[i], mesh2->Node(i).x, tolerance); EXPECT_NEAR(expectedNodeY[i], mesh2->Node(i).y, tolerance); } - for (size_t i = 0; i < mesh2->GetNumEdges(); ++i) + for (meshkernel::UInt i = 0; i < mesh2->GetNumEdges(); ++i) { EXPECT_EQ(expectedEdgeStart[i], mesh2->GetEdge(i).first); EXPECT_EQ(expectedEdgeEnd[i], mesh2->GetEdge(i).second); diff --git a/libs/MeshKernelApi/src/MeshKernel.cpp b/libs/MeshKernelApi/src/MeshKernel.cpp index 3da410c6a..8af9f984a 100644 --- a/libs/MeshKernelApi/src/MeshKernel.cpp +++ b/libs/MeshKernelApi/src/MeshKernel.cpp @@ -1947,7 +1947,7 @@ namespace meshkernelapi return lastExitCode; } - MKERNEL_API int mkernel_mesh2d_make_triangular_mesh_from_polygon(int meshKernelId, const GeometryList& polygonPoints, const double scaleFactor) + MKERNEL_API int mkernel_mesh2d_make_triangular_mesh_from_polygon(int meshKernelId, const GeometryList& polygonPoints, const double scaleFactor [[maybe_unused]]) { lastExitCode = meshkernel::ExitCode::Success; try @@ -1961,13 +1961,13 @@ namespace meshkernelapi const meshkernel::Polygons polygon(polygonPointsVector, meshKernelState[meshKernelId].m_mesh2d->m_projection); - meshkernel::TriangulationGenerator* generator = new meshkernel::SimpleTriangulationGenerator(scaleFactor); - - // // generate samples in the first polygonal enclosure - // auto const generatedPoints = polygon.Enclosure(0).GeneratePoints(scaleFactor < 0.0 ? meshkernel::constants::missing::doubleValue : scaleFactor); + // TODO perhaps a triangulation factory or a simple if method == this or method == that then allocate + // SepranTriangulationGenerator or SimpleTriangulationGenerator. This would require a breaking change in the API + // to provide the triangulation method. + meshkernel::SepranTriangulationGenerator generator; // const meshkernel::Mesh2D mesh(generatedPoints, polygon, meshKernetate[meshKernelId].m_mesh2d->m_projection); - meshKernelUndoStack.Add(meshKernelState[meshKernelId].m_mesh2d->Join(*generator->generate(polygon)), meshKernelId); + meshKernelUndoStack.Add(meshKernelState[meshKernelId].m_mesh2d->Join(*generator.generate(polygon)), meshKernelId); } catch (...) { diff --git a/libs/MeshKernelApi/tests/src/ApiTest.cpp b/libs/MeshKernelApi/tests/src/ApiTest.cpp index dafc7f6b0..972213608 100644 --- a/libs/MeshKernelApi/tests/src/ApiTest.cpp +++ b/libs/MeshKernelApi/tests/src/ApiTest.cpp @@ -340,8 +340,14 @@ TEST_F(CartesianApiTestFixture, GenerateTriangularGridThroughApi) ASSERT_EQ(meshkernel::ExitCode::Success, errorCode); // Assert + ASSERT_EQ(33, mesh2d.num_nodes); + ASSERT_EQ(80, mesh2d.num_edges); + +#if 0 + // Leave here until we decide what to do about the triangulation from polygon api ASSERT_EQ(23, mesh2d.num_nodes); ASSERT_EQ(50, mesh2d.num_edges); +#endif } TEST_F(CartesianApiTestFixture, GenerateTriangularGridFromSamplesThroughApi) From 536885b2dc1268ea0c879dc6dfcf7c40f8a40007 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Wed, 10 Jun 2026 13:16:57 +0200 Subject: [PATCH 38/43] GRIDEDIT-2102 Fixed unit test failure (temporary) --- libs/MeshKernelApi/tests/src/ApiTest.cpp | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libs/MeshKernelApi/tests/src/ApiTest.cpp b/libs/MeshKernelApi/tests/src/ApiTest.cpp index 972213608..2b9deda56 100644 --- a/libs/MeshKernelApi/tests/src/ApiTest.cpp +++ b/libs/MeshKernelApi/tests/src/ApiTest.cpp @@ -1858,8 +1858,12 @@ TEST_F(CartesianApiTestFixture, GenerateTriangularGridThroughApi_OnClockWisePoly ASSERT_EQ(meshkernel::ExitCode::Success, errorCode); // Assert + ASSERT_EQ(4, mesh2d.num_nodes); + ASSERT_EQ(5, mesh2d.num_edges); +#if 0 ASSERT_EQ(5, mesh2d.num_nodes); ASSERT_EQ(8, mesh2d.num_edges); +#endif } TEST_F(CartesianApiTestFixture, TranslateMesh) From 13555175bfb69fc42420cf70108596bfd338c150 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Wed, 10 Jun 2026 13:28:10 +0200 Subject: [PATCH 39/43] GRIDEDIT-2102 Missed polygon file in last commit --- data/test/data/northbank_001b.pol | 235 ++++++++++++++++++++++++++++++ 1 file changed, 235 insertions(+) create mode 100755 data/test/data/northbank_001b.pol diff --git a/data/test/data/northbank_001b.pol b/data/test/data/northbank_001b.pol new file mode 100755 index 000000000..15ffcfe48 --- /dev/null +++ b/data/test/data/northbank_001b.pol @@ -0,0 +1,235 @@ +* +* Deltares, RGFGRID Version 7.03.00.77422 (Win64), Nov 30 2022, 15:52:41 +* File creation date: 2025-12-01, 21:04:21 +* +* Coordinate System = Cartesian +* +L000001 + 227 2 + 4.8269651E+04 4.1104092E+05 + 4.8309201E+04 4.1101690E+05 + 4.8348617E+04 4.1099271E+05 + 4.8387901E+04 4.1096835E+05 + 4.8427367E+04 4.1094396E+05 + 4.8465908E+04 4.1091938E+05 + 4.8503840E+04 4.1089477E+05 + 4.8541162E+04 4.1087013E+05 + 4.8578186E+04 4.1084545E+05 + 4.8614778E+04 4.1082038E+05 + 4.8651248E+04 4.1079491E+05 + 4.8687598E+04 4.1076905E+05 + 4.8724086E+04 4.1074251E+05 + 4.8758623E+04 4.1071678E+05 + 4.8791471E+04 4.1069159E+05 + 4.8822627E+04 4.1066693E+05 + 4.8852209E+04 4.1064235E+05 + 4.8881096E+04 4.1061850E+05 + 4.8909403E+04 4.1059494E+05 + 4.8937131E+04 4.1057166E+05 + 4.8964120E+04 4.1054840E+05 + 4.8990744E+04 4.1052578E+05 + 4.9016843E+04 4.1050354E+05 + 4.9042417E+04 4.1048167E+05 + 4.9067297E+04 4.1045999E+05 + 4.9091808E+04 4.1043902E+05 + 4.9115781E+04 4.1041857E+05 + 4.9139217E+04 4.1039866E+05 + 4.9161994E+04 4.1037919E+05 + 4.9184333E+04 4.1036030E+05 + 4.9206113E+04 4.1034191E+05 + 4.9227334E+04 4.1032402E+05 + 4.9247984E+04 4.1030662E+05 + 4.9268183E+04 4.1028959E+05 + 4.9287921E+04 4.1027292E+05 + 4.9307197E+04 4.1025661E+05 + 4.9326096E+04 4.1024074E+05 + 4.9344349E+04 4.1022525E+05 + 4.9362041E+04 4.1021021E+05 + 4.9379173E+04 4.1019564E+05 + 4.9395813E+04 4.1018150E+05 + 4.9412005E+04 4.1016765E+05 + 4.9427817E+04 4.1015406E+05 + 4.9443251E+04 4.1014074E+05 + 4.9458364E+04 4.1012766E+05 + 4.9473152E+04 4.1011479E+05 + 4.9487675E+04 4.1010209E+05 + 4.9501933E+04 4.1008957E+05 + 4.9515984E+04 4.1007721E+05 + 4.9529797E+04 4.1006498E+05 + 4.9543432E+04 4.1005287E+05 + 4.9556888E+04 4.1004086E+05 + 4.9570226E+04 4.1002895E+05 + 4.9583380E+04 4.1001712E+05 + 4.9596410E+04 4.1000536E+05 + 4.9609317E+04 4.0999367E+05 + 4.9622162E+04 4.0998202E+05 + 4.9634852E+04 4.0997043E+05 + 4.9647450E+04 4.0995888E+05 + 4.9659954E+04 4.0994738E+05 + 4.9672429E+04 4.0993590E+05 + 4.9684762E+04 4.0992446E+05 + 4.9697017E+04 4.0991306E+05 + 4.9709194E+04 4.0990168E+05 + 4.9721358E+04 4.0989032E+05 + 4.9733383E+04 4.0987900E+05 + 4.9745335E+04 4.0986770E+05 + 4.9757214E+04 4.0985643E+05 + 4.9769089E+04 4.0984517E+05 + 4.9780823E+04 4.0983395E+05 + 4.9792486E+04 4.0982275E+05 + 4.9804077E+04 4.0981158E+05 + 4.9815668E+04 4.0980042E+05 + 4.9827116E+04 4.0978930E+05 + 4.9838491E+04 4.0977820E+05 + 4.9849794E+04 4.0976713E+05 + 4.9861102E+04 4.0975606E+05 + 4.9872260E+04 4.0974504E+05 + 4.9883345E+04 4.0973405E+05 + 4.9894357E+04 4.0972308E+05 + 4.9905376E+04 4.0971212E+05 + 4.9916239E+04 4.0970121E+05 + 4.9927028E+04 4.0969032E+05 + 4.9937741E+04 4.0967946E+05 + 4.9948459E+04 4.0966860E+05 + 4.9959021E+04 4.0965779E+05 + 4.9969507E+04 4.0964701E+05 + 4.9979916E+04 4.0963626E+05 + 4.9990329E+04 4.0962551E+05 + 5.0000590E+04 4.0961481E+05 + 5.0010779E+04 4.0960414E+05 + 5.0020896E+04 4.0959350E+05 + 5.0031029E+04 4.0958287E+05 + 5.0041006E+04 4.0957229E+05 + 5.0050915E+04 4.0956174E+05 + 5.0060756E+04 4.0955121E+05 + 5.0070630E+04 4.0954072E+05 + 5.0080330E+04 4.0953023E+05 + 5.0089956E+04 4.0951977E+05 + 5.0099508E+04 4.0950931E+05 + 5.0109053E+04 4.0949883E+05 + 5.0118458E+04 4.0948839E+05 + 5.0127790E+04 4.0947794E+05 + 5.0137049E+04 4.0946750E+05 + 5.0146223E+04 4.0945694E+05 + 5.0155375E+04 4.0944650E+05 + 5.0164493E+04 4.0943607E+05 + 5.0173578E+04 4.0942565E+05 + 5.0182618E+04 4.0941513E+05 + 5.0191672E+04 4.0940473E+05 + 5.0200728E+04 4.0939434E+05 + 5.0209787E+04 4.0938397E+05 + 5.0218920E+04 4.0937358E+05 + 5.0227979E+04 4.0936305E+05 + 5.0237036E+04 4.0935235E+05 + 5.0246091E+04 4.0934149E+05 + 5.0255245E+04 4.0933030E+05 + 5.0264132E+04 4.0931934E+05 + 5.0272856E+04 4.0930847E+05 + 5.0281415E+04 4.0929767E+05 + 5.0289830E+04 4.0928695E+05 + 5.0298329E+04 4.0927611E+05 + 5.0306931E+04 4.0926513E+05 + 5.0315637E+04 4.0925403E+05 + 5.0324558E+04 4.0924254E+05 + 5.0333321E+04 4.0923127E+05 + 5.0342038E+04 4.0921996E+05 + 5.0350709E+04 4.0920861E+05 + 5.0359216E+04 4.0919720E+05 + 5.0367862E+04 4.0918569E+05 + 5.0376529E+04 4.0917408E+05 + 5.0385217E+04 4.0916234E+05 + 5.0393847E+04 4.0915032E+05 + 5.0402585E+04 4.0913832E+05 + 5.0411349E+04 4.0912618E+05 + 5.0420140E+04 4.0911390E+05 + 5.0429022E+04 4.0910131E+05 + 5.0437815E+04 4.0908879E+05 + 5.0446584E+04 4.0907617E+05 + 5.0455328E+04 4.0906347E+05 + 5.0464075E+04 4.0905051E+05 + 5.0472787E+04 4.0903760E+05 + 5.0481493E+04 4.0902458E+05 + 5.0490192E+04 4.0901144E+05 + 5.0498869E+04 4.0899802E+05 + 5.0507582E+04 4.0898462E+05 + 5.0516316E+04 4.0897107E+05 + 5.0525070E+04 4.0895737E+05 + 5.0533803E+04 4.0894336E+05 + 5.0542640E+04 4.0892931E+05 + 5.0551538E+04 4.0891504E+05 + 5.0560498E+04 4.0890058E+05 + 5.0579910E+04 4.0888206E+05 + 5.0598392E+04 4.0885159E+05 + 5.0617156E+04 4.0881975E+05 + 5.0636716E+04 4.0878676E+05 + 5.0678375E+04 4.0874172E+05 + 5.0721626E+04 4.0866610E+05 + 5.0768423E+04 4.0858381E+05 + 5.0818108E+04 4.0849554E+05 + 5.0868762E+04 4.0840250E+05 + 5.0968545E+04 4.0833842E+05 + 5.1027975E+04 4.0841417E+05 + 5.1099739E+04 4.0847768E+05 + 5.1072798E+04 4.0857736E+05 + 5.0987017E+04 4.0862324E+05 + 5.0893257E+04 4.0866713E+05 + 5.0804816E+04 4.0870770E+05 + 5.0741644E+04 4.0878350E+05 + 5.0701081E+04 4.0887194E+05 + 5.0681464E+04 4.0891949E+05 + 5.0661848E+04 4.0896703E+05 + 5.0633254E+04 4.0900593E+05 + 5.0604661E+04 4.0904483E+05 + 5.0587704E+04 4.0909304E+05 + 5.0570747E+04 4.0914125E+05 + 5.0551796E+04 4.0918547E+05 + 5.0532844E+04 4.0922970E+05 + 5.0506245E+04 4.0927425E+05 + 5.0479647E+04 4.0931880E+05 + 5.0470670E+04 4.0936435E+05 + 5.0461693E+04 4.0940990E+05 + 5.0472000E+04 4.0946044E+05 + 5.0482307E+04 4.0951098E+05 + 5.0492281E+04 4.0955786E+05 + 5.0502256E+04 4.0960474E+05 + 5.0513560E+04 4.0965428E+05 + 5.0524864E+04 4.0970382E+05 + 5.0536942E+04 4.0976462E+05 + 5.0526089E+04 4.0982664E+05 + 5.0486296E+04 4.0988336E+05 + 5.0421129E+04 4.0995584E+05 + 5.0352638E+04 4.1002965E+05 + 5.0285476E+04 4.1010014E+05 + 5.0216319E+04 4.1017528E+05 + 5.0150488E+04 4.1024577E+05 + 5.0080001E+04 4.1032157E+05 + 5.0014169E+04 4.1039272E+05 + 4.9946342E+04 4.1046654E+05 + 4.9877186E+04 4.1053702E+05 + 4.9796725E+04 4.1059687E+05 + 4.9720253E+04 4.1065738E+05 + 4.9643117E+04 4.1072321E+05 + 4.9566646E+04 4.1078372E+05 + 4.9488845E+04 4.1084690E+05 + 4.9412373E+04 4.1090741E+05 + 4.9333907E+04 4.1097058E+05 + 4.9258766E+04 4.1103176E+05 + 4.9180964E+04 4.1108629E+05 + 4.9093854E+04 4.1104306E+05 + 4.9023085E+04 4.1101596E+05 + 4.8954210E+04 4.1098920E+05 + 4.8908328E+04 4.1097125E+05 + 4.8861447E+04 4.1095396E+05 + 4.8814567E+04 4.1093667E+05 + 4.8768684E+04 4.1094099E+05 + 4.8722802E+04 4.1094531E+05 + 4.8681241E+04 4.1097357E+05 + 4.8639681E+04 4.1100183E+05 + 4.8598785E+04 4.1102943E+05 + 4.8557890E+04 4.1105703E+05 + 4.8512339E+04 4.1107465E+05 + 4.8466789E+04 4.1109227E+05 + 4.8418911E+04 4.1108429E+05 + 4.8371034E+04 4.1107631E+05 + 4.8320342E+04 4.1105861E+05 + 4.8269651E+04 4.1104092E+05 From f6022486b2f0291aa3620c75dda4c04a387881f4 Mon Sep 17 00:00:00 2001 From: Bill Senior Date: Wed, 10 Jun 2026 13:38:15 +0200 Subject: [PATCH 40/43] GRIDEDIT-2102 Fix macos build failures --- cmake/compiler_config.cmake | 3 +++ 1 file changed, 3 insertions(+) diff --git a/cmake/compiler_config.cmake b/cmake/compiler_config.cmake index ad5a12ff5..ac757e2be 100644 --- a/cmake/compiler_config.cmake +++ b/cmake/compiler_config.cmake @@ -25,6 +25,9 @@ if(APPLE) # Optimization / debug flags add_compile_options("$<$:-O2>") add_compile_options("$<$:-g>") + # Disable warnings about implicit conversions between character types + # This is required because of a compatibility issue between clang++ and googletest + add_compile_options("-Wno-character-conversion") else() message(FATAL_ERROR "Unsupported compiler on macOS. Supported: AppleClang/Clang. Found ${CMAKE_CXX_COMPILER_ID}.") endif() From a9c52b71cb3925f4b4769c023411728385af5c8c Mon Sep 17 00:00:00 2001 From: BillSenior Date: Thu, 11 Jun 2026 16:13:28 +0200 Subject: [PATCH 41/43] GRIDEDIT-2102 Added license header --- extern/sepran/Msho2d.cpp | 28 ++++++++++++++++++++-- extern/sepran/Msho2d.hpp | 28 ++++++++++++++++++++-- extern/sepran/Mshoce.cpp | 28 ++++++++++++++++++++-- extern/sepran/Mshoce.hpp | 28 ++++++++++++++++++++-- extern/sepran/SepranBoundary.cpp | 28 ++++++++++++++++++++-- extern/sepran/SepranBoundary.hpp | 28 ++++++++++++++++++++-- extern/sepran/SepranContext.hpp | 28 ++++++++++++++++++++-- extern/sepran/SepranCurveIntersection.cpp | 28 ++++++++++++++++++++-- extern/sepran/SepranCurveIntersection.hpp | 28 ++++++++++++++++++++-- extern/sepran/SepranFront.cpp | 29 ++++++++++++++++++++--- extern/sepran/SepranFront.hpp | 28 ++++++++++++++++++++-- extern/sepran/SepranGeometry.cpp | 28 ++++++++++++++++++++-- extern/sepran/SepranGeometry.hpp | 28 ++++++++++++++++++++-- extern/sepran/SepranQuadratic.cpp | 28 ++++++++++++++++++++-- extern/sepran/SepranQuadratic.hpp | 28 ++++++++++++++++++++-- extern/sepran/SepranSort.cpp | 28 ++++++++++++++++++++-- extern/sepran/SepranSort.hpp | 28 ++++++++++++++++++++-- extern/sepran/SepranTopology.cpp | 28 ++++++++++++++++++++-- extern/sepran/SepranTopology.hpp | 28 ++++++++++++++++++++-- extern/sepran/SepranTransform.cpp | 28 ++++++++++++++++++++-- extern/sepran/SepranTransform.hpp | 28 ++++++++++++++++++++-- 21 files changed, 546 insertions(+), 43 deletions(-) diff --git a/extern/sepran/Msho2d.cpp b/extern/sepran/Msho2d.cpp index 14ec7ab18..039839941 100644 --- a/extern/sepran/Msho2d.cpp +++ b/extern/sepran/Msho2d.cpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of msho2d.for from the SEPRAN library // ("Ingenieursbureau SEPRA", Niek Praagman, 1989-2011). diff --git a/extern/sepran/Msho2d.hpp b/extern/sepran/Msho2d.hpp index 751e03ef6..cbc885c6b 100644 --- a/extern/sepran/Msho2d.hpp +++ b/extern/sepran/Msho2d.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of msho2d.for from the SEPRAN library // ("Ingenieursbureau SEPRA", Niek Praagman, 1989-2011). diff --git a/extern/sepran/Mshoce.cpp b/extern/sepran/Mshoce.cpp index 3fb1fdbde..c0fbc3cd9 100644 --- a/extern/sepran/Mshoce.cpp +++ b/extern/sepran/Mshoce.cpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshoce.for from the SEPRAN library // ("Ingenieursbureau SEPRA", Niek Praagman, 1989-2010). diff --git a/extern/sepran/Mshoce.hpp b/extern/sepran/Mshoce.hpp index f2ba10121..2f25473c2 100644 --- a/extern/sepran/Mshoce.hpp +++ b/extern/sepran/Mshoce.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshoce.for from the SEPRAN library. diff --git a/extern/sepran/SepranBoundary.cpp b/extern/sepran/SepranBoundary.cpp index 88b22bc32..e59667c52 100644 --- a/extern/sepran/SepranBoundary.cpp +++ b/extern/sepran/SepranBoundary.cpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshcopyboun.for and mshchkstapl.for from the SEPRAN library. // diff --git a/extern/sepran/SepranBoundary.hpp b/extern/sepran/SepranBoundary.hpp index 0038952e9..8cdb94ef4 100644 --- a/extern/sepran/SepranBoundary.hpp +++ b/extern/sepran/SepranBoundary.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshcopyboun.for and mshchkstapl.for from the SEPRAN library. diff --git a/extern/sepran/SepranContext.hpp b/extern/sepran/SepranContext.hpp index 6b20c664b..22cd7b5ae 100644 --- a/extern/sepran/SepranContext.hpp +++ b/extern/sepran/SepranContext.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of the Fortran module mshconstants.f90 and msherror module // from the SEPRAN library ("Ingenieursbureau SEPRA"). diff --git a/extern/sepran/SepranCurveIntersection.cpp b/extern/sepran/SepranCurveIntersection.cpp index a3199a870..71f269ffe 100644 --- a/extern/sepran/SepranCurveIntersection.cpp +++ b/extern/sepran/SepranCurveIntersection.cpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshcurvinters.for, mshcurvinters1.for, and mshcurvinters2.for // from the SEPRAN library. diff --git a/extern/sepran/SepranCurveIntersection.hpp b/extern/sepran/SepranCurveIntersection.hpp index ec3d1cae7..5d97c6634 100644 --- a/extern/sepran/SepranCurveIntersection.hpp +++ b/extern/sepran/SepranCurveIntersection.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshcurvinters.for, mshcurvinters1.for, and mshcurvinters2.for // from the SEPRAN library. diff --git a/extern/sepran/SepranFront.cpp b/extern/sepran/SepranFront.cpp index b83b05f51..028da853c 100644 --- a/extern/sepran/SepranFront.cpp +++ b/extern/sepran/SepranFront.cpp @@ -1,3 +1,29 @@ +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // SepranFront.cpp - all translated functions // // C++20 translation of msho01, msho09, msho11, msho12, msho13, msho14, @@ -12,9 +38,6 @@ // itri : flat; itri[k-1] for 1-based node k // istart : CSR ptr; istart[i-1] = cumulative neighbour count through node i -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares - #include "SepranFront.hpp" #include "SepranContext.hpp" #include "SepranGeometry.hpp" diff --git a/extern/sepran/SepranFront.hpp b/extern/sepran/SepranFront.hpp index 63f863085..2a3bde360 100644 --- a/extern/sepran/SepranFront.hpp +++ b/extern/sepran/SepranFront.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of msho01, msho09, msho11-msho14, msho17, msho20-msho21, // msho24-msho30, msho33-msho35, msho36, msho38-msho42 diff --git a/extern/sepran/SepranGeometry.cpp b/extern/sepran/SepranGeometry.cpp index 9c2abd736..a3775464e 100644 --- a/extern/sepran/SepranGeometry.cpp +++ b/extern/sepran/SepranGeometry.cpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshcrossline.for, mshcrossline1.for, and msho75.for // from the SEPRAN library. diff --git a/extern/sepran/SepranGeometry.hpp b/extern/sepran/SepranGeometry.hpp index b4a5ef7f6..47d4df7ef 100644 --- a/extern/sepran/SepranGeometry.hpp +++ b/extern/sepran/SepranGeometry.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshcrossline.for, mshcrossline1.for, and msho75.for // from the SEPRAN library. diff --git a/extern/sepran/SepranQuadratic.cpp b/extern/sepran/SepranQuadratic.cpp index c6a950780..fa2ef7221 100644 --- a/extern/sepran/SepranQuadratic.cpp +++ b/extern/sepran/SepranQuadratic.cpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of msho31.for, msho32.for, msh401-403/406/416 from SEPRAN. // diff --git a/extern/sepran/SepranQuadratic.hpp b/extern/sepran/SepranQuadratic.hpp index 363a2654a..e11418874 100644 --- a/extern/sepran/SepranQuadratic.hpp +++ b/extern/sepran/SepranQuadratic.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of msho31.for, msho32.for, msh401.for, msh402.for, // msh403.for, msh406.for, msh416.for from the SEPRAN library. diff --git a/extern/sepran/SepranSort.cpp b/extern/sepran/SepranSort.cpp index 831987054..8c7355396 100644 --- a/extern/sepran/SepranSort.cpp +++ b/extern/sepran/SepranSort.cpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of chsort.for from the SEPRAN library. // diff --git a/extern/sepran/SepranSort.hpp b/extern/sepran/SepranSort.hpp index 0bde9b52d..363257bda 100644 --- a/extern/sepran/SepranSort.hpp +++ b/extern/sepran/SepranSort.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of chsort.for from the SEPRAN library. diff --git a/extern/sepran/SepranTopology.cpp b/extern/sepran/SepranTopology.cpp index 5d8dd9f2d..7a4f986ad 100644 --- a/extern/sepran/SepranTopology.cpp +++ b/extern/sepran/SepranTopology.cpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of msho02, msho03, msho10, msho18, msho19, msho22 // from the SEPRAN library. diff --git a/extern/sepran/SepranTopology.hpp b/extern/sepran/SepranTopology.hpp index bb2d3eceb..052f54b3c 100644 --- a/extern/sepran/SepranTopology.hpp +++ b/extern/sepran/SepranTopology.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of msho02, msho03, msho10, msho18, msho19, msho22 // from the SEPRAN library. diff --git a/extern/sepran/SepranTransform.cpp b/extern/sepran/SepranTransform.cpp index 227446e21..1224f7d07 100644 --- a/extern/sepran/SepranTransform.cpp +++ b/extern/sepran/SepranTransform.cpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshtrans2dsur.for from the SEPRAN library. // diff --git a/extern/sepran/SepranTransform.hpp b/extern/sepran/SepranTransform.hpp index 46977f52e..4c5a5f041 100644 --- a/extern/sepran/SepranTransform.hpp +++ b/extern/sepran/SepranTransform.hpp @@ -1,5 +1,29 @@ -// SPDX-License-Identifier: GPL-3.0-or-later -// SPDX-FileCopyrightText: 2025 Stichting Deltares +//----- AGPL -------------------------------------------------------------------- +// +// Copyright (C) Stichting Deltares, 2017-2026. +// +// This programme is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation version 3. +// +// This programme 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 Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with This programme. If not, see . +// +// contact: delft3d.support@deltares.nl +// Stichting Deltares +// P.O. Box 177 +// 2600 MH Delft, The Netherlands +// +// All indications and logos of, and references to, "Delft3D", +// "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting +// Deltares, and remain the property of Stichting Deltares. All rights reserved. +// +//------------------------------------------------------------------------------- // // C++20 translation of mshtrans2dsur.for from the SEPRAN library. From d8a71cd81d3c5cfa78b8e092952b1cade49b24cf Mon Sep 17 00:00:00 2001 From: BillSenior Date: Thu, 25 Jun 2026 12:50:06 +0200 Subject: [PATCH 42/43] GRIDEDIT-2102 Removed unnecessary Fortran files --- extern/sepran/chsort.for | 131 -- extern/sepran/msh401.for | 909 ----------- extern/sepran/msh402.for | 251 --- extern/sepran/msh403.for | 173 -- extern/sepran/msh406.for | 88 - extern/sepran/msh416.for | 93 -- extern/sepran/mshchkstapl.for | 165 -- extern/sepran/mshconstants.f90 | 17 - extern/sepran/mshcopyboun.for | 259 --- extern/sepran/mshcrossline.for | 162 -- extern/sepran/mshcrossline1.for | 127 -- extern/sepran/mshcurvinters.for | 156 -- extern/sepran/mshcurvinters1.for | 194 --- extern/sepran/mshcurvinters2.for | 183 --- extern/sepran/mshdummymethods.f90 | 121 -- extern/sepran/msho01.for | 216 --- extern/sepran/msho02.for | 135 -- extern/sepran/msho03.for | 88 - extern/sepran/msho04.for | 112 -- extern/sepran/msho05.for | 105 -- extern/sepran/msho06.for | 608 ------- extern/sepran/msho07.for | 145 -- extern/sepran/msho08.for | 383 ----- extern/sepran/msho09.for | 109 -- extern/sepran/msho10.for | 182 --- extern/sepran/msho11.for | 142 -- extern/sepran/msho12.for | 194 --- extern/sepran/msho13.for | 354 ---- extern/sepran/msho14.for | 113 -- extern/sepran/msho15.for | 117 -- extern/sepran/msho16.for | 156 -- extern/sepran/msho17.for | 96 -- extern/sepran/msho18.for | 284 ---- extern/sepran/msho19.for | 93 -- extern/sepran/msho20.for | 96 -- extern/sepran/msho21.for | 88 - extern/sepran/msho22.for | 114 -- extern/sepran/msho24.for | 226 --- extern/sepran/msho25.for | 148 -- extern/sepran/msho26.for | 115 -- extern/sepran/msho27.for | 147 -- extern/sepran/msho28.for | 174 -- extern/sepran/msho29.for | 294 ---- extern/sepran/msho2d.for | 2481 ----------------------------- extern/sepran/msho30.for | 266 ---- extern/sepran/msho31.for | 413 ----- extern/sepran/msho32.for | 98 -- extern/sepran/msho33.for | 126 -- extern/sepran/msho34.for | 270 ---- extern/sepran/msho35.for | 477 ------ extern/sepran/msho36.for | 356 ----- extern/sepran/msho38.for | 587 ------- extern/sepran/msho39.for | 116 -- extern/sepran/msho40.for | 257 --- extern/sepran/msho41.for | 106 -- extern/sepran/msho42.for | 96 -- extern/sepran/msho75.for | 295 ---- extern/sepran/mshoce.for | 458 ------ extern/sepran/mshtrans2dsur.for | 218 --- 59 files changed, 14683 deletions(-) delete mode 100644 extern/sepran/chsort.for delete mode 100644 extern/sepran/msh401.for delete mode 100644 extern/sepran/msh402.for delete mode 100644 extern/sepran/msh403.for delete mode 100644 extern/sepran/msh406.for delete mode 100644 extern/sepran/msh416.for delete mode 100644 extern/sepran/mshchkstapl.for delete mode 100644 extern/sepran/mshconstants.f90 delete mode 100644 extern/sepran/mshcopyboun.for delete mode 100644 extern/sepran/mshcrossline.for delete mode 100644 extern/sepran/mshcrossline1.for delete mode 100644 extern/sepran/mshcurvinters.for delete mode 100644 extern/sepran/mshcurvinters1.for delete mode 100644 extern/sepran/mshcurvinters2.for delete mode 100644 extern/sepran/mshdummymethods.f90 delete mode 100644 extern/sepran/msho01.for delete mode 100644 extern/sepran/msho02.for delete mode 100644 extern/sepran/msho03.for delete mode 100644 extern/sepran/msho04.for delete mode 100644 extern/sepran/msho05.for delete mode 100644 extern/sepran/msho06.for delete mode 100644 extern/sepran/msho07.for delete mode 100644 extern/sepran/msho08.for delete mode 100644 extern/sepran/msho09.for delete mode 100644 extern/sepran/msho10.for delete mode 100644 extern/sepran/msho11.for delete mode 100644 extern/sepran/msho12.for delete mode 100644 extern/sepran/msho13.for delete mode 100644 extern/sepran/msho14.for delete mode 100644 extern/sepran/msho15.for delete mode 100644 extern/sepran/msho16.for delete mode 100644 extern/sepran/msho17.for delete mode 100644 extern/sepran/msho18.for delete mode 100644 extern/sepran/msho19.for delete mode 100644 extern/sepran/msho20.for delete mode 100644 extern/sepran/msho21.for delete mode 100644 extern/sepran/msho22.for delete mode 100644 extern/sepran/msho24.for delete mode 100644 extern/sepran/msho25.for delete mode 100644 extern/sepran/msho26.for delete mode 100644 extern/sepran/msho27.for delete mode 100644 extern/sepran/msho28.for delete mode 100644 extern/sepran/msho29.for delete mode 100644 extern/sepran/msho2d.for delete mode 100644 extern/sepran/msho30.for delete mode 100644 extern/sepran/msho31.for delete mode 100644 extern/sepran/msho32.for delete mode 100644 extern/sepran/msho33.for delete mode 100644 extern/sepran/msho34.for delete mode 100644 extern/sepran/msho35.for delete mode 100644 extern/sepran/msho36.for delete mode 100644 extern/sepran/msho38.for delete mode 100644 extern/sepran/msho39.for delete mode 100644 extern/sepran/msho40.for delete mode 100644 extern/sepran/msho41.for delete mode 100644 extern/sepran/msho42.for delete mode 100644 extern/sepran/msho75.for delete mode 100644 extern/sepran/mshoce.for delete mode 100644 extern/sepran/mshtrans2dsur.for diff --git a/extern/sepran/chsort.for b/extern/sepran/chsort.for deleted file mode 100644 index 86a3271f9..000000000 --- a/extern/sepran/chsort.for +++ /dev/null @@ -1,131 +0,0 @@ - subroutine chsort ( keysrt, kgrad, npoint ) -! ====================================================================== -! -! programmer Jos van Kan/Onno Hoitinga -! version 3.1 date 26-12-1998 Remove continues -! version 3.0 date 25-01-1995 Complete new subroutine, programmed -! by Onno Hoitinga -! version 2.3 date 20-06-1994 Adaptation comments -! version 2.2 date 03-02-1994 New comments -! version 2.1 date 22-11-1990 Change declarations to prevent errors -! version 2.0 date 12-05-1989 Complete revision, with extra parameters -! version 1.0 date 21-06-1987 -! -! -! copyright (c) 1987-1998 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! This routine gets as input array keysrt of length npoint -! on output array kgrad contains the indices to sort array keysrt -! The Heap sort algorithm is used -! ********************************************************************** -! -! KEYWORDS -! -! sort -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - implicit none - integer npoint, keysrt(npoint), kgrad(npoint) - -! keysrt i sortkey (integer) on array to be sorted. -! kgrad o contains permutation index that sorts keysrt -! in ascending order on output. -! npoint i number of entries in keysrt & kgrad -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer i, j, l, ir, kgradt, q - -! i Counting variable -! ir ? -! j Counting variable -! kgradt ? -! l General loop variable -! q ? -! ********************************************************************** -! -! I/O -! -! none -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! This routine originates from Numerical Recipes (fortran edition) -! Cambridge University Press 1989 -! ********************************************************************** -! -! MODULES USED -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - do j = 1, npoint - kgrad(j) = j - end do - if ( npoint.le.1 ) go to 1000 - l = npoint/2+1 - ir = npoint - -200 if ( l.gt.1 ) then - l = l-1 - kgradt = kgrad(l) - q = keysrt(kgradt) - else - kgradt = kgrad(ir) - q = keysrt(kgradt) - kgrad(ir) = kgrad(1) - ir = ir-1 - if ( ir.eq.1 ) then - kgrad(1) = kgradt - go to 1000 - end if - end if - i = l - j = l+l -300 if ( j.le.ir ) then - if ( j.lt.ir ) then - if ( keysrt(kgrad(j)).lt.keysrt(kgrad(j+1)) ) j = j+1 - end if - if ( q.lt.keysrt(kgrad(j)) ) then - kgrad(i) = kgrad(j) - i = j - j = j+j - else - j = ir+1 - end if - go to 300 - end if - kgrad(i) = kgradt - go to 200 - -1000 end diff --git a/extern/sepran/msh401.for b/extern/sepran/msh401.for deleted file mode 100644 index 2549c99a0..000000000 --- a/extern/sepran/msh401.for +++ /dev/null @@ -1,909 +0,0 @@ - subroutine msh401 ( npoint, kmeshc , nelem , istart, ibrp, - + ibrpnt, kelemh, ishape, inpelm, niedge, - + nisurf, nivolm ) -! ====================================================================== -! -! programmer Niek Praagman -! version 5.7 date 18-11-2000 Include connection elements -! version 5.6 date 18-04-1997 Extension with interface elements -! version 5.5 date 05-04-1995 add niedge, nisurf and nivolm to indi- -! cate whether lines, surfaces and volu- -! mes are included or not) -! version 5.4 date 15-02-1995 add npoint for call of MSH402 -! version 5.3 date 22-10-1993 extra parameter inpelm for ishape=-199 -! version 5.2 date 02-02-1993 new requirements layout etc -! version 5.1 date 22-08-1991 Zdenek: no dimension, cdc, ce -! version 5.0 date 10-09-1990 variable number IBRP of neighbours -! Deletion of inpelm -! version 4.0 date 14-03-1989 2D and 3D elements -! -! copyright (c) 1986-2000 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Fill neighbour arrays (istart and ibrpnt) for refinement -! In istart the addresses where the neighbours of point i are -! stored in array ibrpnt are stored. In this routine it is assumed -! that each point has ibrp neighbours. Neighbours of point i are -! stored from position istart(i) to istart(i+1)-1 . In the final -! form only the neighbours with nodal numbers smaller than point i -! are stored , together with the new points . If a point has more -! than ibrp neighbours, the extra neighbours are temporarily stored -! in array kelemh. Arrays istart and ibrpnt are adjusted according- -! ly in subroutine msh400. -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! refine -! neighbour -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use msherror - use mshdummymethods - - implicit none - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer npoint, kmeshc(*), istart(*), ibrpnt(*), kelemh(*), nelem, - + ibrp, ishape, inpelm, niedge, nisurf, nivolm - -! ibrp i number of assumed neighbours -! ibrpnt o neighbour array -! inpelm i number of nodes in element ishape -! ishape i type of elements to be considered (see SEPRAN -! PROGRAMMERS GUIDE) -! istart o array containing the start positions of -! array ibrpnt -! kelemh o helparray for extra neighbours -! kmeshc i array containing the elements -! nelem i number of elements -! niedge i number of nodes to be placed on edges -! nisurf i number of nodes to be placed on faces -! nivolm i number of nodes to be placed in volumes -! npoint i number of nodes in mesh originally -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer i(27), ie, ielem, it, j, jelem - - -! i node numbers of element -! ie first node of diagonal -! ielem loop variable elements -! it second node of diagonal -! j loop variable -! jelem helppointer -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Deconcatenate name of subroutine from string -! EROPEN Concatenate name to string of calling subroutines -! ERRINT Fills integer in error message -! ERRSUB Produces error message -! INSTOP Stop SEPRAN execution -! MSH402 Place neighbour in neighbour array -! MSH416 Determine correct order in nodenumbers -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! 531 REFINE or TRANSF not yet available for this type of element -! ********************************************************************** -! -! PSEUDO CODE -! -! PSEUDO CODE -! Run through all elements of this group -! Fill node array for each element -! Place lines, surfaces and/or volumes in neighbour array -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - character(len=260) localName - localName = 'msh401' - call eropen( localName ) - -! --- Run through all elements of this group - - if ( ishape.eq.-9 ) then - -! --- Special line element containing all points of one side - - do j = 1 , inpelm-1 - - i(1) = kmeshc( j ) - i(2) = kmeshc( j+1 ) - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - - end do - - else if ( ishape.eq.1 ) then - -! --- inpelm = 2 - - do ielem = 1, nelem - - jelem = 2 * ( ielem - 1 ) - - do j = 1 , 2 - - i(j) = kmeshc( jelem + j ) - - end do - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - - end do - - else if ( ishape.eq.2 ) then - -! --- inpelm = 3 - - do ielem = 1, nelem - - jelem = 3 * ( ielem - 1 ) - - do j = 1 , 3 - - i(j) = kmeshc( jelem + j ) - - end do - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - - end do - - else if ( ishape.eq.3 ) then - -! --- inpelm = 3 - - do ielem = 1, nelem - - jelem = 3 * ( ielem - 1 ) - - do j = 1 , 3 - - i(j) = kmeshc( jelem + j ) - - end do - - if ( niedge.gt.0 ) then - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(1), - + kelemh ) - - end if - -! --- Place surface later in array ibrpnt (see MSH443) ! - - end do - - else if ( ishape.eq.4 ) then - -! --- inpelm = 6 - - do ielem = 1, nelem - - jelem = 6 * ( ielem - 1 ) - - do j = 1 , 6 - - i(j) = kmeshc( jelem + j ) - - end do - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(5), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(1), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(6), - + kelemh ) - - end do - - else if ( ishape.eq.5 ) then - -! --- inpelm = 4 - - do ielem = 1, nelem - - jelem = 4 * ( ielem - 1 ) - - do j = 1 , 4 - - i(j) = kmeshc( jelem + j ) - - end do - - if ( niedge.gt.0 ) then - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(1), - + kelemh ) - - end if - - if ( nisurf.gt. 0 .or. - + nisurf.eq.-1 .and. niedge.gt.0 ) then - -! --- One extra for new middlepoint - - call msh416( i(1), i(2), i(3), i(4), ie, it ) - - it = it * npoint - - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - end if - - end do - - else if ( ishape.eq.6 ) then - -! --- inpelm = 9 - - do ielem = 1, nelem - - jelem = 9 * ( ielem - 1 ) - - do j = 1 , 9 - - i(j) = kmeshc( jelem + j ) - - end do - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(8), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(5), - + kelemh ) - - call msh416( i(1), i(2), i(9), i(8), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - call msh416( i(2), i(3), i(4), i(9), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - call msh416( i(8), i(9), i(6), i(7), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - call msh416( i(9), i(4), i(5), i(6), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - end do - - else if ( ishape.eq.7 ) then - -! --- inpelm = 7 - - do ielem = 1, nelem - - jelem = 7 * ( ielem - 1 ) - - do j = 1 , 7 - - i(j) = kmeshc( jelem + j ) - - end do - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(5), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(1), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(2), - + kelemh ) - - end do - - else if ( ishape.eq.11 ) then - -! --- inpelm = 4 - - do ielem = 1, nelem - - jelem = 4 * ( ielem - 1 ) - - do j = 1 , 4 - - i(j) = kmeshc( jelem + j ) - - end do - - if ( niedge.gt.0 ) then - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), - + kelemh ) - - end if - -! --- Place the four surfaces later in the neighbour arrays ! -! (Use routine MSH443) - - end do - - else if ( ishape.eq.12 ) then - -! --- inpelm = 10 - - do ielem = 1, nelem - - jelem = 10 * ( ielem - 1 ) - - do j = 1 , 10 - - i(j) = kmeshc( jelem + j ) - - end do - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(8), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(8), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(5), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(8), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(8), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(8), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(10), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(10), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(9), i(10), - + kelemh ) - - end do - - else if ( ishape.eq.13 ) then - -! --- inpelm = 8 - - do ielem = 1, nelem - - jelem = 8 * ( ielem - 1 ) - - do j = 1 , 8 - - i(j) = kmeshc( jelem + j ) - - end do - - if ( niedge.gt.0 ) then - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(4), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(1), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(5), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(8), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(7), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(8), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(5), - + kelemh ) - - end if - - if ( nisurf.gt. 0 .or. - + nisurf.eq.-1 .and. niedge.gt.0 ) then - -! --- Store the six faces - - call msh416( i(1), i(2), i(3), i(4), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - call msh416( i(1), i(2), i(6), i(5), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - call msh416( i(2), i(3), i(7), i(6), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - call msh416( i(3), i(4), i(8), i(7), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - call msh416( i(1), i(4), i(8), i(5), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - call msh416( i(5), i(6), i(7), i(8), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - end if - - if ( nivolm.gt. 0 .or. - + nivolm.eq.-1 .and. niedge.gt.0 ) then - - ie = min( i(1), i(7) ) - it = max( i(1), i(7) ) - - it = npoint * ( npoint + 1 ) + it - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - - end if - - end do - - else if ( ishape.eq.14 ) then - -! --- inpelm = 27 - - do ielem = 1, nelem - - jelem = 27 * ( ielem - 1 ) - - do j = 1 , 27 - - i(j) = kmeshc( jelem + j ) - - end do - -! --- determine new points in "first plane" - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(2), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(4), - + kelemh ) - call msh416( i(1), i(2), i(5), i(4), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(5), - + kelemh ) - call msh416( i(2), i(3), i(6), i(5), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(5), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(6), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(7), - + kelemh ) - call msh416( i(4), i(5), i(8), i(7), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(8), - + kelemh ) - call msh416( i(5), i(6), i(9), i(8), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(9), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(8), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(9), - + kelemh ) - -! --- "second plane" - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(10), - + kelemh ) - call msh416( i(1), i(2), i(11), i(10), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(11), - + kelemh ) - call msh416( i(2), i(3), i(12), i(11), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(12), - + kelemh ) - call msh416( i(1), i(4), i(13), i(10), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(3), i(14), - + kelemh ) - call msh416( i(3), i(6), i(15), i(12), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(13), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(4), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(5), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(6), i(15), - + kelemh ) - call msh416( i(4), i(7), i(16), i(13), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(9), i(14), - + kelemh ) - call msh416( i(6), i(9), i(18), i(15), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(7), i(16), - + kelemh ) - call msh416( i(7), i(8), i(17), i(16), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(8), i(17), - + kelemh ) - call msh416( i(8), i(9), i(18), i(17), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(9), i(18), - + kelemh ) - -! --- "third plane" - - call msh402( npoint, ibrp, ibrpnt, istart, i(10), i(11), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(11), i(12), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(10), i(13), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(10), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(11), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(12), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(12), i(15), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(13), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(14), i(15), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(13), i(16), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(14), i(16), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(14), i(17), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(14), i(18), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(15), i(18), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(16), i(17), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(17), i(18), - + kelemh ) - -! --- "fourth plane" - - call msh402( npoint, ibrp, ibrpnt, istart, i(10), i(19), - + kelemh ) - call msh416( i(10), i(11), i(20), i(19), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(11), i(20), - + kelemh ) - call msh416( i(11), i(12), i(21), i(20), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(12), i(21), - + kelemh ) - call msh416( i(10), i(13), i(22), i(19), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(19), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(20), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(21), i(14), - + kelemh ) - call msh416( i(12), i(15), i(24), i(21), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(22), i(13), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(22), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(23), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(24), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(24), i(15), - + kelemh ) - call msh416( i(13), i(16), i(25), i(22), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(25), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(26), i(14), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(27), i(14), - + kelemh ) - call msh416( i(15), i(18), i(27), i(24), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(25), i(16), - + kelemh ) - call msh416( i(16), i(17), i(26), i(25), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(26), i(17), - + kelemh ) - call msh416( i(17), i(18), i(27), i(26), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(27), i(18), - + kelemh ) - -! --- "fifth plane" - - call msh402( npoint, ibrp, ibrpnt, istart, i(19), i(20), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(20), i(21), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(19), i(22), - + kelemh ) - call msh416( i(19), i(20), i(23), i(22), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(20), i(23), - + kelemh ) - call msh416( i(20), i(21), i(24), i(23), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(21), i(24), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(22), i(23), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(23), i(24), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(22), i(25), - + kelemh ) - call msh416( i(22), i(23), i(26), i(25), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(23), i(26), - + kelemh ) - call msh416( i(23), i(24), i(27), i(26), ie, it ) - it = it * npoint - call msh402( npoint, ibrp, ibrpnt, istart, ie, it, - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(24), i(27), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(25), i(26), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(26), i(27), - + kelemh ) - - end do - - else if ( ishape.eq.50 ) then - -! --- inpelm = 50 - - do ielem = 1, nelem - - jelem = 4 * ( ielem - 1 ) - - do j = 1, 4 - - i(j) = kmeshc( jelem + j ) - - end do - - if ( niedge.gt.0 ) then - - call msh402( npoint, ibrp, ibrpnt, istart, i(1), i(3), - + kelemh ) - call msh402( npoint, ibrp, ibrpnt, istart, i(2), i(4), - + kelemh ) - - end if - -! --- Place surface later in array ibrpnt (see MSH443) ! - - end do - - else - -! --- not yet available - - call errint ( ishape, 1 ) - call errsub ( 531, 1, 0, 0 ) - go to 1000 - - end if - -1000 call erclos('msh401') - - end - diff --git a/extern/sepran/msh402.for b/extern/sepran/msh402.for deleted file mode 100644 index 51423aa65..000000000 --- a/extern/sepran/msh402.for +++ /dev/null @@ -1,251 +0,0 @@ - subroutine msh402( npoint, ibrp, ibrpnt, istart, i1, i2, kelemh ) -! ====================================================================== -! -! programmer Niek Praagman -! version 2.5 date 14-02-1995 use alternative of neighbours -! and npoint -! version 2.4 date 03-03-1993 layout adjustments, new norms -! version 2.3 date 18-08-1992 iabs==>abs -! version 2.2 date 22-08-1991 Zdenek: no dimension, cdc, ce -! version 2.1 date 10-09-1990 variable length for IBRPNT -! version 2.0 date 01-03-1989 -! -! -! -! copyright (c) 1986-1995 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard or soft copy granted only by written license obtained -! from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system (e.g. , in memory, disk or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! -! ********************************************************************** -! -! DESCRIPTION -! -! Fill the nodal point numbers in the right positions of array ibrpnt -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! neighbour -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - use mshdummymethods - - implicit none - integer npoint, ibrpnt(*), i1, i2, ibrp, istart(*), kelemh(*) - -! i1 i first node number to be considered -! i2 i second node number to be considred -! ibrp i number of places available in IBRPNT for each -! point -! ibrpnt i,o array containing sequentially the neighbour- -! points -! istart i array of startposition for each nodal point -! in ibrpnt -! kelemh o array to store extra neighbours if a point has -! more than ibrp neighbours -! npoint i number of nodes before operation -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer idif, ih, ihigh, il, ilow, j, ja, jstart, jstend - -! idif difference -! ih number of neighbour -! ihigh highest node number of i1,i2 -! il loop variable -! ilow lowest node number of i1,i2 -! j loop variable -! ja local indicator which storage system is used -! jstart startposition in ibrpnt -! jstend endposition in ibrpnt -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Deconcatenate name from string of calling subroutines -! EROPEN Concatenate name to string of calling subroutines -! ERRSUB Produce error message -! INSTOP Stop SEPRAN execution -! ********************************************************************** -! -! ERROR MESSAGES -! -! 1274 No place left for neighbour -! ********************************************************************** -! -! PSEUDO CODE -! -! Check whether special situation (i1 < 0) -! -! If special situation ja = 1 else ja = 0 -! -! Determine lowest and highest node number if both are smaller -! than npoint else change roles -! -! Store : ilow is neighbour of ihigh -! -! Determine places in array with neighbours -! -! If ja=1 than start situation else rearranged situation -! -! Check whether new point -! -! If new than place number in array of neighbours -! -! ********************************************************************** -! -! MODULES USED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - character(len=260) localName - localName = 'msh402' - call eropen( localName ) - - if ( i1.lt.0 ) then - - ja = 0 - i1 = -i1 - - else - - ja = 1 - - end if - -! --- Determine ilow and ihigh - - if ( i1.gt.i2 ) then - -! --- Check for npoint - - if ( i1.gt.npoint ) then - - ilow = i1 - ihigh = i2 - - else - - ilow = i2 - ihigh = i1 - - end if - - else - -! --- Check for npoint - - if ( i2.gt.npoint ) then - - ilow = i2 - ihigh = i1 - - else - - ilow = i1 - ihigh = i2 - - end if - - end if - -! --- ilow is neighbour of ihigh - - if ( ja.eq.1 ) then - - jstart = ibrp * ( ihigh - 1 ) + 1 - jstend = jstart + ibrp - 1 - - else - - jstart = istart( ihigh ) - jstend = istart( ihigh + 1 ) - 1 - - end if - -! --- Run through available positions - -100 ih = ibrpnt( jstart ) - - if ( ih.eq.0 ) then - - ibrpnt( jstart ) = ilow - istart( ihigh ) = istart( ihigh ) + ja - -! --- Ready - - goto 1000 - - else if ( ih.eq.ilow ) then - -! --- Line already stored - - goto 1000 - - end if - - jstart = jstart + 1 - - if ( jstart.gt.jstend ) then - - if ( ja.eq.0 ) then - - call errsub ( 1274, 0, 0, 0 ) - - end if - - j = kelemh(1) - -! --- Check whether this line is already in kelemh - - do il = 1 , j - - idif = abs ( kelemh(2*il ) - ihigh ) + - + abs ( kelemh(2*il+1) - ilow ) - - if ( idif.eq.0 ) goto 1000 - - end do - -! --- Place in kelemh - - kelemh( 2 * j + 2 ) = ihigh - kelemh( 2 * j + 3 ) = ilow - kelemh( 1 ) = j + 1 - istart( ihigh ) = istart( ihigh ) + 1 - -! --- Ready - - goto 1000 - - end if - - goto 100 - -1000 call erclos('msh402') - - end - diff --git a/extern/sepran/msh403.for b/extern/sepran/msh403.for deleted file mode 100644 index 5307fe26e..000000000 --- a/extern/sepran/msh403.for +++ /dev/null @@ -1,173 +0,0 @@ - subroutine msh403( npoint, i1, i3, ibrpnt, istart, i2 ) -! ====================================================================== -! -! programmer niek praagman -! version 2.1 date 22-07-1998 Layout -! version 2.0 date 14-02-1995 npoint added; other storage of -! neighbour nodes -! version 1.3 date 08-04-1994 initialize i2 -! version 1.2 date 03-03-1993 adjustment layout and error 949 -! version 1.1 date 22-08-1991 Zdenek: no dimension, cdc, ce -! version 1.0 date 01-02-1986 -! -! -! -! copyright (c) 1986-1998 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard or soft copy granted only by written license obtained -! from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system (e.g. , in memory, disk or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! -! ********************************************************************** -! -! DESCRIPTION -! -! Determine the nodal point number i2 of a new point between the nodes -! i1 and i3 as stored in array ibrpnt -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! neighbour -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - use mshdummymethods - - implicit none - integer i1, i2, i3, ibrpnt(*), istart(*), npoint - -! i1 i first node number to be considered -! i2 o node number of intermediate point -! i3 i last node number of line to be considered -! ibrpnt i array containing the neighbours of the -! nodes sequentially -! istart i array containing the startaddresses for -! each original nodal point -! npoint i number of nodes in original mesh -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer ihelp, ihigh, ilow, jstart, jstend - -! ihelp place to store node number temporarily -! ihigh highest node number -! ilow lowest node number -! jstart start position neighbour points -! jstend last position neighbour points -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Deconcatenate name from string of calling subroutines -! EROPEN Concatenate name to string of calling subroutines -! ERRSUB Produce error message -! ********************************************************************** -! -! ERROR MESSAGES -! -! 949 No intermediate neighbour found -! ********************************************************************** -! -! PSEUDO CODE -! -! Determine position taking the value of npoint into account -! -! Check new neighbour number -! -! If no point is found, error ! -! -! ********************************************************************** -! -! MODULES USED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - character(len=260) localName - localName = 'msh403' - call eropen( localName ) - - i2 = 0 - -! --- determine place - - if ( i1.gt.i3 ) then - -! --- Check for npoint - - if ( i1.gt.npoint ) then - - ilow = i1 - ihigh = i3 - - else - - ilow = i3 - ihigh = i1 - - end if - - else - -! --- Check for npoint - - if ( i3.gt.npoint ) then - - ilow = i3 - ihigh = i1 - - else - - ilow = i1 - ihigh = i3 - - end if - - end if - - jstart = istart( ihigh ) - jstend = istart( ihigh + 1 ) - 1 - -100 ihelp = ibrpnt(jstart) - - if ( ihelp.eq.ilow ) then - -! --- Point found - - i2 = ibrpnt( jstart + 1 ) - - goto 1000 - - end if - - jstart = jstart + 2 - - if ( jstart.le.jstend ) goto 100 - -! --- Error, no point number found - - call errsub ( 949, 0, 0, 0 ) - -1000 call erclos('msh403') - - end - diff --git a/extern/sepran/msh406.for b/extern/sepran/msh406.for deleted file mode 100644 index 0fff8b98e..000000000 --- a/extern/sepran/msh406.for +++ /dev/null @@ -1,88 +0,0 @@ - subroutine msh406( kelem, j, i1, i2, i3, i4, i5, i6 ) - -! ======================================================================= -! -! -! programmer niek praagman -! -! version 2.0 date 03-03-1993 adjustment layout -! version 1.1 date 22-08-1991 Zdenek: no dimension, cdc, ce -! version 1 date 19-5-1986 -! -! -! -! copyright (c) 1986-1993 "ingenieursbureau sepra" -! permission to copy or distribute this software or documentation -! in hard or soft copy granted only by written license obtained -! from "ingenieursbureau sepra". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system (e.g. , in memory, disk or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! -! *********************************************************************** -! -! DESCRIPTION -! -! Subroutine to place nodes in element array in case of a quadratic -! triangle -! -! *********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! quadratic -! triangle -! -! *********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - implicit none - - integer i1, i2, i3, i4, i5, i6, j, kelem( 6,j ) - -! i1 first node -! i2 second node -! i3 third node -! i4 fourth node -! i5 fifth node -! i6 sixth node -! j triangle number to be considered -! kelem element array -! -! *********************************************************************** -! -! COMMON BLOCKS -! -! *********************************************************************** -! -! LOCAL PARAMETERS -! -! *********************************************************************** -! -! SUBROUTINES CALLED -! -! *********************************************************************** -! -! ERROR MESSAGES -! -! *********************************************************************** -! -! METHOD -! -! PSEUDO CODE -! -! ======================================================================= - - kelem( 1,j ) = i1 - kelem( 2,j ) = i2 - kelem( 3,j ) = i3 - kelem( 4,j ) = i4 - kelem( 5,j ) = i5 - kelem( 6,j ) = i6 - - end - diff --git a/extern/sepran/msh416.for b/extern/sepran/msh416.for deleted file mode 100644 index dfa52c803..000000000 --- a/extern/sepran/msh416.for +++ /dev/null @@ -1,93 +0,0 @@ - subroutine msh416( i1, i2, i3, i4, ie, it ) -! ======================================================================= -! -! -! programmer niek praagman -! version 1.3 date 06-04-1995 ie is min, it is max -! version 1.2 date 04-02-1993 New norms -! version 1.1 date 23-02-1989 -! -! -! -! copyright (c) 1989 - 1995 "ingenieursbureau sepra" -! permission to copy or distribute this software or documentation -! in hard or soft copy granted only by written license obtained -! from "ingenieursbureau sepra". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system (e.g. , in memory, disk or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! -! *********************************************************************** -! -! DESCRIPTION -! -! Determine begin and endpoint of (main-)diagonal in quadrilateral -! -! *********************************************************************** -! -! KEYWORDS -! -! quadrilateral -! diagonal -! -! *********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - implicit none - - integer i1, i2, i3, i4, ie, it - -! i1 first node of quadrilateral -! i2 second -! i3 third -! i4 fourth -! ie first node of chosen diagonal -! it second node of chosen diagonal -! -! *********************************************************************** -! -! COMMON BLOCKS -! -! *********************************************************************** -! -! LOCAL PARAMETERS -! - integer im - -! im smallest node value of quadrilateral -! -! *********************************************************************** -! -! SUBROUTINES CALLED -! -! -! *********************************************************************** -! -! ERROR MESSAGES -! -! *********************************************************************** -! -! METHOD -! -! PSEUDO CODE -! -! ======================================================================= - - im = min (i1,i2,i3,i4) - - if ( im.eq.i1 .or. im.eq.i3 ) then - - ie = min( i1, i3 ) - it = max( i1, i3 ) - - else - - ie = min( i2, i4 ) - it = max( i2, i4 ) - - end if - - end diff --git a/extern/sepran/mshchkstapl.for b/extern/sepran/mshchkstapl.for deleted file mode 100644 index 72e76e9e5..000000000 --- a/extern/sepran/mshchkstapl.for +++ /dev/null @@ -1,165 +0,0 @@ - subroutine mshchkstapl ( kstapl, lenkstapl, text ) -! ====================================================================== -! -! programmer Guus Segal -! version 1.0 date 10-02-2003 -! -! copyright (c) 2003-2003 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Check the contents of array kstapl -! It is checked if a node that is on the left-hand side is also the -! right-hand side -! ********************************************************************** -! -! KEYWORDS -! -! mesh -! check -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -!AvD include 'SPcommon/cmcdpi' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer kstapl(2,*), lenkstapl - character *(*) text - -! kstapl i Array containing the actual boundary build by -! pairs of nodes -! lenkstapl i Number of pairs in kstapl -! text i String variable containing some text to be -! printed as part of the debugging -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer i, j, iseq1(lenkstapl), iseq2(lenkstapl), - + iwork(lenkstapl), ihelp(lenkstapl) - logical debug, found - -! debug If true debug statements are carried out otherwise -! they are not -! found If true an error has been found -! i Counting variable -! ihelp integer work array to be used for the sorting -! iseq1 Array containing the nodes of the left-hand side -! of the pairs after sorting -! iseq2 Array containing the node after sortings of the right-hand -! side of the pairs -! iwork integer work array to store the nodes of either the -! left-hand side or the right-hand side of the pairs -! j Counting variable -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! CHSORT Sort integer array for increasing sequence -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! INSTOP Stop the program -! PRININ1 print 2d integer array -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen ( 'mshchkstapl' ) - debug = .false. - - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'Debug information from mshchkstapl' - - end if - if ( lenkstapl.eq.0 ) go to 1000 - -! --- Check array by sorting each row of pairs - - do i = 1, lenkstapl - iwork(i) = kstapl(1,i) - end do - call chsort ( iwork, ihelp, lenkstapl ) - do i = 1, lenkstapl - iseq1(i) = iwork(ihelp(i)) - end do - - do i = 1, lenkstapl - iwork(i) = kstapl(2,i) - end do - call chsort ( iwork, ihelp, lenkstapl ) - do i = 1, lenkstapl - iseq2(i) = iwork(ihelp(i)) - end do - - found = .false. - do i = 1, lenkstapl - if ( iseq1(i).ne.iseq2(i) ) then - -! --- first point found in second column - - found = .true. - j = i - go to 100 - - end if - - end do - -100 if ( found ) then - -! --- Both rows do not contain the same node numbers - - write(irefwr,*) text - write(irefwr,*) 'Both columns of kstapl do not contain the ', - + 'same node numbers' - write(irefwr,*) 'The ', j, '-th nodes are different' - do i = 1, lenkstapl - write(irefwr,110) i, iseq1(i), iseq2(i) -110 format ( i5, ': ', 2i6 ) - end do - call prinin1 ( kstapl, lenkstapl, 2, 'kstapl' ) - !AvD: call instop - - end if - -1000 call erclos ( 'mshchkstapl' ) - if ( debug ) write(irefwr,*) 'End mshchkstapl' - - end diff --git a/extern/sepran/mshconstants.f90 b/extern/sepran/mshconstants.f90 deleted file mode 100644 index 2a05c2725..000000000 --- a/extern/sepran/mshconstants.f90 +++ /dev/null @@ -1,17 +0,0 @@ -module mshconstants - -double precision, parameter :: EPSMAC = 1.0d-15 -double precision, parameter :: SQREPS = 1.0d-15 -double precision, parameter :: RINFIN = 1.0d77 -integer, parameter :: IREFWR = 66 -integer :: ITIME = 1 -integer :: IGOBS = 1 -integer :: JTIMES = 1 - -end module - -module msherror - -integer :: IERROR = 0 - -end module diff --git a/extern/sepran/mshcopyboun.for b/extern/sepran/mshcopyboun.for deleted file mode 100644 index e4631e13d..000000000 --- a/extern/sepran/mshcopyboun.for +++ /dev/null @@ -1,259 +0,0 @@ - subroutine mshcopyboun ( jpnt, nbound, bcord, coor, kbndpt, - + kbound, inside, nbn, fillkbound) -! ====================================================================== -! -! programmer Guus Segal -! version 2.0 date 08-02-2001 Extra parameter ihelp -! version 1.0 date 03-04-1999 -! -! copyright (c) 1999-2001 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Fill the arrays kbndpt, kbound and coor with information concerning -! the nodes on the boundary -! kbndpt and kbound are only filled if fillkbound is true -! ********************************************************************** -! -! KEYWORDS -! -! boundary -! copy -! mesh -! ********************************************************************** -! -! MODULES USED -! - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer jpnt, nbound, kbndpt(*), kbound(*), inside, nbn!, -! + ihelp(0:*) - double precision bcord(2,*), coor(2,*) - logical fillkbound - -! bcord i array containing the coordinates of the boundaries -! coor o array of length ndim x npoint containing the -! co-ordinates of the nodal points with respect to the -! global numbering -! In this subroutine only the boundary is filled. -! It is supposed that the points on the boundary are -! also the first points in coor -! fillkbound i if true the array kbndpt and kbound must be filled -! ihelp integer work array of length nparts+1, where nparts -! is the number of closed boundaries -! ihelp(0) = 0 -! ihelp(j) is the last relative number of part j with -! respect to kbndpt -! inside o indicator how many internal regions have to be -! considered -! jpnt o last point number used -! kbndpt o array containing the nodal point numbers of the -! boundary -! kbound o help array for boundary lines, length 2*npunt -! nbn o number of boundary points -! nbound i number of points in bcord -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision, allocatable, dimension(:) :: ihelp - - double precision dx, dy, ref, xst, yst, xp, yp, ds - integer i, j, jst, ifirst, ilast, nparts - logical finished - -! ds distance -! dx x-distance -! dy y-distance -! finished Indicates if the loop has been finished (true) or not -! (false) -! i Counting variable -! ifirst First node in part -! ilast Last node in part -! j Counting variable -! jst nodal point number of first point of local boundary -! nparts number of closed parts the boundary consists of -! ref reference length -! xp x-coordinate of point -! xst x-coordinate of first point -! yp y-coordinate of point -! yst y-coordinate of first point -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! initialize parameters -! Compute reference distance -! Detect the number of parts the boundary consists of and store information -! in ihelp -! -! For all points in the boundary do -! if ( first point on a new part of the boundary ) then -! raise node number -! Copy coor -! Fill kbndpt if necessary -! else ( next point on the boundary ) -! Fill kbound -! If ( last point of closed boundary ) then -! reset j -! Fill kbndpt if necessary -! Fill kbound if necessary -! else ( not last point of closed boundary ) -! Fill kbndpt if necessary -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- initialize parameters - - nbn = 0 - jpnt = 0 - inside = -1 - -! --- Allocate helparrays: - - ! Worst-case estimate of nr of closed boundary polygons - nparts = 1+.5*nbound - allocate( ihelp ( 0:nparts ) ) - -! --- Compute reference distance - - dx = bcord(1,2) - bcord(1,1) - dy = bcord(2,2) - bcord(2,1) - - ref = 1d-5 * sqrt( dx*dx + dy*dy ) - j = 0 - -! --- Detect number of closed parts the boundary consists of and store in -! ihelp - - ihelp(0) = 0 - finished = .false. - nparts = 0 - ifirst = 1 - do while ( .not. finished ) - -! --- Not all parts have been found -! Store starting node -! ilast is last point in closed boundary - - xst = bcord(1,ifirst) - yst = bcord(2,ifirst) - -! --- Find last point that coincides with starting point - - ilast = nbound - do i = ifirst+1, nbound - - xp = bcord(1,i) - yp = bcord(2,i) - dx = xp - xst - dy = yp - yst - ds = sqrt( dx*dx + dy*dy ) - if ( ds.le.ref ) ilast = i - - end do - -! --- Raise nparts - - nparts = nparts+1 - ihelp(nparts) = ilast - if ( ilast.eq.nbound ) finished = .true. - ifirst = ilast+1 - - end do - -! --- Loop over all parts - - do j = 1, nparts - ifirst = ihelp(j-1)+1 - ilast = ihelp(j) - do i = ifirst, ilast - xp = bcord(1,i) - yp = bcord(2,i) - - if ( i.eq.ihelp(j-1)+1 ) then - -! --- first point on a new part of the boundary - - if ( inside.lt.1 ) inside = inside + 1 - jst = jpnt+1 - jpnt = jpnt + 1 - coor(1,jpnt) = xp - coor(2,jpnt) = yp - if ( fillkbound ) kbndpt(i) = jpnt - - else - -! --- next point on the boundary - - if ( fillkbound ) then - -! --- fill kbound - - nbn = nbn + 1 - kbound(2*nbn-1) = jpnt - kbound(2*nbn ) = jpnt + 1 - - end if - - if ( i.eq.ihelp(j) ) then - -! --- end point of a closed boundary found - - if ( fillkbound ) then - kbound(2*nbn) = jst - kbndpt(i) = jst - end if - - else - -! --- not end point of a closed boundary - - jpnt = jpnt + 1 - coor(1,jpnt) = xp - coor(2,jpnt) = yp - if ( fillkbound ) kbndpt(i) = jpnt - - end if - - end if - - end do - - end do - - deallocate( ihelp ) - - - end diff --git a/extern/sepran/mshcrossline.for b/extern/sepran/mshcrossline.for deleted file mode 100644 index c228705cc..000000000 --- a/extern/sepran/mshcrossline.for +++ /dev/null @@ -1,162 +0,0 @@ - subroutine mshcrossline ( x1, x2, x3, x4, fact1, fact2, eps ) -! ====================================================================== -! -! programmer Guus Segal -! version 1.2 date 16-07-2008 adaptation for zero determinant -! version 1.1 date 29-06-2006 Debug statements -! version 1.0 date 30-11-2000 -! -! copyright (c) 2000-2008 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Find the intersection of the lines x1-x2 and x3-x4 -! The result is the parameter fact, where the intersection point is defined -! as x1 + fact*(x2-x1) -! If no intersection point is found fact gets the value -infinity -! Two-dimensions only -! ********************************************************************** -! -! KEYWORDS -! -! 2d -! intersection -! line -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use msherror - use mshdummymethods - - implicit none - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision x1(2), x2(2), x3(2), x4(2), fact1, fact2, eps - -! eps i local accuracy -! fact1 o Defines the factor for the intersection point -! The intersection point on the face is defined by -! x1 + fact1 * (x2-x1) -! fact2 o Defines the factor for the intersection point -! The intersection point on the face is defined by -! x3 + fact2 * (x4-x3) -! x1 i Contains the coordinates of the point x1 -! x2 i Contains the coordinates of the point x2 -! x3 i Contains the coordinates of the point x3 -! x4 i Contains the coordinates of the point x4 -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision det, amax - logical debug - -! amax maximum value of coordinates -! debug If true debug statements are carried out otherwise -! they are not -! det determinant of system of equations to be solved -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! PRINRL Print 1d real vector -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! The line through x1-x2 is defined as -! x = x1 + fact1 * (x2-x1) -! The line through x3-x4 is defined as -! x = x3 + fact2 * (x4-x3) -! If an intersection is present then -! x1 + fact * (x2-x1) = x3 + alpha1 * (x4-x3) -! Hence: -! [ (x2-x1) (x4-x3) ] [fact -alpha1]^T = x3-x1 -! This system can be solved if det( [ (x2-x1) (x4-x3) ] ) # 0 -! The solution is: -! -! [fact1 -fact2]^T = [ (x2-x1) (x4-x3) ]^(-1) (x3-x1) -! -! or: -! -! det = (x2-x1)*(y4-y3)-(x4-x3)*(y2-y1) -! fact1 = ((y4-y3)*(x3-x1)+(x3-x4)*(y3-y1))/det -! fact2 = -((y1-y2)*(x3-x1)+(x2-x1)*(y3-y1))/det -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - character(len=260) localName - localName = 'mshcrossline' - call eropen( localName ) - - debug = .false. - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'Debug information from mshcrossline' - 2 format ( a, 1x, (5d12.4) ) -! call prinrl ( x1, 2, 'x1' ) -! call prinrl ( x2, 2, 'x2' ) -! call prinrl ( x3, 2, 'x3' ) -! call prinrl ( x4, 2, 'x4' ) - - end if ! ( debug ) - if ( ierror/=0 ) go to 1000 - - det = (x2(1)-x1(1))*(x4(2)-x3(2))-(x4(1)-x3(1))*(x2(2)-x1(2)) - amax = max(abs(x1(1)), abs(x1(2)), abs(x2(1)), abs(x2(2)), - + abs(x3(1)), abs(x3(2)), abs(x4(1)), abs(x4(2)) ) - if ( debug ) write(irefwr,2) 'det', det - if ( abs(det)<=epsmac*amax*100d0 ) then - fact1 = -rinfin - fact2 = -rinfin - else - fact1 = ((x4(2)-x3(2))*(x3(1)-x1(1))+ - + (x3(1)-x4(1))*(x3(2)-x1(2)))/det - if ( fact1>=-eps .and. fact1<=1d0+eps ) then - fact2 = -((x1(2)-x2(2))*(x3(1)-x1(1))+ - + (x2(1)-x1(1))*(x3(2)-x1(2)))/det - else - fact2 = -rinfin - end if - end if - -1000 call erclos ( 'mshcrossline' ) - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'End mshcrossline' - write(irefwr,2) 'fact1, fact2', fact1, fact2 - - end if ! ( debug ) - - end diff --git a/extern/sepran/mshcrossline1.for b/extern/sepran/mshcrossline1.for deleted file mode 100644 index 0ede43e91..000000000 --- a/extern/sepran/mshcrossline1.for +++ /dev/null @@ -1,127 +0,0 @@ - subroutine mshcrossline1 ( x1, x2, x3, x4, fact1, fact2, eps ) -! ====================================================================== -! -! programmer Guus Segal -! version 1.0 date 26-11-2003 -! -! copyright (c) 2000-2003 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Find the intersection of the lines x1-x2 and x3-x4 -! The result is the parameter fact, where the intersection point is defined -! as x1 + fact*(x2-x1) -! If no intersection point is found fact gets the value -infinity -! Two-dimenions only -! First it is checked if the rectangles around both lines intersect -! ********************************************************************** -! -! KEYWORDS -! -! 2d -! intersection -! line -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - - implicit none -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision x1(2), x2(2), x3(2), x4(2), fact1, fact2, eps - -! eps i local accuracy -! fact1 o Defines the factor for the intersection point -! The intersection point on the face is defined by -! x1 + fact1 * (x2-x1) -! fact2 o Defines the factor for the intersection point -! The intersection point on the face is defined by -! x3 + fact2 * (x4-x3) -! x1 i Contains the coordinates of the point x1 -! x2 i Contains the coordinates of the point x2 -! x3 i Contains the coordinates of the point x3 -! x4 i Contains the coordinates of the point x4 -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision xmin1, xmin2, ymin1, ymin2, xmax1, xmax2, - + ymax1, ymax2 - -! xmax1 maximum x-coordinate of first edge -! xmax2 maximum x-coordinate of second edge -! xmin1 maximum y-coordinate of first edge -! xmin2 maximum y-coordinate of second edge -! ymax1 maximum x-coordinate of third edge -! ymax2 maximum x-coordinate of fourth edge -! ymin1 maximum y-coordinate of third edge -! ymin2 maximum y-coordinate of fourth edge -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! MSHCROSSLINE Computes the intersection of two lines -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! The line through x1-x2 is defined as -! x = x1 + fact1 * (x2-x1) -! The line through x3-x4 is defined as -! x = x3 + fact2 * (x4-x3) -! If an intersection is present then -! x1 + fact * (x2-x1) = x3 + alpha1 * (x4-x3) -! Hence: -! [ (x2-x1) (x4-x3) ] [fact -alpha1]^T = x3-x1 -! This system can be solved if det( [ (x2-x1) (x4-x3) ] ) # 0 -! The solution is: -! -! [fact1 -fact2]^T = [ (x2-x1) (x4-x3) ]^(-1) (x3-x1) -! -! or: -! -! det = (x2-x1)*(y4-y3)-(x4-x3)*(y2-y1) -! fact1 = ((y4-y3)*(x3-x1)+(x3-x4)*(y3-y1))/det -! fact2 = -((y1-y2)*(x3-x1)+(x2-x1)*(y3-y1))/det -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - fact1 = -rinfin - fact2 = -rinfin - xmin1 = min(x1(1),x2(1)) - xmax1 = max(x1(1),x2(1)) - ymin1 = min(x1(2),x2(2)) - ymax1 = max(x1(2),x2(2)) - xmin2 = min(x3(1),x4(1)) - xmax2 = max(x3(1),x4(1)) - ymin2 = min(x3(2),x4(2)) - ymax2 = max(x3(2),x4(2)) - if ( xmax1.lt.xmin2-eps .or. xmin1.gt.xmax2+eps .or. - + ymax1.lt.ymin2-eps .or. ymin1.gt.ymax2+eps ) go to 1000 - call mshcrossline ( x1, x2, x3, x4, fact1, fact2, eps ) -1000 end - diff --git a/extern/sepran/mshcurvinters.for b/extern/sepran/mshcurvinters.for deleted file mode 100644 index 8b1da9525..000000000 --- a/extern/sepran/mshcurvinters.for +++ /dev/null @@ -1,156 +0,0 @@ - subroutine mshcurvinters ( ncurvs, iwork, xbox, icurvs, curves ) -! ====================================================================== -! -! programmer Guus Segal -! version 1.0 date 28-11-2005 -! -! copyright (c) 2005-2005 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Give an error if two curves intersect -! At this moment 2d only -! ********************************************************************** -! -! KEYWORDS -! -! intersection -! curve -! 2d -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use msherror - - implicit none -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer ncurvs, iwork(*), icurvs(*) - double precision xbox(2,ncurvs,2), curves(2,*) - -! curves i array containing the coordinates of the curves -! icurvs i array containing the number of points in the curves -! accumulated -! iwork i integer work array of length ncurvs -! iwork(i) = -1: curve is empty -! iwork(i) = 0: curve is single -! iwork(i) = 1: curve is compound -! ncurvs i Number of curves in mesh -! xbox i Is used to store the minimum and maximum coordinates -! of all curves -! xbox(i,j,1) minimum i^th coordinate of curve j -! xbox(i,j,2) maximum i^th coordinate of curve j -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer icurnr, jcurnr - logical debug - -! debug If true debug statements are carried out otherwise -! they are not -! icurnr Curve sequence number -! jcurnr Curve sequence number -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! MSHCURVINTERS1 Give an error if 2 curves intersect -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! For all single curves icurnr do -! for all single curve with sequence number>icurnr do -! If ( possible intersection ) then -! if ( subparts of curve intersect ) then -! give error message -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen ( 'mshcurvinters' ) - debug = .false. - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'Debug information from mshcurvinters' - - end if - if ( ierror/=0 ) go to 1000 - -! --- For all single curves icurnr do - - do icurnr = 1, ncurvs - - if ( iwork(icurnr)==0 ) then - -! --- single non-empty curve found -! for all single curve with sequence number>icurnr do - - do jcurnr = icurnr+1, ncurvs - - if ( iwork(jcurnr)==0 ) then - -! --- single non-empty curve found -! If ( possible intersection ) then -! xminixbox(1,jcurnr,2) ) go to 200 - if ( xbox(1,jcurnr,1)>xbox(1,icurnr,2) ) go to 200 - -! --- yminixbox(2,jcurnr,2) ) go to 200 - if ( xbox(2,jcurnr,1)>xbox(2,icurnr,2) ) go to 200 - -! --- if ( subparts of curve intersect ) then -! give error message - - call mshcurvinters1 ( icurnr, jcurnr, icurvs, curves ) - - end if ! ( iwork(jcurnr)==0 ) - -200 end do ! jcurnr = icurnr+1, ncurvs - - end if ! ( iwork(i)==0 ) - - end do ! icurnr = 1, ncurvs - -1000 call erclos ( 'mshcurvinters' ) - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'End mshcurvinters' - - end if - - end - diff --git a/extern/sepran/mshcurvinters1.for b/extern/sepran/mshcurvinters1.for deleted file mode 100644 index c9744a3aa..000000000 --- a/extern/sepran/mshcurvinters1.for +++ /dev/null @@ -1,194 +0,0 @@ - subroutine mshcurvinters1 ( icurnr, jcurnr, icurvs, curves ) -! ====================================================================== -! -! programmer Guus Segal -! version 1.0 date 28-11-2005 -! -! copyright (c) 2005-2005 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Give an error if 2 curves intersect -! 2d only -! ********************************************************************** -! -! KEYWORDS -! -! intersection -! curve -! 2d -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use msherror - - implicit none - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer icurnr, jcurnr, icurvs(*) - double precision curves(2,*) - -! curves i array containing the coordinates of the curves -! icurnr i Curve sequence number of first curve -! icurvs i array containing the number of points in the curves -! accumulated -! jcurnr i Curve sequence number of second curve -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer k, j, istart, jstart, inodes, jnodes - double precision x1(2), x2(2), x3(2), x4(2), eps, fact1, fact2 - logical debug - -! debug If true debug statements are carried out otherwise -! they are not -! eps Local accuracy -! fact1 multiplication factor -! fact2 multiplication factor -! inodes number of nodes on icurnr -! istart Last position used at icurnr -! j Counting variable -! jnodes number of nodes on jcurnr -! jstart Last position used at jcurnr -! k Counting variable -! x1 coordinates of first point of edge in icurnr -! x2 coordinates of last point of edge in icurnr -! x3 coordinates of first point of edge in jcurnr -! x4 coordinates of last point of edge in jcurnr -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! ERREAL Put real in error message -! ERRINT Put integer in error message -! ERRWAR Warnings -! MSHCROSSLINE1 Find the intersection of the lines x1-x2 and x3-x4 -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! 2787 curves intersect -! ********************************************************************** -! -! PSEUDO CODE -! -! for all edges on curve 1 do -! for all edges on curve 2 do -! if edges intersect give error message -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen ( 'mshcurvinters1' ) - debug = .false. - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'Debug information from mshcurvinters1' - write(irefwr,100) 'icurnr, jcurnr', icurnr, jcurnr -100 format ( a, 1x, (10i6) ) -110 format ( a, 1x, (5d12.4) ) - - end if - if ( ierror/=0 ) go to 1000 - eps = sqreps - -! --- for all edges on curve 1 do - - if ( icurnr==1 ) then - istart = 0 - else - istart = icurvs(icurnr-1) - end if ! ( icurnr==1 ) - inodes = icurvs(icurnr)-istart - x1(1) = curves(1,istart+1) ! first node of edge - x1(2) = curves(2,istart+1) - - do j = 2, inodes - - x2(1) = curves(1,istart+j) ! last node of edge - x2(2) = curves(2,istart+j) - -! --- for all edges on curve 2 do - - if ( jcurnr==1 ) then - jstart = 0 - else - jstart = icurvs(jcurnr-1) - end if ! ( icurnr==1 ) - jnodes = icurvs(jcurnr)-jstart - x3(1) = curves(1,jstart+1) ! first node of edge - x3(2) = curves(2,jstart+1) - - do k = 2, jnodes - - x4(1) = curves(1,jstart+k) ! last node of edge - x4(2) = curves(2,jstart+k) - -! --- if edges intersect give error message - - call mshcrossline1 ( x1, x2, x3, x4, fact1, fact2, eps ) - if ( debug ) then - write(irefwr,100) 'j, k', j, k - write(irefwr,110) 'x1, x2', x1, x2 - write(irefwr,110) 'x3, x4', x3, x4 - write(irefwr,110) 'fact1, fact2', fact1, fact2 - end if ! ( debug ) - - if ( fact1>sqreps .and. fact1<1d0-sqreps .and. - + fact2>sqreps .and. fact2<1d0-sqreps ) then - -! --- curves intersect, give error message and leave subroutine - - call errint ( icurnr, 1 ) - call errint ( jcurnr, 2 ) - call erreal ( x1(1) + fact1 * (x2(1)-x1(1)), 1 ) - call erreal ( x1(2) + fact1 * (x2(2)-x1(2)), 2 ) - call errwar ( 2787, 2, 2, 0 ) - go to 1000 - - end if ! ( fact1>sqreps .and. fact1<1d0-sqreps ... ) - x3(1) = x4(1) - x3(2) = x4(2) - - end do ! k = 2, jnodes - x1(1) = x2(1) - x1(2) = x2(2) - - end do ! j = 1, nnodes-1 - -1000 call erclos ( 'mshcurvinters1' ) - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'End mshcurvinters1' - - end if - - end - diff --git a/extern/sepran/mshcurvinters2.for b/extern/sepran/mshcurvinters2.for deleted file mode 100644 index ebe7cb013..000000000 --- a/extern/sepran/mshcurvinters2.for +++ /dev/null @@ -1,183 +0,0 @@ - subroutine mshcurvinters2 ( kbound, nbound, coor, isurnr ) -! ====================================================================== -! -! programmer Guus Segal -! version 1.0 date 30-11-2005 -! -! copyright (c) 2005-2005 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Check if edges in boundary of surface do not intersect -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh -! surface -! boundary -! check -! intersection -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use msherror - use mshdummymethods - - implicit none - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer kbound(2,*), nbound, isurnr - double precision coor(2,*) - -! coor i contains the coordinates of the nodes on the boundary -! isurnr i Surface sequence number -! kbound i Contains the node numbers of the boundary edges -! kbound(1,i) first node of edge i -! kbound(2,i) last node of edge i -! nbound i Number of edges on the boundary -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer i, j - double precision eps, fact1, fact2, x1(2), x2(2), x3(2), x4(2) - logical debug - -! debug If true debug statements are carried out otherwise -! they are not -! eps Local accuracy -! fact1 multiplication factor -! fact2 multiplication factor -! i Counting variable -! j Counting variable -! x1 coordinates of first point of edge in icurnr -! x2 coordinates of last point of edge in icurnr -! x3 coordinates of first point of edge in jcurnr -! x4 coordinates of last point of edge in jcurnr -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! ERREAL Put real in error message -! ERRINT Put integer in error message -! ERRSUB Error messages -! MSHCROSSLINE1 Find the intersection of the lines x1-x2 and x3-x4 -! PRININ1 print 2d integer array -! PRINRL1 Print 2d real vector -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! 2788 boundary intersects itself -! ********************************************************************** -! -! PSEUDO CODE -! -! for all edges on boundary do -! for all edges with higher number on boundary do -! if edges intersect give error message -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - character(len=260) localName - localName = 'mshcurvinters2' - call eropen( localName ) - - debug = .false. - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'Debug information from mshcurvinters2' - write(irefwr,100) 'isurnr', isurnr -100 format ( a, 1x, (10i6) ) -110 format ( a, 1x, (5d15.7) ) - - end if - if ( ierror/=0 ) go to 1000 - eps = 1d-3 - -! --- for all edges on boundary do - - do i = 1, nbound-1 - - x1(1) = coor(1,kbound(1,i)) ! first node of edge - x1(2) = coor(2,kbound(1,i)) - x2(1) = coor(1,kbound(2,i)) ! last node of edge - x2(2) = coor(2,kbound(2,i)) - -! --- for all edges with higher number on boundary do - - do j = i+1, nbound - - x3(1) = coor(1,kbound(1,j)) ! first node of edge - x3(2) = coor(2,kbound(1,j)) - x4(1) = coor(1,kbound(2,j)) ! last node of edge - x4(2) = coor(2,kbound(2,j)) - -! --- if edges intersect give error message - - call mshcrossline1 ( x1, x2, x3, x4, fact1, fact2, eps ) - if ( debug ) then - write(irefwr,100) 'i, j', i, j - write(irefwr,100) 'kbound(i)', kbound(1,i), kbound(2,i) - write(irefwr,100) 'kbound(j)', kbound(1,j), kbound(2,j) - write(irefwr,110) 'x1, x2', x1, x2 - write(irefwr,110) 'x3, x4', x3, x4 - write(irefwr,110) 'fact1, fact2', fact1, fact2 - end if ! ( debug ) - - if ( fact1>eps .and. fact1<1d0-eps .and. - + fact2>eps .and. fact2<1d0-eps ) then - -! --- curves intersect, give error message and leave subroutine - - call errint ( isurnr, 1 ) - call errint ( i, 2 ) - call errint ( j, 3 ) - call erreal ( x1(1) + fact1 * (x2(1)-x1(1)), 1 ) - call erreal ( x1(2) + fact1 * (x2(2)-x1(2)), 2 ) - call errsub ( 2788, 3, 2, 0 ) - - end if ! ( fact1>sqreps .and. fact1<1d0-sqreps ... ) - - end do ! j = i+1, nbound - - end do ! i = 1, nbound-1 - -1000 call erclos ( 'mshcurvinters2' ) - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'End mshcurvinters2' - - end if - - end - diff --git a/extern/sepran/mshdummymethods.f90 b/extern/sepran/mshdummymethods.f90 deleted file mode 100644 index 095868f61..000000000 --- a/extern/sepran/mshdummymethods.f90 +++ /dev/null @@ -1,121 +0,0 @@ -module mshdummymethods - -implicit none - -private - -public eropen -public ersettime -public erclos -public errsub -public errint -public errchr -public erreal -public prinrl1 -public prinin -public prinin1 -public eralloc -public erdealloc -public printtime - -!=============================================================================== -contains -! -!------------------------------------------------------------------------------ -subroutine eropen(aErrorString) - character(len=*) :: aErrorString - -end subroutine - -subroutine ersettime(aErrorTime) - doubleprecision :: aErrorTime - integer i - i = 1 -end subroutine - -subroutine erclos(aErrorString) - character :: aErrorString - integer i - i = 1 -end subroutine - -subroutine errsub(aError1, aError2, aError3, aError4) -use msherror - integer :: aError1 - integer :: aError2 - integer :: aError3 - integer :: aError4 - integer i - - ierror = 1 -end subroutine - -subroutine errint(aError1, aError2) - integer :: aError1 - integer :: aError2 - integer i - i = 1 -end subroutine - -subroutine errchr(aErrorString, aErrorNumber) - character :: aErrorString - integer :: aErrorNumber - integer i - i = 1 - -end subroutine - -subroutine erreal(aErrorValue, aErrorNumber) - doubleprecision :: aErrorValue - integer :: aErrorNumber - integer i - i = 1 -end subroutine - -subroutine prinrl1( rarr, n1, n2, name) - double precision, intent(in) :: rarr(*) - integer, intent(in) :: n1, n2 - character(len=*), intent(in) :: name - - write (*,*) 'prinrl1 not implemented yet' -end subroutine - -subroutine prinin( iarr, n1, name) - integer, intent(in) :: iarr(*) - integer, intent(in) :: n1 - character(len=*), intent(in) :: name - - write (*,*) 'prinin not implemented yet' -end subroutine - -subroutine prinin1( iarr, n1, n2, name) - integer, intent(in) :: iarr(*) - integer, intent(in) :: n1, n2 - character(len=*), intent(in) :: name - - write (*,*) 'prinin1 not implemented yet' -end subroutine - -subroutine eralloc ( ierror, numel, name) - integer, intent(in) :: ierror - integer, intent(in) :: numel - character(len=*), intent(in) :: name - - write (*,*) 'eralloc not implemented yet' -end subroutine - -subroutine erdealloc ( ierror, name) - integer, intent(in) :: ierror - character(len=*), intent(in) :: name - - write (*,*) 'erdealloc not implemented yet' -end subroutine - -subroutine printtime(text, time) - character(len=*), intent(in) :: text - double precision, intent(in) :: time - - write (*,*) 'printtime not implemented yet' -end subroutine - -end module \ No newline at end of file diff --git a/extern/sepran/msho01.for b/extern/sepran/msho01.for deleted file mode 100644 index a5c7702c5..000000000 --- a/extern/sepran/msho01.for +++ /dev/null @@ -1,216 +0,0 @@ - subroutine msho01( kbound, nbound, istart, ibuur, coarse, - + coor, npoint, coarsemin, coarsemax, coar, - + ncoar ) -! ====================================================================== -! -! programmer Niek Praagman -! version 4.1 date 29-08-2008 No coarseness 0 allowed -! version 4.0 date 26-01-2005 Extra parameters coar and ncoar -! version 3.0 date 08-03-2003 Extra parameters coarsemin, coarsemax -! version 2.1 date 08-02-2001 Layout -! version 2.0 date 03-02-1994 New norms -! version 1.1 date 07-11-1990 New error message -! version 0.1 date 12-04-1989 -! -! copyright (c) 1989-2008 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Subroutine to check whether the boundary-elements of the area -! considered are correct and to fill in array coarse for each point -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! coarseness -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - - implicit none -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision coarse(*), coor(*), coarsemin, coarsemax, - + coar(3,*) - integer kbound(*), nbound, istart(*), ibuur(*), npoint, ncoar - -! coar i/o array containing coordinates and coarseness of -! special points to be used in later calculations: -! positions of these points are fixed! -! In ths subroutine the coarseness may be changed -! coarse o array for coarsenesses of each point -! coarsemax o Maximum coarseness at the boundary -! coarsemin o Minimum coarseness at the boundary -! coor i coordinate array ( Standard SEPRAN ) -! ibuur o array with neighbours -! istart o array containing the starting addresses of -! the neighbours in ibuur -! kbound i array with boundary elements (lines) -! nbound i number of lines in kbound -! ncoar i Number of internal points in surface -! npoint i number of points already created -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision afstan, afst, xp, yp, coarsemean - integer itotal, i, jknoop, k, i1, i2, no, ni, ntal, ierror - -! afst distance between two points -! afstan sum of distances for point considered -! coarsemean Average coarseness at the boundary -! i loop variable -! i1 node number -! i2 node number -! ierror count for errors -! itotal local length of istart -! jknoop local node number -! k loop variable -! ni address in neighbour array -! no address in neighbour array -! ntal number of neighbours of point considered -! xp x-coordinate -! yp y-coordinate -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Deconcatenate name from string of calling subroutines -! EROPEN Concatenate name to string of calling subroutines -! ERREAL Place real value in error array -! ERRSUB Submit error message -! MSHO02 Place neighbour points in array of neighbours -! MSHO03 Compute Euclidian distance -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! 905 Number of neighbours of a boundary point is other than -! zero or two ! -! ********************************************************************** -! -! PSEUDO CODE -! -! Count all neighbours by running through array KBOUND and check -! the final values -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen( 'msho01' ) - -! --- Initialize coarsemin and coarsemax - - coarsemin = rinfin - coarsemax = -rinfin - -! --- Fill istart - - do i = 1, npoint - istart(i) = 0 - end do - do i = 1, nbound - i1 = kbound(2*i-1) - i2 = kbound(2*i ) - istart(i1) = istart(i1) + 1 - istart(i2) = istart(i2) + 1 - end do - -! --- Check and rearrange - - itotal = 0 - do i = 1, npoint - itotal = itotal + istart(i) - istart(i) = itotal - end do - -! --- Clear and fill array ibuur - - itotal = istart(npoint) - do i = 1, itotal - ibuur(i) = 0 - end do - do i = 1, nbound - i1 = kbound(2*i-1) - i2 = kbound(2*i ) - call msho02( istart, ibuur, i1, i2 ) - call msho02( istart, ibuur, i2, i1 ) - end do - -! --- Check ibuur - - ierror = 0 - no = 0 - do i = 1, npoint - ni = istart(i) - -! --- ntal is number of neighbours - - ntal = ni - no - -! --- check number of neighbours - - if ( ntal==0 .or. ntal==2 ) then - -! --- Right number of neighbours ! - - else - -! --- Error in number of neighbours - - xp = coor(2*i-1) - yp = coor(2*i ) - call erreal( xp, 1 ) - call erreal( yp, 2 ) - call errsub ( 905, 0, 2, 0 ) - ierror = ierror + 1 - end if - afstan = 0d0 - if ( ntal>0 ) then - do k = no + 1, no + ntal - jknoop = ibuur(k) - if ( jknoop>0 ) then - call msho03( i, jknoop, coor, afst ) - afstan = afstan + afst - end if - end do - coarse(i) = afstan / ntal - coarsemin = min(coarsemin,coarse(i)) - coarsemax = max(coarsemax,coarse(i)) - else - coarse(i) = 0 - end if - no = ni - end do - -! --- Fill coarseness in coar in case this has not been filled - - coarsemean = 0.5d0*(coarsemin+coarsemax) - do i = 1, ncoar - if ( coar(3,i)<=1d-6 ) coar(3,i) = coarsemean - end do ! i = 1, ncoar - - call erclos( 'msho01' ) - end diff --git a/extern/sepran/msho02.for b/extern/sepran/msho02.for deleted file mode 100644 index deee4b01f..000000000 --- a/extern/sepran/msho02.for +++ /dev/null @@ -1,135 +0,0 @@ - subroutine msho02( istart, ibuur, i, j) -! ====================================================================== -! -! programmer Niek Praagman -! version 2.1 date 17-08-1997 Check coincidence of double -! Plaxis lines -! version 2.0 date 03-02-1994 New norms -! version 1.0 date 12-04-1989 -! -! -! -! copyright (c) 1989-1997 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard or soft copy granted only by written license obtained -! from "ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system (e.g. , in memory, disk or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! -! ********************************************************************** -! -! DESCRIPTION -! -! Subroutine to fill array of neighbour points -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! neighbour -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - use mshdummymethods - - implicit none - integer istart(*), ibuur(*), i, j - -! i i first node of segment to be considered -! ibuur o neighbour array -! istart i array with startaddresses for neighbours of -! each point -! j i second node of line to be considered -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer ist, kn, ien, ib - -! ib node number of neighbour -! ien end address of neighbours in array IBUUR -! ist starting address of neighbours in array IBUUR -! kn loop variable -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Deconcatenate name from string of calling subroutines -! EROPEN Concatenate name to string of calling subroutines -! ERRSUB Submit error message -! INSTOP Stop execution of SEPRAN -! ********************************************************************** -! -! ERROR MESSAGES -! -! 906 Double line in the boundary -! ********************************************************************** -! -! PSEUDO CODE -! -! find starting position for neighbours of point i -! -! run through all points; if node=0 then place new point, else -! if node = j give error message -! -! ********************************************************************** -! -! MODULES USED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen( 'msho02' ) - -! --- Consider line i - j - - if ( i.eq.1 ) then - ist = 1 - else - ist = istart(i-1) + 1 - end if - - ien = istart(i) - - do kn = ist, ien - - ib = ibuur(kn) - - if ( ib.eq.0 ) then - - ibuur(kn) = j - -! --- Ready, point has been placed - - goto 1000 - - else if ( ib.eq.j ) then - -! --- Double line found, do nothing more - - go to 1000 - - end if - - end do - -1000 call erclos( 'msho02' ) - - end diff --git a/extern/sepran/msho03.for b/extern/sepran/msho03.for deleted file mode 100644 index daad91209..000000000 --- a/extern/sepran/msho03.for +++ /dev/null @@ -1,88 +0,0 @@ - subroutine msho03( i, j, coor, afst) - -! ======================================================================= -! -! -! -! programmer niek praagman -! -! version 2.0 date 03-02-1994 New norms -! version 1.0 date 12-04-1989 -! -! -! -! copyright (c) 1989-1994 "ingenieursbureau sepra" -! permission to copy or distribute this software or documentation -! in hard or soft copy granted only by written license obtained -! from "ingenieursbureau sepra". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system (e.g. , in memory, disk or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! -! *********************************************************************** -! -! DESCRIPTION -! -! Subroutine to compute the Euclidian distance of two nodes -! -! *********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! distance -! -! *********************************************************************** -! -! -! INPUT / OUTPUT PARAMETERS -! - implicit none - double precision afst, coor(2,*) - integer i, j - -! afst o Euclidian distance -! coor i coordinate array ( Standard SEPRAN ) -! i i first node to be considered -! j i second node to be considered -! -! *********************************************************************** -! -! COMMON BLOCKS -! -! *********************************************************************** -! -! LOCAL PARAMETERS -! - double precision dx, dy - -! dx difference in x-coordinates of i and j -! dy difference in y-coordinates of i and j -! -! *********************************************************************** -! -! SUBROUTINES CALLED -! -! *********************************************************************** -! -! ERROR MESSAGES -! -! *********************************************************************** -! -! METHOD -! -! trivial -! -! ======================================================================= - -! Compute distance - - dx = coor( 1,i ) - coor( 1,j ) - dy = coor( 2,i ) - coor( 2,j ) - - afst = sqrt( dx*dx + dy*dy ) - - end diff --git a/extern/sepran/msho04.for b/extern/sepran/msho04.for deleted file mode 100644 index c4d64e437..000000000 --- a/extern/sepran/msho04.for +++ /dev/null @@ -1,112 +0,0 @@ - subroutine msho04 ( coor, npoint, xmin, xmax, ymin, ymax ) -! ====================================================================== -! -! programmer niek praagman -! version 3.0 date 11-02-2005 New for min and max determination -! version 2.0 date 03-02-1994 New norms -! version 1.0 date 12-04-1989 -! -! copyright (c) 1989-2005 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Subroutine to determine extreme values of region considered -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! extreme -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpr' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision coor(2,*), xmin, xmax, ymin, ymax - integer npoint - -! coor i coordinate array ( Standard SEPRAN ) -! npoint i number of points in coor -! xmax o max x-coordinate -! xmin o min x-coordinate -! ymax o max y-coordinate -! ymin o min y-coordinate -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer i - double precision x, y - -! i loop variable -! x x-coordinate -! y y-coordinate -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Run through all points and compare with temporary extreme -! values; if necessary replace values by better new extremes -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Set starting values - - xmax = -rinfin - ymax = -rinfin - - xmin = -xmax - ymin = -ymax - -! --- Run through all npoint points and compute - - do i = 1, npoint - - x = coor( 1,i ) - y = coor( 2,i ) - - xmin = min( xmin, x) - xmax = max( xmax, x) - ymin = min( ymin, y) - ymax = max( ymax, y) - - end do - - end diff --git a/extern/sepran/msho05.for b/extern/sepran/msho05.for deleted file mode 100644 index 39c495d3b..000000000 --- a/extern/sepran/msho05.for +++ /dev/null @@ -1,105 +0,0 @@ - subroutine msho05 ( dist, npoint, dismin, dismax ) -! ====================================================================== -! -! programmer niek praagman -! version 3.0 date 11-02-2005 Update min, max determination -! version 2.0 date 03-02-1994 New norms -! version 1.1 date 04-01-1990 Quadratic case added -! version 1.1 date 12-04-1989 -! -! copyright (c) 1989-2005 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Subroutine to determine the extreme coarsenesses of the points on -! the boundary of the area given -! ********************************************************************** -! -! KEYWORDS -! -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpr' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision dist(*), dismin, dismax - integer npoint - -! dismax o largest distance -! dismin o smallest distance -! dist i array containing the representative distances -! for the surface-points -! npoint i number of points in boundary elements -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision dis, eps - integer i - -! dis coarseness of node considered -! eps accuracy -! i loop variable -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Compute extreme coarseness values -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - eps = 10 * epsmac - - dismin = rinfin - dismax = -rinfin - - do i = 1, npoint - - dis = dist(i) - - if ( dis>eps ) then - - dismin = min( dismin, dis) - dismax = max( dismax, dis) - - end if - - end do - - end diff --git a/extern/sepran/msho06.for b/extern/sepran/msho06.for deleted file mode 100644 index 4d995c2f3..000000000 --- a/extern/sepran/msho06.for +++ /dev/null @@ -1,608 +0,0 @@ - subroutine msho06( npoint, coor , dist , xstart, ystart, - + nx, ny, icube , chelp , cube , jcube , - + kbound, nbound, coar , ncoar , ncurvs, - + curves, cocurvs ) -! ====================================================================== -! -! programmer niek praagman -! version 4.1 date 07-01-2011 Tuning improved again -! version 4.0 date 10-11-2009 New tuning of several parameters -! version 3.4 date 30-06-2009 other values for xstart and ystart -! version 3.3 date 10-03-2009 Use smoothing of and do not enlarge -! coarseness finally -! version 3.2 date 28-08-2008 Use also nodes of internal curves -! version 3.1 date 02-06-2008 Smooth interpolation coarseness of -! cubes (quadrilaterals) -! version 3.0 date 11-01-2005 Extra coarseness points, different -! computation coarsenesses blocks -! version 2.1 date 20-09-2004 Correction upper bound loop -! version 2.0 date 03-02-1994 New norms -! version 1.0 date 13-04-1989 -! -! copyright (c) 1989-2011 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Subroutine to determine for each standard quadrilateral the coarse- -! ness and for all the boundary points in which quadrilateral they are -! situated. -! Also the type of each quadrilateral is determined. -! At the end of the routine: -! 0 : no points in common with boundary lines -! 1 : belongs partially to inside part -! 2 : belongs totally to inside part -! Determine (if specified) special inside coarsness points -! ********************************************************************** -! -! KEYWORDS -! -! mesh -! mesh_generation -! 2d -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpr' -! include 'SPcommon/cmcdpi' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer npoint, nx, ny, icube(npoint), jcube(*), ncoar, ncurvs, - + nbound, curves(ncurvs), kbound(2,nbound) - double precision coor(2,*), dist, xstart, ystart, chelp(*), - + cube(nx*ny) , coar(3,ncoar), cocurvs(2,*) - -! chelp i array with coarsenesses of each point -! coar i array with x,y coordinates points and their -! coarseness -! cocurvs i array with coordinates internal lines -! coor i coordinate array -! cube i array with coarsenesses of each quadrilateral -! curves i array with number of nodes for each internal curve -! dist i mean distance of two neighbour points in -! the contour -! icube i array with for each node quadrilateral that node -! belongs to -! jcube i array with indication whether quadrilateral is -! completely outside, completely inside or a -! boundary quadrilateral -! kbound i array with boundary pieces -! nbound i number of boundary pieces -! ncoar i number of extra coarseness points -! ncurvs i number of internal curves -! npoint i number of points in line elements of contour -! nx i number of quadrilaterals in x-direction -! ny i number of quadrilaterals in y-direction -! considered -! xstart i smallest x-coordinate of enveloping quadrilateral -! ystart i smallest y-coordinate of enveloping quadrilateral -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision afst, eps, xp, yp, coarse, coxmin, coxmax, - + coymin, coymax, cgem, alpha, deel, cox, coy, coa, - + val1, val2, val3, val4, valmax, valmin - integer i, i1, i2, j, ik, kub, n1, n1i1, n1i2, n1min, n1max, - + n2, n2i1, n2i2, n2min, n2max, - + nc, ntal, nrkube, nnodes, - + ikxmin, ikxmax, ikymin, ikymax, jblok - logical debug - -! afst local distance between sequential nodes -! alpha helpvalue for interpolation -! cgem helpvalue to store mean value -! coa smallest coarseness value point -! coarse coarseness of points resp cube -! cox interpolation value coarseness x-direction -! coxmax ending coarseness x-direction -! coxmin starting coarseness x-direction -! coy interpolation value coarseness y-direction -! coymax ending coarseness y-direction -! coymin starting coarseness y-direction -! debug indicator for debugging -! deel check variable to see in which direction values -! have been used -! eps accuracy -! i loop variable -! ik loop variable -! ikxmax maximum value where x-line stops -! ikxmin minimum value where x-line starts -! ikymax maximum value where x-line stops -! ikymin see ikxmin, now for y -! j loop variable -! jblok help value for block -! kub help for starting address in loop -! n1 help variable to determine ref number of node -! n2 help variable to determine reference number of node -! nc reference number -! nnodes number of nodes in internal lines -! nrkube cube number -! ntal number of steps -! val1 coarseness value in cube 1 -! val2 coarseness value in cube 2 -! val3 coarseness value in cube 3 -! val4 coarseness value in cube 4 -! valmax max value surrounding coarsenesses -! valmin min value surrounding coarsenesses -! xp x-coordinate -! yp y-coordinate -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Run through all boundary points and determine the number of the -! quadrilateral point belongs to -! Run through all quadrilaterals and check for each quadrilateral -! whether a coarseness-value is given -! Determine for all empty quadrilaterals which are inside the area -! also a value for the coarseness by interpolation -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Set debug - debug = .false. - - eps = 10 * epsmac - - coa = rinfin - -! --- Determine for all boundary points the cube-numbers - do i = 1, npoint - - xp = coor( 1,i ) - yp = coor( 2,i ) - -! --- Find number of quadrilateral - - n1 = int ( (xp-xstart)/dist ) - n2 = int ( (yp-ystart)/dist ) - -! --- Determine smallest coarseness value - - if ( chelp(i)>eps .and. chelp(i)eps ) then - nc = icube(ik) - if ( nc==i ) then - ntal = ntal + 1 - coarse = coarse + chelp(ik) - end if - end if - end do - if ( ntal>0 ) then - coarse = coarse / ntal - cube(i) = coarse - jcube(i) = 1 - end if - end do - - if ( debug ) then - write(irefwr,*) 'Check: cubes and cubevalues, dist =',dist - do j=1, ny - yp = ystart + (j-0.5)*dist - do i=1, nx - nc = i + (j-1)*nx - xp = xstart + (i-0.5) * dist - write(irefwr,*) 'Cube, i=',i,'j= ',j,'nc =',nc - write(irefwr,*) 'Center of cube',xp,yp,'coarse',cube(nc) - end do - end do - end if - -! --- Fill empty places along boundary contour: - do i=1, nbound - - i1 = kbound(1,i) - i2 = kbound(2,i) - - cgem = ( chelp(i1)+chelp(i2) ) / 2d0 - - xp = coor(1,i1) - yp = coor(2,i1) - - n1i1 = int( (xp-xstart) / dist ) - n2i1 = int( (yp-ystart) / dist ) - - xp = coor(1,i2) - yp = coor(2,i2) - - n1i2 = int( (xp-xstart) / dist ) - n2i2 = int( (yp-ystart) / dist ) - - n1min = min( n1i1, n1i2 ) - n1max = max( n1i1, n1i2 ) - - n2min = min( n2i1, n2i2 ) - n2max = max( n2i1, n2i2 ) - - do n1 = n1min, n1max - do n2 = n2min, n2max - - nc = 1 + n1 + n2 * nx - - if ( cube(nc)0 ) then - - nnodes = 0 - - do i=1, ncurvs -! --- Run through line: - - do j= nnodes + 1, nnodes + curves(i) - 1 -! --- Determine start and endpoint - - val1 = cocurvs(1,j+1) - cocurvs(1,j) - val2 = cocurvs(2,j+1) - cocurvs(2,j) - - afst = sqrt(val1*val1+val2*val2) - - xp = ( cocurvs(1,j+1) + cocurvs(1,j) ) / 2d0 - yp = ( cocurvs(2,j+1) + cocurvs(2,j) ) / 2d0 - - n1 = int ( (xp-xstart)/dist ) - n2 = int ( (yp-ystart)/dist ) - -! --- This point belongs to quadrilateral with number - nc = 1 + n1 + n2*nx - -! --- Set values of coarseness and type - if ( jcube(nc)==0 ) then - cube (nc) = afst - jcube(nc) = 1 - else if ( jcube(nc)>0 ) then - cube(nc) = ( cube(nc) + afst ) /2d0 - end if - end do - nnodes = nnodes + curves(i) - end do - end if - - if ( debug ) then - write(irefwr,*) 'Second cube-test' - do i=1, nx * ny - write(irefwr,*) i,jcube(i),cube(i) - end do - end if - -! --- Place extra coarse values for internal points: - do i = 1, ncoar - - xp = coar( 1, i ) - yp = coar( 2, i ) - - n1 = int ( (xp-xstart)/dist ) - n2 = int ( (yp-ystart)/dist ) - -! --- This point belongs to quadrilateral with number - nc = 1 + n1 + n2*nx - -! --- Set values of coarseness and type - cube (nc) = coar( 3, i ) - jcube(nc) = 1 - - end do - -! --- All prescribed cubes have now indication: jcube(nc) == 1 - if ( debug ) then - write(irefwr,*) 'third cube-test, nx=',nx,'ny=',ny - do i=1, nx * ny - write(irefwr,*) i,jcube(i),cube(i) - end do - end if - -! --- Determine for all empty quadrilaterals which are inside the area -! also a value for the coarseness - do i = 1, nx - do j = 1, ny - - nrkube = i + (j-1)*nx - - if ( jcube(nrkube)==0 .and. cube(nrkube)0 ) then -! --- Exponential: - alpha = (coxmax/coxmin)**(1d0/(ikxmax-ikxmin)) - cox = coxmin*(alpha **(1d0*(nrkube-ikxmin))) - else -! --- Linear: - alpha = (nrkube - ikxmin)*(1D0/(ikxmax-ikxmin)) - cox = coxmin + alpha * (coxmax-coxmin) - end if - deel = deel + 1d0 - cube(nrkube) = cox - end if - - jblok = ikymax * ikymin - - if ( jblok/=0 ) then -! --- Make choice (exponential or linear) - if ( jblok>0 ) then -! --- Exponential: - alpha = (coymax/coymin)**(1d0/(1d0*(ikymax-ikymin)/nx)) - coy = coymin*(alpha **(1d0*(nrkube-ikymin)/nx)) - else -! --- Linear: - alpha = (nrkube - ikymin)*(1D0/(ikymax-ikymin)) - coy = coymin + alpha * (coymax-coymin) - end if - deel = deel + 1d0 - cube(nrkube) = (cube(nrkube) + coy) / deel - end if - -! --- Set type of this node: - if ( deel>0.5d0 ) jcube(nrkube) = 2 - - end if - end do - end do - - if ( debug ) then - do i = 1, nx - do j = 1, ny - nrkube = i + (j-1)*nx - write(irefwr,*) 'Cube ',nrkube,' i= ',i,'j= ',j - write(irefwr,*) 'type',jcube(nrkube),'value ',cube(nrkube) - end do - end do - end if - -! --- Fill all quadrilaterals with a minimum value if no value -! was found - valmin = rinfin - valmax = 0d0 - -! --- Determine smallest and largest cubecoarseness value - do i = 1, nx * ny - if ( cube(i)>eps .and. cube(i)eps .and. cube(i)>valmax ) valmax = cube(i) - end do - - coa = ( valmax + 3 * valmin ) / 4d0 -! --- Set value coa in all "empty" cubes - do i = 1, nx * ny - if ( cube(i)2 .and. ny>2 .and. 0>1 ) then - - do ik = 1, 5 - -! --- 5 times smoothing should be enough to get "smooth" values - - do i = nx-1, 2, -1 - do j = ny-1, 2, -1 - - nrkube = i + (j-1)*nx - - if ( jcube(nrkube)==2 ) then - -! --- Internal cube: - - val1 = cube(nrkube-nx) - val2 = cube(nrkube- 1) - val3 = cube(nrkube+ 1) - val4 = cube(nrkube+nx) - - valmin = min( val1, val2, val3, val4 ) - valmax = max( val1, val2, val3, val4 ) - - if (valmincube(nrkube)) then - -! --- Adjust value: - - cube(nrkube)= (2*valmin+val1+val2+val3+val4)/6d0 - end if - - end if - - end do - end do - - end do - - end if - - if ( debug ) then - write(irefwr,*) 'Fifth cube-test' - do i=1, nx * ny - write(irefwr,*) i,jcube(i),cube(i) - end do - end if - -! --- Adjust values (not too large differences in neighbouring -! cubes) - - ik = 1 - - do while ( ik==1 .and. nx>2 .and. ny>2 ) - - ik = 0 - - do i = nx-1, 2, -1 - do j = ny-1, 2, -1 - - nrkube = i + (j-1)*nx - - if ( jcube(nrkube)==2 ) then - -! --- Internal cube: - - val1 = cube(nrkube-nx) - val2 = cube(nrkube- 1) - val3 = cube(nrkube+ 1) - val4 = cube(nrkube+nx) - - valmin = min( val1, val2, val3, val4 ) - - if ( cube(nrkube)>2.75d0*valmin ) then - -! --- Adjust value: - - cube(nrkube)=2.75d0*valmin - ik = 1 - end if - - end if - - end do - end do - - end do - -! --- Check in case of debugging - - if ( debug ) then - write(irefwr,*) 'Values nx = ',nx,' ny = ',ny - write(irefwr,*) 'dist = ',dist - do j = 1, ny - do i = 1, nx - - nrkube = i + (j-1)*nx - write(irefwr,*) - + nrkube,'type',jcube(nrkube),'value ',cube(nrkube) - end do - end do - write(irefwr,*) 'End routine msho06' - end if - - end diff --git a/extern/sepran/msho07.for b/extern/sepran/msho07.for deleted file mode 100644 index 4721be71a..000000000 --- a/extern/sepran/msho07.for +++ /dev/null @@ -1,145 +0,0 @@ - subroutine msho07 ( xcub, ycub, xmini, coor, kbound, nbound, ja ) -! ====================================================================== -! -! programmer niek praagman -! version 2.2 date 09-01-2008 Replace mshg03 by msho75 -! version 2.1 date 26-01-2005 Layout -! version 2.0 date 03-04-1994 new norms -! version 1.1 date 10-10-1990 msho23 replaced by mshg03 -! version 1.0 date 13-04-1989 -! -! copyright (c) 1989-2008 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Subroutine to determine whether point (xcub,ycub) belongs to -! the region given by kbound. -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! ********************************************************************** -! -! MODULES USED -! - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision xcub, ycub, xmini, coor(2,*) - integer kbound(*), nbound, ja - -! coor i coordinate array -! ja o output parameter -! if point belongs to area ( ja = 1 ) -! else ( ja = 0 ) -! kbound i boundary element array -! nbound i number of boundary elements -! xcub i x-coordinate of point considered -! xmini i smallest x-coordinate of all nodes -! ycub i y-coordinate of point considered -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision xleft, yleft, xmin, ymin, ymax, x1, y1, x2, y2 - integer i, isnij, ih, i1, i2 - -! i loop variable -! i1 first node boundary segment -! i2 second node boundary segment -! ih help indicator for crossing point -! isnij number of crossings with boundary segments -! x1 x-coordinate of node i1 -! x2 x-coordinate of node i2 -! xleft reference x-coordinate (far away) -! xmin min value of x-values of boundary line -! y1 y-coordinate of node i1 -! y2 y-coordinate of node i2 -! yleft reference y-coordinate -! ymax max value of y-values of boundary line -! ymin min value of y-values of boundary line -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! MSHO75 Check whether two line segments have a point in common -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Suppose that a line is drawn from point (xcub,ycub) to reference -! point (xleft,yleft). Count all crossings of this line with boundary -! lines (i1,i2) from array KBOUND. If the number of crossings is odd -! than point (xcub,ycub) belongs to area given by KBOUND. -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - xleft = xmini - 10d0 - yleft = ycub - - isnij = 0 - ja = 0 - - do i = 1, nbound - - i1 = kbound(2*i-1) - i2 = kbound(2*i ) - - x1 = coor( 1,i1 ) - y1 = coor( 2,i1 ) - - x2 = coor( 1,i2 ) - y2 = coor( 2,i2 ) - - xmin = min(x1,x2) - - ymin = min(y1,y2) - ymax = max(y1,y2) - - if ( xcubymax ) goto 100 - -! --- Potential point - - call msho75( x1, y1, x2, y2, xleft, yleft, xcub, ycub, ih ) - - if ( ih==1 ) goto 100 - -! --- Real intersection point - - isnij = isnij + 1 - -100 end do - - if ( (isnij - (isnij/2) * 2)/=0 ) ja = 1 - - end diff --git a/extern/sepran/msho08.for b/extern/sepran/msho08.for deleted file mode 100644 index b26a77e6c..000000000 --- a/extern/sepran/msho08.for +++ /dev/null @@ -1,383 +0,0 @@ - subroutine msho08 ( kstapl, kstap, coor, xstart, dismin, - + holeinfo, nholes, check ) -! ====================================================================== -! -! programmer Niek Praagman -! version 5.2 date 24-03-2009 Extra debug facilities -! version 5.1 date 25-11-2008 Check for double lines -! and counterclockwise -! version 5.0 date 17-02-2005 Accuracy improvement -! version 4.0 date 24-02-2003 Extra parameter check -! version 3.0 date 05-04-2002 Extra parameters -! version 2.0 date 14-02-1994 New norms -! version 1.0 date 12-04-1989 -! -! copyright (c) 1989-2009 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Check whether all boundary elements are given in the right direction. -! If not then reverse direction of boundary element. -! If element is double determine direction by sequencing -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! check -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpi' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer kstap, kstapl(*), nholes, holeinfo(2,0:nholes+1) - double precision coor(2,*), xstart, dismin - logical check - -! check i Indicates if this is the first call of msho08, where -! possibly the boundary must be reversed (false) or -! that the call is just for checking (true) -! coor i coordinate array -! dismin i smallest distance in boundary polygon -! holeinfo i Integer array of size 2 x (nholes+2) -! Contains information about holes in surfaces and where -! a new part of the boundary starts -! Pos (1,i-1) contains the local sequence number of the -! first curve of part i provided with a sign -! If the sign is positive the boundary is -! created counter clockwise, otherwise clockwise -! Pos (2,i-1) contains the local sequence number of the -! first node of of part i -! Pos (1,nholes+1) contains the number of curves of the -! boundary -! kstap i number of elements in array kstapl -! kstapl i/o array with boundary elements -! nholes i Number of holes in the boundary of a surface -! xstart i smallest x-value of reference quadrangles -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer i, i1, i2, ichange, ih1, ih2, j, j1, j2, ja, icount, - + iloop - double precision eps, e1, e2, xn, yn, xm, ym - logical debug - -! debug parameter to indicate whether debug actions need -! to be taken -! e1 first component of unity vector -! e2 second component of unity vector -! eps accuracy parameter -! i loop variable -! i1 first node of boundary line -! i2 second node of boundary line -! ichange indicator whether changings have been made -! icount Counter -! ih1 helpvariable for first node -! ih2 helpvariable for second node -! iloop helpvariable to count -! j loop variable -! j1 helpnode -! j2 helpnode -! ja help indicator -! xm x-coordinate midpoint -! xn x-coordinate extra point -! ym y-coordinate midpoint -! yn y-coordinate extra point -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! ERRINT Put integer in error message -! ERRSUB Error messages -! MSHCHKSTAPL Check the contents of array kstapl -! MSHO07 Check whether point belongs to given area -! MSHO09 Compute midpoint line and the normal vector -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! 1274 internal error -! 2434 Internal error in triangle -! ********************************************************************** -! -! PSEUDO CODE -! -! The check is to consider the nodes i1 and i2 of the boundary element -! together with an extra point which should be in the interior of the -! area given by KBOUND. Here it is assumed that the area is closed. -! Set accuracy (here relative to 1) -! Run through all boundary elements -! Compute midpoint and "inside" pointing unity normal -! Compute point that should be inside -! Check whether point belongs to area -! If point does not belong to area reverse direction -! of boundary element -! Check whether all pieces are simple. If pieces are double check -! the correct direction and adjust eventually. -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen( 'msho08' ) - - debug = .false. - -! --- Set accuracy - - eps = 1d-5 - - icount = 0 - - do i = 1, kstap - - i1 = kstapl( 2*i - 1 ) - i2 = kstapl( 2*i ) - - kstapl(2*kstap+i) = 0 - -! --- Compute midpoint line and normal vector ("counterclockwise") - - call msho09 ( coor, i1, i2, e1, e2, xm, ym ) - -! --- Determine extra point for checking - - xn = xm + eps * e1 * dismin - yn = ym + eps * e2 * dismin - -! --- Check whether point belongs to area - - ja = 0 - - call msho07( xn, yn, xstart, coor, kstapl, kstap, ja ) - -! --- If not inside direction is reversed - - if ( ja==0 ) then - -! --- ja = 0, reverse or give error message - - if ( check ) then - -! --- check is true, error - - call errint ( i1, 1 ) - call errint ( i2, 2 ) - call errsub ( 2434, 2, 0, 0 ) - - else - -! --- check is false, start of procedure - - if ( debug) - + write(irefwr,*) 'Interchange',i1,'and',i2 - kstapl( 2*i-1 ) = i2 - kstapl( 2*i ) = i1 - - end if - - end if - - if ( holeinfo(2,icount)==i1 ) then - -! --- New part of boundary found - - if ( ja==0 ) holeinfo(1,icount) = -holeinfo(1,icount) - if ( icount0 ) then - -! --- Piece has a problem with connections: - - if ( debug ) then - write(irefwr,*) 'Piece',i - if ( ih1>0 ) write(*,*) 'No connection',i1 - if ( ih2>0 ) write(*,*) 'No connection',i2 - end if - -! --- Run through all "doubles" and make connection - - do j = 1 , kstap - -! --- Check for all "double" pieces: - - if ( kstapl(2*kstap+j)==1 ) then - -! --- Candidate - - j1 = kstapl(2*j-1) - j2 = kstapl(2*j ) - - if ( j1==i2 .and. ih2>0 .or. - + j2==i1 .and. ih1>0 ) then - -! --- "Double" piece is connected - - kstapl(2 * kstap+j) = 0 - ih1 = 0 - ih2 = 0 - - else if ( j1==i1 .and. ih1>0 .or. - + j2==i2 .and. ih2>0 ) then - -! --- "Double" piece is connected, but direction has -! to be changed: - - kstapl(2 * kstap+j) = 0 - kstapl(2 * j - 1 ) = j2 - kstapl(2 * j ) = j1 - - ichange = 1 - - ih1 = 0 - ih2 = 0 - - end if - - end if - - end do - - end if - - end if - - end do - - if ( debug .and. ih1+ih2>0 ) then - write(irefwr,*) 'element',i1,i2,' has no connection ' - end if - - iloop = iloop + 1 - - if ( iloop>1000 ) then - call errsub (1274, 0, 0, 0 ) - go to 1000 - end if - - end do - - call mshchkstapl( kstapl, kstap, 'Final check in msho08') - -1000 call erclos( 'msho08' ) - - if ( debug ) then - write(irefwr,*) 'kstapl at the end of msho08' - do i=1, kstap - write(irefwr,*) i,kstapl(2*i-1),kstapl(2*i) - end do - end if - - end diff --git a/extern/sepran/msho09.for b/extern/sepran/msho09.for deleted file mode 100644 index b98c28551..000000000 --- a/extern/sepran/msho09.for +++ /dev/null @@ -1,109 +0,0 @@ - subroutine msho09( coor, i, j, e1, e2, xm, ym ) -! ====================================================================== -! -! programmer niek praagman -! version 2.0 date 14-02-1994 New norms -! version 1.0 date 13-04-1989 -! -! copyright (c) 1989-2009 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Determine the vector ( e1, e2 ) which is perpendicular to the line -! of the points i-j. Also point (xm,ym) in the middle of line i-j is -! computed -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! perpendicular -! ********************************************************************** -! -! MODULES USED -! - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer i, j - double precision coor(2,*), e1, e2, xm, ym - -! coor i coordinate array -! e1 o first coordinate vector perpendicular to line -! e2 o second coordinate vector perpendicular to line -! i i first node of line -! j i second node of line -! xm o first coordinate midpoint of line -! ym o second coordinate midpoint of line -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision xi, yi, xj, yj, eleng - -! eleng normalisation parameter -! xi x-coordinate point i -! xj x-coordinate point j -! yi y-coordinate point i -! yj y-coordinate point j -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Determine coordinates two line endpoints -! Compute normalizing length and the unit vector -! Compute mid point -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Determine coordinates - - xi = coor( 1, i ) - yi = coor( 2, i ) - xj = coor( 1, j ) - yj = coor( 2, j ) - e1 = - ( yj - yi ) - e2 = ( xj - xi ) - -! --- Normalize - - eleng = sqrt( e1*e1 + e2*e2 ) - e1 = e1 / eleng - e2 = e2 / eleng - -! --- Mid point - - xm = 0.5000001234 * xi + 0.4999998766 * xj - ym = 0.5000001234 * yi + 0.4999998766 * yj - end diff --git a/extern/sepran/msho10.for b/extern/sepran/msho10.for deleted file mode 100644 index c057f9142..000000000 --- a/extern/sepran/msho10.for +++ /dev/null @@ -1,182 +0,0 @@ - subroutine msho10 ( kelem, nelem, i1, i2, jpn, kstapl, - + kstap, itri ) -! ====================================================================== -! -! programmer niek praagman -! version 2.1 date 21-02-2003 Layout -! version 2.0 date 14-02-1994 New norms -! version 1.0 date 13-04-1989 -! -! copyright (c) 1989-2003 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Fill new element in array KELEM and adjust arrays KSTAPL and ITRI -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! element -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpi' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer kelem(3,*), nelem, i1, i2, jpn, kstapl(2,*), kstap, - + itri(*) - -! i1 i first node of new element -! i2 i second node of new element -! itri i,o array indicating whether a node n is on the boundary -! itri(n) = 2 or not : itri(n) = 0 -! jpn i third node of element just created -! kelem i,o element array -! kstap i,o number of elements in kstapl -! kstapl i,o array containing the actual boundary -! nelem i,o actual number of elements -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer idrie, ieen, itwe, ks, ia, ib - logical debug - -! debug If true debug statements are carried out otherwise -! they are not -! ia node of boundary element -! ib node of boundary element -! idrie countvariable for new number of elements in kstapl -! ieen check for line i2 - jpn -! itwe check for line jpn - i1 -! ks loop variable -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! PRININ1 print 2d integer array -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Fill new created element in in array kelem -! Adjust kstapl and itri -! Run through all elements of kstapl -! if element is one of the sides of the new element : cancel -! Check which elements of the three sides have already been cancelled -! If sides are left place them in kstapl -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen ( 'msho10' ) - debug = .false. - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'Debug information from msho10' - write(irefwr,*) 'nelem, i1, i2, jpn ', nelem, i1, i2, jpn - - end if - -! --- Fill new created element in in array kelem - - nelem = nelem + 1 - kelem( 1, nelem ) = i1 - kelem( 2, nelem ) = i2 - kelem( 3, nelem ) = jpn - -! --- Adjust kstapl and itri - - idrie = 0 - ieen = 1 - itwe = 1 - do ks = 2, kstap - ia = kstapl(1,ks) - ib = kstapl(2,ks) - if ( ia.eq.i2 .and. ib.eq.jpn ) then - ieen = 0 - else if ( ia.eq.jpn .and. ib.eq.i1 ) then - itwe = 0 - else - idrie = idrie + 1 - kstapl(1,idrie) = ia - kstapl(2,idrie) = ib - end if - end do - if ( debug ) - + write(irefwr,*) 'ieen, itwe, idrie ',ieen, itwe, idrie - -! --- Check which elements have already been used - - if ( ieen.eq.1 ) then - idrie = idrie + 1 - kstapl(1,idrie) = jpn - kstapl(2,idrie) = i2 - itri(i2 ) = itri(i2 ) + 1 - itri(jpn) = itri(jpn) + 1 - else - itri(i2 ) = itri(i2 ) - 1 - itri(jpn) = itri(jpn) - 1 - end if - - if ( itwe.eq.1 ) then - idrie = idrie + 1 - kstapl(1,idrie) = i1 - kstapl(2,idrie) = jpn - itri(jpn) = itri(jpn) + 1 - itri(i1 ) = itri(i1 ) + 1 - else - itri(jpn) = itri(jpn) - 1 - itri(i1 ) = itri(i1 ) - 1 - end if - kstap = idrie - - call erclos ( 'msho10' ) - - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'End msho10' - - end if - - end diff --git a/extern/sepran/msho11.for b/extern/sepran/msho11.for deleted file mode 100644 index b26b40855..000000000 --- a/extern/sepran/msho11.for +++ /dev/null @@ -1,142 +0,0 @@ - subroutine msho11 ( i1, i2, i3, coor, angle ) -! ====================================================================== -! -! programmer niek praagman -! version 3.0 date 11-02-2005 Alternative accuracy treatment -! version 2.1 date 28-02-1997 Improvements -! version 2.0 date 14-02-1994 New norms -! version 1.0 date 13-04-1989 -! -! copyright (c) 1989-2005 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Compute the angle between line i1 - i2 and line i2 - i3 using the -! dot product -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! angle -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpr' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer i1, i2, i3 - double precision coor(2,*), angle - -! angle o cosine of angle between lines 1-2 and 2-3 -! coor i coordinate array -! i1 i first node -! i2 i second node -! i3 i third node -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision x1, y1, x2, y2, x3, y3, e1, e2, e3, e4, eleng, - + h1, h2, hnorm - -! e1 first component direction line 3-2 -! e2 second component direction line 3-2 -! e3 first component direction line 1-2 -! e4 second component direction line 1-2 -! eleng scaling parameter -! h1 helpvariable for coincidences -! h2 helpvariable for coincidences -! hnorm norm of helpvariables -! x1 x-coordinate node 1 -! x2 x-coordinate node 2 -! x3 x-coordinate node 3 -! y1 y-coordinate node 1 -! y2 y-coordinate node 2 -! y3 y-coordinate node 3 -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS deconcatenate name subroutine from calling string -! EROPEN concatenate name subroutine to calling string -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen( 'msho11' ) - x1 = coor(1,i1) - y1 = coor(2,i1) - x2 = coor(1,i2) - y2 = coor(2,i2) - x3 = coor(1,i3) - y3 = coor(2,i3) - e1 = x3 - x2 - e2 = y3 - y2 - eleng = sqrt ( e1*e1 + e2*e2 ) - h1 = ( x2 + x3 ) / 2d0 - h2 = ( y2 + y3 ) / 2d0 - hnorm = sqrt( h1*h1 + h2*h2 ) - if ( eleng<1.d2 * epsmac * hnorm ) then - -! --- Points coincide, skip this possibility - - angle = -1.5d0 - goto 1000 - end if - e1 = e1 / eleng - e2 = e2 / eleng - e3 = x1 - x2 - e4 = y1 - y2 - eleng = sqrt ( e3*e3 + e4*e4 ) - h1 = ( x1 + x2 ) / 2d0 - h2 = ( y1 + y2 ) / 2d0 - hnorm = sqrt( h1*h1 + h2*h2 ) - if ( eleng<1.d2 * epsmac * hnorm ) then - -! --- Points coincide, skip this possibility - - angle = -1.5d0 - goto 1000 - end if - e3 = e3 / eleng - e4 = e4 / eleng - angle = e1*e3 + e2*e4 -1000 call erclos( 'msho11' ) - end diff --git a/extern/sepran/msho12.for b/extern/sepran/msho12.for deleted file mode 100644 index 1b44d9cac..000000000 --- a/extern/sepran/msho12.for +++ /dev/null @@ -1,194 +0,0 @@ - subroutine msho12 ( coor, kstapl, kstap, i1, i2, iex1, iex2, - + angle1, angle2 ) -! ====================================================================== -! -! programmer Niek Praagman -! version 3.3 date 14-02-2010 Higher accuracy -! version 3.2 date 26-01-2005 Layout -! version 3.1 date 21-02-2003 Layout -! version 3.0 date 14-02-1994 New norms -! version 2.0 date 01-02-1990 only real neighbours ! -! version 1.0 date 14-04-1989 -! -! copyright (c) 1989-2010 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Determine for line i1 - i2 the other lines where i1 resp i2 are -! nodes off and compute the angles between these lines and the original -! line -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! neighbour -! angle -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpi' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer kstap, kstapl(2,kstap), i1, i2, iex1, iex2 - double precision coor(*), angle1, angle2 - -! angle1 o angle between basis line and iex1 line -! angle2 o angle between basis line and iex2 line -! coor i coordinate array -! i1 i first node segment to be considered -! i2 i second node segment to be considered -! iex1 o node of line adjacent to i1 -! iex2 o node of line adjacent to i2 -! kstap i number of line-elements in kstapl -! kstapl i boundary array -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer ii1, ii2, i - double precision angle, surf - logical debug - -! angle help variable to determine angle -! debug If true debug statements are carried out otherwise -! they are not -! i loop variable -! ii1 node number -! ii2 node number -! surf help variable for determination of surface -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! ERRINT Put integer in error message -! ERRSUB Error messages -! MSHO11 compute angle -! MSHO19 Compute area of triangle -! PRININ1 print 2d integer array -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! 2433 Internal error in triangle -! ********************************************************************** -! -! PSEUDO CODE -! -! trivial -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen ( 'msho12' ) - - debug = .false. - - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'Debug information from msho12' - - end if - - iex1 = 0 - iex2 = 0 - -! --- Initialize angle values - - angle1 = -1.2d0 - angle2 = -1.2d0 - - do i = 1 , kstap - - ii1 = kstapl(1,i) - ii2 = kstapl(2,i) - - if ( i1==ii2 ) then - -! --- Compute surface of area - - call msho19( coor, ii1, i1, i2, surf ) - - if ( surf<=0 ) then - angle = -1.1d0 - else - -! --- Compute angle ii1-i1-i2 - - call msho11( ii1, i1, i2, coor, angle ) - end if - if ( angle>angle1 ) then - iex1 = ii1 - angle1 = angle - end if - end if - - if ( i2==ii1 ) then - -! --- Compute surface of area - - call msho19( coor, i1, i2, ii2, surf ) - if ( surf<=0 ) then - angle = -1.1d0 - else - -! --- Compute angle i1-i2-ii2 - - call msho11( i1, i2, ii2, coor, angle ) - end if - if ( angle>angle2 ) then - iex2 = ii2 - angle2 = angle - end if - end if - end do - - call erclos ( 'msho12' ) - - if ( debug ) write(irefwr,*) 'End msho12' - - if ( iex1==0 .or. iex2==0 ) then - -! --- Problem in msho12 - - call errint ( i1, 1 ) - call errint ( i2, 2 ) - call errint ( iex1, 3 ) - call errint ( iex2, 4 ) - call errsub ( 2433, 4, 0, 0 ) - - end if - - end diff --git a/extern/sepran/msho13.for b/extern/sepran/msho13.for deleted file mode 100644 index 0a2db78a4..000000000 --- a/extern/sepran/msho13.for +++ /dev/null @@ -1,354 +0,0 @@ - subroutine msho13 ( coor, i1, i2, kdrie, kstapl, kstap, xn, yn ) -! ====================================================================== -! -! programmer niek praagman -! version 2.2 date 14-02-2010 Checks adjusted (crossing and double) -! version 2.1 date 27-08-2009 Adjust accuracy for double points -! version 2.0 date 14-02-2005 Update -! version 1.4 date 21-02-2003 Layout -! version 1.3 date 21-02-1997 Adjust for "double" points -! version 1.2 date 16-02-1994 New norms -! version 1.1 date 10-10-1990 msho23 replaced by mshg03 -! version 1.0 date 14-04-1989 -! -! copyright (c) 1989-2010 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Determine whether lines from i1 and i2 to new point (xn,yn) do or -! do not cross boundary lines -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! intersection -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpr' -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer i1, i2, kdrie, kstapl(2,*), kstap - double precision coor(2,*), xn, yn - -! coor i coordinate array -! i1 i node of basis element -! i2 i node of basis element -! kdrie o number of line that lines to new point -! crosses. 0 means no crossing ! -! kstap i number of elements in kstapl -! kstapl i current boundary elements array -! xn i x-coordinate new point -! yn i y-coordinate new point -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision xi1, yi1, xi2, yi2, xmin, xmax, ymin, ymax, - + x1, y1, x2, y2, xmi, xma, ymi, yma, xh, yh, - + xpn1, xpn2, ypn1, ypn2, - + dis1, dis2, eps, h1, h2 - integer i, ii1, ii2, ipn1, ipn2, ih - -! dis1 helpdistance -! dis2 helpdistance -! eps accuracy parameter -! h1 helpvariable for distance -! h2 helpvariable for distance -! i loop variable -! ih help indicator -! ii1 first node of boundary line -! ii2 second node of boundary line -! ipn1 node number -! ipn2 node number -! x1 x-coordinate point ii1 -! x2 x-coordinate point ii2 -! xh x-coordinate helppoint -! xi1 x-coordinate first basis point -! xi2 x-coordinate second basis point -! xma extreme x-value quadrangular envelope boundary line -! xmax extreme x-value quadrangular envelope basis line -! xmi extreme x-value quadrangular envelope boundary line -! xmin extreme x-value quadrangular envelope basis line -! xpn1 x-coordinate point ipn1 -! xpn2 x-coordinate point ipn2 -! y1 y-coordinate point ii1 -! y2 y-coordinate point ii2 -! yh y-coordinate helppoint -! yi1 y-coordinate first basis point -! yi2 y-coordinate second basis point -! yma extreme y-value quadrangular envelope boundary line -! ymax extreme y-value quadrangular envelope basis line -! ymi extreme y-value quadrangular envelope boundary line -! ymin extreme y-value quadrangular envelope basis line -! ypn1 y-coordinate point ipn1 -! ypn2 y-coordinate point ipn2 -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! MSHO75 Check whether two linesegments have an internal point -! in common -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Compute coordinates line nodes -! Determine extreme values of line i1-i2 and new point xn,yn -! Run through all boundary elements ii1-ii2 and check whether -! "new" lines i1-n and i2-n intersect line ii1-ii2. Check also -! whether line midpoint-n intersects line ii1-ii2. -! Return with number of line that is crossing. Check for double -! crossings. If it seems to be a double line leave the routine with -! kdrie = -1. In the other case take the "nearest" line kdrie. -! If result is kdrie = 0 then no intersection has been found -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Check whether new point is allowed - call eropen( 'msho13' ) - - eps = 1d4 * epsmac - - xi1 = coor( 1, i1 ) - yi1 = coor( 2, i1 ) - xi2 = coor( 1, i2 ) - yi2 = coor( 2, i2 ) - -! --- Determine extreme values line i1-i2 and new point - - xmin = min( xi1, xi2, xn ) - xmax = max( xi1, xi2, xn ) - ymin = min( yi1, yi2, yn ) - ymax = max( yi1, yi2, yn ) - - kdrie = 0 - -! --- Run through all boundary elements and check whether lines intersect -! each other - - do i = 2, kstap - - ii1 = kstapl( 1, i ) - ii2 = kstapl( 2, i ) - - x1 = coor( 1, ii1 ) - y1 = coor( 2, ii1 ) - - x2 = coor( 1, ii2 ) - y2 = coor( 2, ii2 ) - - xmi = min(x1,x2) - xma = max(x1,x2) - ymi = min(y1,y2) - yma = max(y1,y2) - - if ( xmi<=xmax .and. - + xma>=xmin .and. - + ymi<=ymax .and. - + yma>=ymin ) then -! --- Potential line i: - -! --- Check for point i1 - if ( i1/=ii1 .and. i1/=ii2 ) then -! --- Check for distance and coincidence of points - - dis1 = abs(xi1-x1)+abs(yi1-y1) - dis2 = abs(xi1-x2)+abs(yi1-y2) - - h1 = abs(xi1)+abs(x1)+abs(yi1)+abs(y1) - h2 = abs(xi1)+abs(x2)+abs(yi1)+abs(y2) - - if ( dis1>eps*h1 .and. dis2>eps*h2 ) then - - call msho75( xi1, yi1, xn, yn, x1, y1, x2, y2, ih ) - - if ( ih==0 ) then - if ( kdrie == 0 ) then -! --- First crossing line: - kdrie = i - else if ( kdrie>0 .and. kdrie/=i ) then -! --- Double crossing: -! -Compute distance to midpoint kdrie - ipn1 = kstapl( 1, kdrie ) - ipn2 = kstapl( 2, kdrie ) - -! -Coordinates midpoint piece kdrie: - xpn1 = (coor(1,ipn1)+coor(1,ipn2))/2d0 - ypn1 = (coor(2,ipn1)+coor(2,ipn2))/2d0 - -! -Coordinates midpoint piece i1 - i2: - xpn2 = (xi1+xi2)/2d0 - ypn2 = (yi1+yi2)/2d0 - - dis1 = (xpn1-xpn2)*(xpn1-xpn2)+ - + (ypn1-ypn2)*(ypn1-ypn2) - -! -Coordinates midpoint piece i: - xpn1 = ( x1 + x2 ) / 2d0 - ypn1 = ( y1 + y2 ) / 2d0 - - dis2 = (xpn1-xpn2)*(xpn1-xpn2)+ - + (ypn1-ypn2)*(ypn1-ypn2) - - if ( dis2<(1d0-eps)*dis1 ) then -! --- Take new one i.e. i: - kdrie = i - else if ( dis2<(1d0+eps)*dis1 ) then -! --- Problems: return - kdrie = -1 - goto 1000 - else -! --- Use old value do not change kdrie - end if - - end if - end if - end if - end if -! --- Check for point i2 - if ( i2/=ii1 .and. i2/=ii2 ) then -! --- Check for distance and coincidence of points - dis1 = abs(xi2-x1)+abs(yi2-y1) - dis2 = abs(xi2-x2)+abs(yi2-y2) -! --- Helpaccuracy: - h1 = abs(xi2)+abs(x1)+abs(yi2)+abs(y1) - h2 = abs(xi2)+abs(x2)+abs(yi2)+abs(y2) -! --- If no coïncidence: - if ( dis1>eps*h1 .and. dis2>eps*h2 ) then - call msho75( xi2, yi2, xn, yn, x1, y1, x2, y2, ih ) - - if ( ih == 0 ) then - if ( kdrie == 0 ) then -! --- First crossing line: - kdrie = i - else if ( kdrie>0 .and. kdrie/=i ) then -! --- Double crossing: -! -Compute distance to midpoint kdrie - ipn1 = kstapl( 1, kdrie ) - ipn2 = kstapl( 2, kdrie ) - -! -Coordinates midpoint piece kdrie: - xpn1 = (coor(1,ipn1)+coor(1,ipn2))/2d0 - ypn1 = (coor(2,ipn1)+coor(2,ipn2))/2d0 - -! -Coordinates midpoint piece i1 - i2: - xpn2 = (xi1+xi2)/2d0 - ypn2 = (yi1+yi2)/2d0 - - dis1 = (xpn1-xpn2)*(xpn1-xpn2)+ - + (ypn1-ypn2)*(ypn1-ypn2) - -! -Coordinates midpoint piece i: - xpn1 = ( x1 + x2 ) / 2d0 - ypn1 = ( y1 + y2 ) / 2d0 - - dis2 = (xpn1-xpn2)*(xpn1-xpn2)+ - + (ypn1-ypn2)*(ypn1-ypn2) - - if ( dis2<(1d0-eps)*dis1 ) then -! --- Take new one i.e. i: - kdrie = i - else if ( dis2<(1d0+eps)*dis1 ) then -! --- Problems: return - kdrie = -1 - goto 1000 - else -! --- Use old value do not change kdrie - end if - end if - end if - end if - end if -! --- Finally check for middle point - xh = ( xi1 + xi2 ) / 2d0 - yh = ( yi1 + yi2 ) / 2d0 - - xh = ( eps * xn + (1d0-eps) * xh ) - yh = ( eps * yn + (1d0-eps) * yh ) - - call msho75(xh,yh,xn,yn,x1,y1,x2,y2,ih) - - if ( ih == 0 ) then - if ( kdrie == 0 ) then -! --- First crossing line: - kdrie = i - else if ( kdrie>0 .and. kdrie/=i ) then -! --- Double crossing: -! -Compute distance to midpoint kdrie - ipn1 = kstapl( 1, kdrie ) - ipn2 = kstapl( 2, kdrie ) - -! -Coordinates midpoint piece kdrie: - xpn1 = (coor(1,ipn1)+coor(1,ipn2))/2d0 - ypn1 = (coor(2,ipn1)+coor(2,ipn2))/2d0 - -! -Coordinates midpoint piece i1 - i2: - xpn2 = (xi1+xi2)/2d0 - ypn2 = (yi1+yi2)/2d0 - - dis1 = (xpn1-xpn2)*(xpn1-xpn2)+ - + (ypn1-ypn2)*(ypn1-ypn2) - -! -Coordinates midpoint piece i: - xpn1 = ( x1 + x2 ) / 2d0 - ypn1 = ( y1 + y2 ) / 2d0 - - dis2 = (xpn1-xpn2)*(xpn1-xpn2)+ - + (ypn1-ypn2)*(ypn1-ypn2) - - if ( dis2<(1d0-eps)*dis1 ) then -! --- Take new one i.e. i: - kdrie = i - else if ( dis2<(1d0+eps)*dis1 ) then -! --- Problems: return - kdrie = -1 - goto 1000 - else -! --- Use old value do not change kdrie - end if - - end if - end if - end if - end do - -! --- Checking is ready -1000 call erclos( 'msho13' ) - - end diff --git a/extern/sepran/msho14.for b/extern/sepran/msho14.for deleted file mode 100644 index 1924e8662..000000000 --- a/extern/sepran/msho14.for +++ /dev/null @@ -1,113 +0,0 @@ - subroutine msho14 ( coor, jpn, npoint, itri, i1, i2, - + xn, yn, dista ) -! ====================================================================== -! -! programmer niek praagman -! version 3.0 date 14-02-2005 Update -! version 2.0 date 16-02-1994 New norms -! version 1.0 date 14-04-1989 -! -! copyright (c) 1989-2005 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Determine nearest boundary point to proposed new point. -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! neighbour -! distance -! ********************************************************************** -! -! MODULES USED -! - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer i1, i2, itri(*), jpn, npoint - double precision coor(2,*), xn, yn, dista - -! coor i coordinate array -! dista o distance new point to boundary point -! i1 i first node basis line -! i2 i second node basis line -! itri i array with for each point number of times -! that point appears in present boundary -! jpn o node number of nearest point -! npoint i actual number of points in mesh -! xn i x-coordinate new point -! yn i y-coordinate new point -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer ih - double precision xi, yi, dx, dy, dist - -! dist Euclidian distance -! dx first component distance vector -! dy second component distance vector -! ih loop variable -! xi x-coordinate boundary point -! yi y-coordinate boundary point -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Run through all points -! If point in boundary and not one of the basis points then -! compute distance new point - boundary point -! if distance smaller then reference value adjust -! reference value and node number -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - jpn = 0 - do ih = 1 , npoint - if ( ih/=i1 .and. ih/=i2 .and. itri(ih)/=0 ) then - xi = coor( 1, ih ) - yi = coor( 2, ih ) - dx = xn - xi - dy = yn - yi - dist = sqrt ( dx*dx + dy*dy ) - if ( distleng ) then - -! --- Declared length too small - - call errsub ( 903, 0, 0, 0 ) - end if - -! --- Clear ibuurp - - do i = 1, isum - ibuurp(i) = 0 - end do - leng = isum - -! --- Fill array ibuurp - - do i = 1 , nelem - is = 3*(i-1) - i1 = kelem(is+1) - i2 = kelem(is+2) - i3 = kelem(is+3) - call msho17(ibuurp,iwork,i1,i2) - call msho17(ibuurp,iwork,i1,i3) - call msho17(ibuurp,iwork,i2,i1) - call msho17(ibuurp,iwork,i2,i3) - call msho17(ibuurp,iwork,i3,i1) - call msho17(ibuurp,iwork,i3,i2) - end do - call erclos( 'msho16' ) - end diff --git a/extern/sepran/msho17.for b/extern/sepran/msho17.for deleted file mode 100644 index 5cec4fe5a..000000000 --- a/extern/sepran/msho17.for +++ /dev/null @@ -1,96 +0,0 @@ - subroutine msho17( ibuurp, iwork, ih, ij ) - -! ======================================================================= -! -! -! programmer niek praagman -! -! version 2.0 date 21-02-1994 New norms -! version 1.0 date 14-04-1989 -! -! -! -! copyright (c) 1989-1994 "ingenieursbureau sepra" -! permission to copy or distribute this software or documentation -! in hard or soft copy granted only by written license obtained -! from "ingenieursbureau sepra". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system (e.g. , in memory, disk or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! -! *********************************************************************** -! -! DESCRIPTION -! -! Fill nodal point number ij in right position of array ibuurp -! -! *********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! neighbour -! *********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - implicit none - integer ibuurp(*),iwork(*),ih,ij - -! ibuurp i,o array containing the nodal point numbers of -! the neighbours -! ih i nodal point number to be considered -! ij i nodal point number of neighbour -! iwork i pointer array -! -! *********************************************************************** -! -! COMMON BLOCKS -! -! *********************************************************************** -! -! LOCAL PARAMETERS -! - integer jstart -! -! jstart startaddress for present point ih in array IBUURP -! -! *********************************************************************** -! -! SUBROUTINES CALLED -! -! *********************************************************************** -! -! ERROR MESSAGES -! -! *********************************************************************** -! -! PSEUDO CODE -! -! trivial -! -! ======================================================================= - - jstart=0 - - if ( ih.ne.1 ) jstart = iwork(ih-1) - -100 jstart = jstart + 1 - -! If point is already placed then return - - if ( ibuurp ( jstart ).eq.ij ) goto 200 - -! If not yet last neighbour, then check next - - if ( ibuurp ( jstart ).ne. 0 ) goto 100 - -! Position is empty, place new neighbour - - ibuurp ( jstart ) = ij - -200 continue - - end diff --git a/extern/sepran/msho18.for b/extern/sepran/msho18.for deleted file mode 100644 index 2c3d29721..000000000 --- a/extern/sepran/msho18.for +++ /dev/null @@ -1,284 +0,0 @@ - subroutine msho18 ( kelem, nelem, coor, npoint, nipnt, iwork, - + ibuurp, coars ) -! ====================================================================== -! -! programmer niek praagman -! version 2.4 date 07-12-2010 New method Laplace -! version 2.3 date 27-08-2009 Enlarge stopvalue of repositioning -! version 2.2 date 24-03-2009 Check eventually correctness Laplacian -! repositioning (Plaxis) -! -! copyright (c) 1989-2010 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Perform a Laplacian repositioning of the nodes -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! repositioning -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpi' -! include 'SPcommon/cmcdpr' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision coor(2,*), coars - integer nelem, npoint, nipnt, iwork(*), ibuurp(*), kelem(3,nelem) - -! coars i coarseness, reference length -! coor i/o coordinate array -! ibuurp i array with nodal point numbers of neighbour points -! for each point -! iwork i helparray with startaddresses of IBUURP -! kelem i element array -! nelem i number of elements in mesh -! nipnt i number of boundary points -! npoint i total number of points in the mesh -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision afstnd, xz, yz, xh, yh, xn, yn, af, - + surf, surf1, surfre - integer jr, ikn, jstart, jeind, nbuur, i, jkn, - + iallow, i1, i2, i3 - logical debug, finished - -! af extreme value for distances -! afstnd distance between old and new position of point -! debug if true debug statements are carried out otherwise -! they are not -! finished logical to indicate whether loop is finished or not -! i loop variable -! iallow allowance indicator -! ikn loop variable -! jeind endaddress neighbours -! jkn local node number -! jr loop variable -! jstart startaddress neighbours -! nbuur number of neighbours -! surf surface of all elements containing specified node -! surf1 surface one special element -! surfre reflection value for surface -! xh old x-coordinate -! xz new x-coordinate -! yh old y-coordinate -! yz new y-coordinate -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Compute stop value for coarseness -! while not finished do -! compute max repositioning distance -! check whether distance small enough -! if so finished else reposition again -! end while -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Compute stop value for coarseness - - debug = .false. - coars = 0.02 * coars - finished = .false. - jr = 1 - do while ( .not. finished ) - jr = jr + 1 - afstnd = 0d0 - do ikn = nipnt + 1 , npoint - -! --- Node ikn, compute surface - - surf = 0d0 - surf1 = 0d0 - -! --- Start values for ikn: - - xh = coor(1,ikn) - yh = coor(2,ikn) - -! --- Add surf of all elements ikn is node of: - - do i = 1, nelem - i1 = kelem( 1,i ) - i2 = kelem( 2,i ) - i3 = kelem( 3,i ) - -! --- Check triangle and add surface: - - if ( i1==ikn.or.i2==ikn.or.i3==ikn ) then - call msho19(coor,i1,i2,i3,surf1) - surf = surf + surf1 - end if - end do - -! --- Set reference value for surface - - surfre = surf - -! --- Run through all neighbours and compute (xz,yz): - - jstart = 0 - if ( ikn/=1 ) jstart = iwork( ikn - 1 ) - jstart = jstart + 1 - jeind = iwork( ikn ) - if ( jstart<=jeind ) then - -! --- jstart<=jeind, there are neighbours, initialize: - - xz = 0d0 - yz = 0d0 - -! --- Set number of neighbours: - - nbuur = jeind - jstart + 1 - -! --- Run through all neighbours and compute barycenter: - - do i = jstart , jeind - jkn = ibuurp(i) - if ( jkn>0 ) then - xz = xz + coor(1,jkn) - yz = yz + coor(2,jkn) - else - nbuur = nbuur - 1 - end if - end do - -! --- New(?) coordinates - - xz = xz / nbuur - yz = yz / nbuur - -! --- Two possibilities: No relaxation or Overrelaxation: - - xn = xh + 1.62 * ( xz - xh ) - yn = yh + 1.62 * ( yz - yh ) - -! --- Try overrelaxation: Set coordinates: - - coor(1,ikn) = xn - coor(2,ikn) = yn - -! --- Check surface: - - surf = 0d0 - -! --- Run through all elements: - - do i = 1, nelem - i1 = kelem( 1,i ) - i2 = kelem( 2,i ) - i3 = kelem( 3,i ) - -! --- Check triangle and add surface: - - if ( i1==ikn.or.i2==ikn.or.i3==ikn ) then - call msho19(coor,i1,i2,i3,surf1) - surf = surf + abs(surf1) - end if - end do - iallow = 0 - if ( abs(surf - surfre)<100 * epsmac ) iallow = 2 - -! --- Allowed? Then ready: - - if ( iallow/=2 ) then - -! --- Not allowed: Check for barycenter: - - coor(1,ikn) = xz - coor(2,ikn) = yz - -! --- Check surface: - - surf = 0d0 - -! --- Run through all elements: - - do i = 1, nelem - i1 = kelem( 1,i ) - i2 = kelem( 2,i ) - i3 = kelem( 3,i ) - -! --- Check triangle and add surface: - - if ( i1==ikn.or.i2==ikn.or.i3==ikn ) then - call msho19(coor,i1,i2,i3,surf1) - surf = surf + surf1 - end if - end do - if ( abs(surf - surfre)<100 * epsmac ) iallow = 1 - -! --- Allowed? Then ready: - - if ( iallow==0 ) then - -! --- Nothing allowed use old values: - - coor(1,ikn) = xh - coor(2,ikn) = yh - end if - end if - -! --- Check whether "new" point is different from "old" point: - - xz = coor(1,ikn) - yz = coor(2,ikn) - -! --- Compute distance: - - af = (xh-xz)*(xh-xz)+(yh-yz)*(yh-yz) ! squared distance - if ( af>afstnd ) afstnd=af - end if ! ( jstart<=jeind ) - end do - -! --- Check whether wanted accuracy is found: - - if ( debug ) - + write(irefwr,*) 'jr =',jr,'afstand=',afstnd,'coars=',coars - if ( jr>2 .and. sqrt(afstnd) 90 degrees -! Indicate which side it concerns. -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! angle -! ********************************************************************** -! -! MODULES USED -! - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision a, b, c - integer icase - -! a i length of first side of triangle -! b i length of second side of triangle -! c i length of third side of triangle -! icase o indicator if (>0) an angle and which angle is too large -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision angle1, angle2, angle3, aa, bb, cc, q - -! aa length of side one squared -! angle1 first angle -! angle2 second angle -! angle3 third angle -! bb length of side two squared -! cc length of side three squared -! q constant -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Trivial -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Square the three sides - - aa = a * a - bb = b * b - cc = c * c - -! --- Use cosine rule to compute the cosine of each of the three angles - - angle1 = ( cc + aa - bb ) / ( 2 * c * a ) - angle2 = ( aa + bb - cc ) / ( 2 * a * b ) - angle3 = ( bb + cc - aa ) / ( 2 * b * c ) - - q = -0.01d0 - -! --- Suppose that all angles are < 90 degrees: - icase = 0 - -! --- Next check whether this is correct: - if ( angle1.lt.q ) then - icase = 1 - else if ( angle2.lt.q ) then - icase = 2 - else if ( angle3.lt.q ) then - icase = 3 - end if - - end diff --git a/extern/sepran/msho24.for b/extern/sepran/msho24.for deleted file mode 100644 index 9c20e5112..000000000 --- a/extern/sepran/msho24.for +++ /dev/null @@ -1,226 +0,0 @@ - subroutine msho24 ( kstapl, kstap, coor, i1, i2, icheck ) -! ====================================================================== -! -! programmer Niek Praagman -! version 3.1 date 23-02-2010 Adjustment for plaxis pnts, use -! MSHO75 in stead of MSHG03 -! version 3.0 date 14-02-2005 Update -! version 2.2 date 25-06-1999 For savety leave routine if second point -! is plaxis -! version 2.1 date 26-05-1997 Check coincidence of double -! Plaxis points -! version 2.0 date 21-02-1994 New norms -! version 1.1 date 14-10-1990 use routine MSHG03 -! version 1.0 date 17-04-1989 -! -! copyright (c) 1989-2010 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Check whether line i1 - i2 has a common point with one of the -! boundary lines -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! crossing_point -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpr' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision coor(2,*) - integer kstap, kstapl(2,kstap), i1, i2, icheck - -! coor i coordinate array -! i1 i first node of line to be considered -! i2 i second node of line to be considered -! icheck o if a line crosses the new element then -! icheck # 0 and equal to number of line -! if no point is "inside" the new element then -! icheck = -1 else icheck is nodenumber of point -! inside -! kstap i number of lines in kstapl -! kstapl i actual array with boundary lines -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision x1, y1, x2, y2, xmin, xmax, ymin, ymax, xa, ya, - + xb, yb, xlm, ylm, eps, dis - integer ia, ib, ih, il - -! dis distance -! eps accuracy -! ia node number -! ib node number -! ih indicator -! il loop variable -! x1 x-coordinate -! x2 x-coordinate -! xa x-coordinate -! xb x-coordinate -! xlm extreme x-value -! xmax extreme x-value -! xmin extreme x-value -! y1 y-coordinate -! y2 y-coordinate -! ya y-coordinate -! yb y-coordinate -! ylm extreme y-value -! ymax extreme y-value -! ymin extreme y-value -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! MSHO75 check whether two line segments have a common point -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen( 'msho24' ) - - eps = 10 * epsmac - - icheck = -1 - - x1 = coor(1,i1) - y1 = coor(2,i1) - - x2 = coor(1,i2) - y2 = coor(2,i2) - - xmin = min(x1,x2) - xmax = max(x1,x2) - ymin = min(y1,y2) - ymax = max(y1,y2) - -! --- Check whether line i1 - i2 has point in common -! with old boundary lines. - - do il = 1 , kstap - - ia = kstapl(1,il) - ib = kstapl(2,il) - -! --- First check whether node numbers of boundary element -! are either equal i1 or i2 - - if ( ia==i1 .or. ia==i2 ) goto 200 - if ( ib==i1 .or. ib==i2 ) goto 200 - - xa = coor(1,ia) - ya = coor(2,ia) - - xb = coor(1,ib) - yb = coor(2,ib) - -! --- Check whether coordinates of nodes are exactly the same, i.e. -! whether it concerns Plaxis points -! Point ia and i1 - - dis = (x1-xa)*(x1-xa) + (y1-ya)*(y1-ya) - - if ( disxmax ) goto 200 - xlm = max(xa,xb) - if ( xlmymax ) goto 200 - ylm = max(ya,yb) - if ( ylm1 ) then - - i1 = kstapl(1,ielem) - i2 = kstapl(2,ielem) - - kstapl(1,ielem) = kstapl(1,1) - kstapl(2,ielem) = kstapl(2,1) - - kstapl(1,1) = i1 - kstapl(2,1) = i2 - - end if - - end diff --git a/extern/sepran/msho26.for b/extern/sepran/msho26.for deleted file mode 100644 index 42a620e29..000000000 --- a/extern/sepran/msho26.for +++ /dev/null @@ -1,115 +0,0 @@ - subroutine msho26( kelem, nelem, i2, i3, jelem, i4 ) - -! ======================================================================= -! -! -! programmer niek praagman -! -! version 3.0 date 02-02-2010 Redesign -! version 2.0 date 22-02-1994 New norms -! version 1.0 date 17-04-1989 -! -! -! -! copyright (c) 1989-2010 "ingenieursbureau sepra" -! permission to copy or distribute this software or documentation -! in hard or soft copy granted only by written license obtained -! from "ingenieursbureau sepra". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system (e.g. , in memory, disk or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! -! *********************************************************************** -! -! DESCRIPTION -! -! Determine triangle where i2 - i3 is side of -! -! *********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! triangle -! -! *********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer kelem(*), nelem, i2, i3, jelem, i4 - -! i2 i node number -! i3 i node number -! i4 o extra node to form triangle -! jelem o number of element found -! kelem i element array -! nelem i number of elements in kelem -! -! *********************************************************************** -! -! COMMON BLOCKS -! -! *********************************************************************** -! -! LOCAL PARAMETERS -! - integer ielem, j, j1, j2, j3 -! -! j loop variable -! j1 local element node -! j2 local element node -! j3 local element node -! -! *********************************************************************** -! -! SUBROUTINES CALLED -! -! *********************************************************************** -! -! ERROR MESSAGES -! -! *********************************************************************** -! -! METHOD -! -! ======================================================================= - - ielem = jelem - - jelem = 0 - - do 200 j = 1, nelem - - if ( j /= ielem ) then -! --- Find triangle j with the same side i2 - i3 that is not equal to -! element ielem: - - j1 = kelem(3*j-2) - j2 = kelem(3*j-1) - j3 = kelem(3*j ) - - if ( j1.eq.i3 .and. j2.eq.i2 ) then - jelem = j - i4 = j3 - goto 500 - else if ( j2.eq.i3 .and. j3.eq.i2 ) then - jelem = j - i4 = j1 - goto 500 - else if ( j3.eq.i3 .and. j1.eq.i2 ) then - jelem = j - i4 = j2 - goto 500 - end if - - end if - -200 continue - - i4 = 0 - -500 continue - - end diff --git a/extern/sepran/msho27.for b/extern/sepran/msho27.for deleted file mode 100644 index 9f3d7fc72..000000000 --- a/extern/sepran/msho27.for +++ /dev/null @@ -1,147 +0,0 @@ - subroutine msho27( coor, i1, i2, i3, i4 ) -! ====================================================================== -! -! programmer niek praagman -! version 3.0 date 22-02-1994 New norms -! version 2.0 date 07-09-1989 New method utilizing a circle-concept -! version 1.0 date 17-04-1989 -! -! copyright (c) 1989-1999 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Determine best diagonal in quadrangle. At input diagonal is -! line 2-3. Check whether 1-4 is better. -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! diagonal -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpr' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision coor(*) - integer i1, i2, i3, i4 - -! coor i coordinate array -! i1 i node -! i2 i node -! i3 i node -! i4 i node -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision af1, af2, xa, xb, xc, xd, ya, yb, yc, yd, - + xm, ym, det - integer j1, j2, j3, j4 - -! af1 distance -! af2 distance -! det area of triangle -! j1 helpnode -! j2 helpnode -! j3 helpnode -! j4 helpnode -! xa x-coordinate -! xb x-coordinate -! xc x-coordinate -! xd x-coordinate -! xm x-coordinate -! ya y-coordinate -! yb y-coordinate -! yc y-coordinate -! yd y-coordinate -! ym y-coordinate -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- consider quadrangle i1 - i2 - i3 - i4 - - j1 = i1 - j2 = i2 - j3 = i3 - j4 = i4 - -! --- Determine best diagonal - - xa = coor(2*i1-1) - xb = coor(2*i2-1) - xc = coor(2*i3-1) - xd = coor(2*i4-1) - ya = coor(2*i1 ) - yb = coor(2*i2 ) - yc = coor(2*i3 ) - yd = coor(2*i4 ) - det = (xa-xb)*(ya-yc) - (xa-xc)*(ya-yb) - if ( abs(det).lt.10 * epsmac ) then - -! --- Triangle 1-2-3 is not good, take diagonal 1-4 - - i1 = j2 - i2 = j4 - i3 = j1 - i4 = j3 - else - xm = ( ( xa*xa + ya*ya ) * ( yb-yc ) + - + ( xb*xb + yb*yb ) * ( yc-ya ) + - + ( xc*xc + yc*yc ) * ( ya-yb ) ) / (2*det) - ym = ( ( xa*xa + ya*ya ) * ( xb-xc ) + - + ( xb*xb + yb*yb ) * ( xc-xa ) + - + ( xc*xc + yc*yc ) * ( xa-xb ) ) / (-2*det) - af1 = ( xa-xm ) * ( xa-xm ) + ( ya-ym ) * ( ya-ym ) - af2 = ( xd-xm ) * ( xd-xm ) + ( yd-ym ) * ( yd-ym ) - if ( af2.lt.af1 ) then - -! --- Change diagonal : (4-1 instead of 2-3) - - i1 = j2 - i2 = j4 - i3 = j1 - i4 = j3 - end if - end if - end diff --git a/extern/sepran/msho28.for b/extern/sepran/msho28.for deleted file mode 100644 index 263ab6571..000000000 --- a/extern/sepran/msho28.for +++ /dev/null @@ -1,174 +0,0 @@ - subroutine msho28 ( coor, i1, i2, i3, xn, yn, npoint, itri, - + iperm ) -! ====================================================================== -! -! programmer niek praagman -! version 3.1 date 23-03-2009 Accuracy adjusted using norm -! version 3.0 date 15-02-2005 Update -! version 2.2 date 29-09-1998 Correction for double line -! version 2.1 date 21-02-1997 Adjust for double line and hence -! for "double" points -! version 2.0 date 22-02-1994 New norms -! version 1.0 date 07-06-1989 -! -! copyright (c) 1989-2009 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Check whether there are boundary points inside the -! triangle with nodes i1 - i2 - i3. -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! check -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpr' -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision coor(2,*), xn, yn - integer i1, i2, i3, npoint, itri(*), iperm - -! coor i coordinate array -! i1 i first node -! i2 i second node -! i3 i last node triangle, if 0 then new coordinates -! are given by xn,yn -! iperm o result , IPERM = 1 there are internal points -! IPERM = 0 no internal points -! itri i indicator whether point i is in boundary or not -! npoint i number of points in COOR -! xn i coordinate new point if i3 = 0 -! yn i coordinate new point if i3 = 0 -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision x1, y1, x2, y2, x3, y3, xm, ym, opp, det, eps, - + dist, norm - integer i - -! det area of triangle -! dist distance -! eps accuracy -! i loop variable -! norm normed value for length -! opp area of triangle -! x1 x-coordinate -! x2 x-coordinate -! x3 x-coordinate -! xm x-coordinate -! y1 y-coordinate -! y2 y-coordinate -! y3 y-coordinate -! ym y-coordinate -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Check for all boundary points whether they are inside -! If point inside then check whether point is a "double" -! point -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - iperm = 1 - eps = 1d-2 * epsmac - -! --- Check whether boundary points are inside triangle - - x1 = coor(1,i1) - y1 = coor(2,i1) - - x2 = coor(1,i2) - y2 = coor(2,i2) - - if ( i3==0 ) then - x3 = xn - y3 = yn - else - x3 = coor(1,i3) - y3 = coor(2,i3) - end if - -! --- Compute relative value for length of "vector": - norm = abs(x1)+abs(x2)+abs(x3)+abs(y1)+abs(y2)+abs(y3) - -! --- Compute area of triangle - det = x1*(y2-y3) + x2*(y3-y1) + x3*(y1-y2) - - do i = 1, npoint -! --- If not point of triangle and point i in boundary then check - if (i/=i1.and.i/=i2.and.i/=i3.and.itri(i)/=0) then - - xm = coor(1,i) - ym = coor(2,i) - - opp = (x1*(y2-ym) + x2*(ym-y1) + xm*(y1-y2))/det - if ( opp<-eps .or. opp>1d0+eps ) goto 100 - - opp = (x2*(y3-ym) + x3*(ym-y2) + xm*(y2-y3))/det - if ( opp<-eps .or. opp>1d0+eps ) goto 100 - - opp = (x3*(y1-ym) + x1*(ym-y3) + xm*(y3-y1))/det - if ( opp<-eps .or. opp>1d0+eps ) goto 100 - -! --- Point i is inside, check whether point coincides -! with one of the cornerpoints (and hence is a "double" -! point) - - dist = abs(x1-xm) + abs(y1-ym) - - if ( distnipnt ) then - iex = iwork(ia)-iwork(ia-1) - if ( iex==3 .or. ianipnt ) then - iex = iwork(ib)-iwork(ib-1) - if ( iex==3 .or. ibnipnt ) then - iex = iwork(ic)-iwork(ic-1) - if ( iex==3 .or. icnipnt ) then - iex = iwork(id)-iwork(id-1) - if ( iex==3 .or. ididebug -! ielem loop variable for elements -! iex1 node to be considered, neighbour -! iex2 node to be considered, neighbour -! ifill indicator whether diagonals of quadrilaterals -! have been changed (1) or not (0) -! ih loop variable -! ii1 node to be considered -! ii2 node to be considered -! imultiply Multiplication factor -! In this program this factor is arbitrarely set to -! 10 log(coarsemax/coarsemin) -! It is used to define the number of searches for -! "acceptable" elements -! inear indicator how near a boundary point is -! iperm indicator whether line is permitted or not -! ipoint node number -! ipotn1 potential point -! ipotn2 potential point -! itot help for summing -! itri array containing information whether a nodal point np is -! in the actual boundary (itri(np)>0) or not (=0) -! j1 node number -! j2 node number -! j3 node number -! j4 node number -! ja help indicator -! jcoars indicator whether coarseness is given (1) or not (0) -! jcube array indicating whether a cube is outside the volume (0), -! is a boundary cube ( 1 ) or is inside ( 2 ) -! jelem element number -! jpn node number -! kdrie number of boundary element for crossing -! kinbnd array with extra internal boundary pieces -! kstap actual length of array KSTAPL -! kstapl array containing all actual boundary elements -! lenbnd length axtra internal curvs part in kinbnd -! leng actual length of repos array -! ma maximum value -! maxratio maximum ratio allowed in two subsequent elements -! meshtmp helparray to store temporarily elements of "best" mesh -! n1 actual number of blocks in x-direction -! n2 actual number of blocks in y-direction -! nc cube number -! ncube number of reference blocks -! neldef defined length of helpelementsarray -! nelemi Number of internal cells (elements) -! Hence, number of boundary cells = nelem - nelemi -! neltmp helpvariable allocation array of elements -! nherha count of redivisions performed -! nipnt number of initial points -! nkmeshc estimated number of elements in MESH -! no help indicator -! nochan change indicator -! npndef defined length of defined help pointsarray -! npntmp helpvariable allocation array of points -! nrepos estimated length of repositioning array -! nx number of reference blocks in x-direction -! ny number of reference blocks in y-direction -! ratiop min ratio of temporary mesh -! surf area value -! surf1 area value -! surf2 area value -! tran scaling parameter -! userco local helparray to store coordinates of all userpoints -! valare reference areavalue -! verh ratio -! x x-coordinate -! xm x-coordinate help node on boundary -! xmaxloc extreme (max) x-value for the whole area -! xminloc extreme (min) x-value for the whole area -! xmint min x for transformation -! xn x-coordinate new point -! xnx x-coordinate second new point -! xstart x-reference coordinate -! y y-coordinate -! ym y-coordinate help node on boundary -! ymaxloc extreme (max) y-value for the whole area -! yminloc extreme (min) y-value for the whole area -! ymint min y for transformation -! yn y-coordinate new point -! yny y-coordinate second new point -! ystart y-reference coordinate -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! ERRINT Put integer in error message -! ERRSUB Error messages -! MSHCHKSTAPL Check the contents of array kstapl -! MSHCURVINTERS2 Check if edges in boundary of surface do not intersect -! MSHO01 Check number of neighbours for all boundary points and -! compute coarseness for all points -! MSHO03 Compute distance between two points -! MSHO04 Determine extreme coordinate values -! MSHO05 Determine min and max distance for total area -! MSHO06 Determine coarseness for each triangle -! MSHO07 Check whether point belongs to given area -! MSHO08 Check whether all elements are given right and adjust -! boundary elements array -! MSHO09 Compute midpoint line and the normal vector -! MSHO10 Fill element in in array and adjust boundary array -! MSHO11 compute angle -! MSHO12 Compute neighbour nodes and angles -! MSHO13 Check for common points with other lines -! MSHO14 Check whether new point is not too near to -! old point -! MSHO15 Fill element with new point in in array -! MSHO16 Compute number of neighbours of points -! MSHO18 Perform repositioning -! MSHO19 Compute area of triangle -! MSHO20 Change ordering of boundary -! MSHO21 Compute reference value for area -! MSHO22 Check form of triangle -! MSHO24 Check whether line has point in common with boundary -! MSHO25 Place smallest element at top of boundary array -! MSHO26 Determine triangle with given side -! MSHO27 Determine best diagonal in quadrilateral -! MSHO28 Check whether boundary points are inside triangle -! MSHO29 Remove internal points with three or four neighbours -! MSHO30 Make boundar array for all elements surrounding -! element indicated -! MSHO33 Determine the ratio (2*Rout/Rin) for all triangles of mesh -! MSHO35 Place special nodes and nodes and elements around -! these nodes -! MSHO36 Add nodal points of internal lines to coor and adjust -! array of boundaries kstapl for mesh generation -! MSHO38 check the coarseness in the total domain considered -! in relation to smoothness requirements -! MSHO40 Check whether all barycenters of triangles are only -! belonging to their "own" triangle -! MSHO42 Check whether line i - j is a piece in one of the internal -! curves -! MSHTRANS2DSUR Transform 2d region to region of unit length in first -! quadrant -! PLOTBOUNINTER Plot actual boundary during the process of creation -! of a mesh -! PLOTMESHINTER Plot actual mesh during the process of creation of a mesh -! PRININ print 1d integer array -! PRININ1 print 2d integer array -! PRINRL1 Print 2d real vector -! ********************************************************************** -! -! I/O -! -! none -! ********************************************************************** -! -! ERROR MESSAGES -! -! 900 Estimated number of points too small -! 901 Estimated length of element array too small. -! 902 No convergence in MESH generation. -! 903 Either connections array not correct or repositioning -! array too small -! ********************************************************************** -! -! PSEUDO CODE -! -! MSHO2D is meant to divide an arbitrary polygon in triangles -! The method used is the so-called advancing boundary method -! Consider all parts that together constitute the boundary of the area -! that has to be triangulated. -! A global coarseness is computed over the whole area using a Laplacian -! method. -! If special points (array coar) are submitted the division is started by -! creating special elements around these points. -! Next the smallest part (segment) of the boundary is determined. -! First it is considered whether there can be created a triangle with one of -! the two neighbouring segments -! If so the new boundary is defined and the -! process starts again. -! If not the process goes on -! A new point is defined using the inside pointing normal. It is con- -! sidered whether this new point is really inside and far enough away -! from the other boundary lines. -! If not so it is considered whether a triangle can be formed using -! one of the already created points. -! If so the boundary is redefined and the process starts -! again. -! If not the actual considered part is placed at the back -! of the boundary array and another part is considered first. -! If so the new boundary is defined and the process starts. -! The process ends when there are no parts in the boundary, i.e. the area -! has been divided totally in triangles or when it is not possible to cre- -! ate new triangles. In that case a message is given. -! If the process has terminated normally, a repositioning is performed. -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen( 'msho2d' ) - debug = .false. - -! --- debug = .false. - - if ( debug ) write(irefwr,*) 'At start of msho2d, npunt =',npunt - idebug = 10000000 - icount = 0 - -! --- Copy estimate for number of elements: - - !nkmeshc = nelem - nkmeshc = 2000000 ! nelem is uninitialised - -! --- Initialize - - neltmp = 0 - npntmp = 0 - -! --- Allocate helparrays: - - allocate( chelp ( npunt ) ) - allocate( icube ( npunt ) ) - allocate( itri ( npunt ) ) - allocate( kstapl ( 10 * npunt + 20 ) ) - -! --- Fill arrays userco and coaval: - - allocate( userco( 2 * nuspnt ) ) - allocate( coaval( 2 + nuspnt ) ) - -! --- Coordinates: - - do i=1, nuspnt - userco(2*i-1) = rinput(1 + ndim*i) - userco(2*i ) = rinput(2 + ndim*i) - end do - -! --- Coarseness: - - ! AvD: enable this to use coarseness points and coarseness values in rinput array (if nuspnt>0) - jcoars = 0 !intarmsh(44) - - if ( jcoars==1 ) then - -! --- Coarseness is given: - - do i=1, nuspnt+2 - coaval( i ) = rinput(2 + ndim*nuspnt + i) - end do - else - -! --- No coarseness given, hence no actions: - - coaval( 1 ) = 1d0 - end if - - if ( debug ) then - -! --- Give coordinates and coarsenesses submitted userpoints: - - write(irefwr,*) 'in msho2d, nuspnt = ',nuspnt - write(irefwr,*) 'coordinates and coarseness:' - write(irefwr,*) 'overall coarseness',coaval(1) - write(irefwr,*) 'maxratio ',coaval(nuspnt + 2) - do i=1, nuspnt - write(irefwr,*) i,userco(2*i-1),userco(2*i),coaval(i+1) - end do - end if - -! --- Replace all nodes temporarily to the first (positive) quadrant: -! (Determine translation parameters x- and y-tran) - - call mshtrans2dsur( coor, npoint, xmint, ymint, tran, - + ncoar, coar, ncurvs, curves, cocurv, - + userco, nuspnt ) - - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'Debug information from msho2d' - write(irefwr,*) 'Nodenumbers and coordinates' - do i=1, npoint - write(irefwr,*) i,'x = ',coor(1,i),'y = ',coor(2,i) - end do - write(irefwr,*) 'Boundary pieces' - write(irefwr,*) 'End boundary pieces' - end if - if ( ierror/=0 ) goto 1000 - -! --- Set accuracy - - eps = 10 * epsmac - xn = 0d0 - yn = 0d0 - -! --- Check whether each line in KBOUND is connected -! and determine for each point a coarseness-value -! (this check concerns the outer boundary and eventually holes -! as given bij bcord. Internal lines are treated later) - - if ( debug ) then - write(irefwr,*) 'MSHO2D array coar contains',ncoar,'points' - write(irefwr,*) 'these points are internal in surf',isurnr - do i=1, ncoar - write(irefwr,*) i,'crds',( coar(i1,i),i1=1,3) - end do - write(irefwr,*) 'end points array coar for surf',isurnr - end if - -! --- Compute the coarsenesses: - - call msho01 ( kbound, nbound, itri, kstapl, chelp, coor, - + npoint, coarsemin, coarsemax, coar, ncoar ) - if ( ierror/=0 ) goto 1000 - -! --- Check that edges in array kbound do not intersect each other - - call mshcurvinters2 ( kbound, nbound, coor, isurnr ) - if ( ierror/=0 ) goto 1000 - -! --- Place boundary elements in kstapl: - - kstap = nbound - -! --- Run through all pieces: - - do i = 1, 2*nbound - kstapl(i) = kbound(i) - end do - -! --- Set number of boundary points before internal lines are added - - nipnt = npoint - -! --- Eventually print contents kstapl: - - if ( debug ) then - write(irefwr,*) 'Array kstapl' - do i = 1, kstap - write(irefwr,*) 'Piece',i,':',kstapl(2*i-1),'-',kstapl(2*i) - end do - end if - -! --- Internal lines? - - if ( ncurvs>0 ) then - -! --- Place points of extra internal lines in kstapl and check -! the boundaries again (was already checked): - - call msho36 ( coor, npoint, istep, ncurvs, curves, cocurv, - + kstapl, kstap, kbndpt, nbndpt, coarsemin, - + extquanodes, chelp ) - if ( debug ) then - -! --- Give computed coarsenesses extra nodes due to internal -! lines - - do i=nipnt+1, npoint - write(irefwr,*) 'Node',i,'coarseness',chelp(i) - end do - end if - -! --- Check for intersections: - - call mshcurvinters2 ( kstapl, kstap, coor, isurnr ) - if ( ierror/=0 ) then - write(irefwr,*) - + 'Intersection(s) found due to internal lines. - + Error! Please check your input' - goto 1000 - end if - -! --- Eventually print kstapl again: - - if ( debug ) then - write(irefwr,*) 'Start MSHO2D with ',npoint,' points' - do i=1, npoint - write(irefwr,*) i,'crd-s',(coor(ierror,i),ierror=1,2) - end do - write(irefwr,*) 'Check! ok? Check kstapl yourself ' - write(irefwr,*) 'Array kstapl, kstap = ',kstap - do i=1, kstap - write(irefwr,*) i,kstapl(2*i-1),kstapl(2*i) - end do - end if - ierror = 0 - end if - -! --- Place all boundary pieces in new array kinbnd, -! determine length (use all kstapl pieces) and allocate: - - lenbnd = 2 * kstap - -! --- Kinbnd has to be kept for later use, allocate: - - allocate ( kinbnd ( lenbnd ) ) - -! --- Fill array: - - do i = 1, lenbnd - kinbnd(i) = kstapl(i) - end do - -! --- Eventually print array kinbnd: - - if ( debug ) then - write(irefwr,*) 'array kinbnd' - write(irefwr,*) (kinbnd(i),i=1,lenbnd) - write(irefwr,*) 'end array kinbnd' - end if - -! --- The minimum and maximum coarseness at the boundary is used to define -! the multiplication factor - - imultiply = max(1,nint(log10(coarsemax/coarsemin))) - if ( debug ) - + write(irefwr,*) 'coarsemin, coarsemax, imultiply ', - + coarsemin, coarsemax, imultiply - if ( ierror/=0 ) goto 1000 - -! --- Determine extreme coordinate-values for this surface - - call msho04 ( coor, npoint, xminloc, xmaxloc, yminloc, ymaxloc ) - if ( ierror/=0 ) goto 1000 - -! --- Determine max and min distance for total area -! ( First set nodes internal curves etc to zero) - - call msho05 ( chelp, nipnt, dismin, dismax ) - - if ( ierror/=0 ) goto 1000 - -! --- Determine global frame -! Determine number of reference quadrilaterals for this frame -! Use mean value for coarse frame: - - dism = (dismax + 2 * dismin) / 3d0 - -! --- Compute number of "boxes": - - nx = int( (xmaxloc-xminloc) / (0.9998 * dism) ) + 1 - ny = int( (ymaxloc-yminloc) / (0.9998 * dism) ) + 1 - -! --- Number of quadrilaterals - - ncube = nx * ny - - if ( debug ) - + write(irefwr,*) 'nx, ny, ncube, dism',nx,ny,ncube,dism - -! --- Allocate space for arrays jcube and cube: - - allocate( jcube( ncube ) ) - allocate( cube( ncube ) ) - -! --- Determine for each centre a dis value - - xstart = ( xmaxloc + xminloc - (nx)*dism ) / 2d0 - ystart = ( ymaxloc + yminloc - (ny)*dism ) / 2d0 - -! --- Place startvalues a little "upwards": - - xstart = xstart + dism/12d0 - ystart = ystart + dism/12d0 - - if ( debug ) then - write(irefwr,*) 'MSHO2D:' - write(irefwr,*) 'xminloc =',xminloc,' xmaxloc =',xmaxloc - write(irefwr,*) 'yminloc =',yminloc,' ymaxloc =',ymaxloc - write(irefwr,*) 'x en y start in cube 1',xstart,ystart - write(irefwr,*) 'x last cube is ',xstart+nx*dism - write(irefwr,*) 'y last cube is ',ystart+ny*dism - write(irefwr,*) 'dismin = ',dismin,' dismax = ',dismax - end if - -! --- Determine coarseness for each quadrilateral - - if ( debug ) - + write(irefwr,*) 'Determine coarseness for surf ',isurnr - - call msho06 ( npoint, coor, dism, xstart, ystart, nx, ny, - + icube, chelp, cube, jcube, kbound, nbound, - + coar, ncoar, ncurvs, curves, cocurv ) - -! --- Check all mutual coarsenesses: userpoint, internal_points and -! internal_curves - - if ( jcoars==1 ) then - maxratio = coaval( nuspnt + 2 ) - else - maxratio = 0 - end if - -! --- Check coarseness ratio's only in 2D problems and only if user -! has submitted a value (i.e. maxratio is not zero!) - - if ( ndim==2 .and. maxratio>1d0 ) then - -! --- Check submitted coarsenesses of user: - - call msho38 ( npoint, coor , dism , xstart, ystart, - + kbndpt, nbndpt, numcrvboun , boundary, - + nbound, nholes, nx , ny , icube , - + chelp , cube , jcube , kstapl, kstap , - + ncurvs, curves, cocurv , isurnr, userco, - + nuspnt, coaval, tran ) - end if - - if ( ierror/=0 ) goto 1000 - -! --- Compute reference area value for each quadrilateral - - deallocate( chelp ) - -! --- Next allocate and use array chelp for area of blocks: - - allocate( chelp ( ncube ) ) - - call msho21 ( cube, ncube, chelp ) - - if ( ierror/=0 ) goto 1000 - -! --- Set number of old (fixed!) points -! (Now nodes on internal lines are not excluded) - - nipnt = npoint - -! --- Repositioning - - nrepos = 10 * npunt + 20 - -! --- Clear array itri - - do i = 1, npunt - itri(i) = 0 - end do - -! --- Fill array itri - - do i = 1, 2*kstap - ipoint = kstapl(i) - itri(ipoint) = itri(ipoint) + 1 - end do - -! --- Eventually check array kstapl: - - nelem = 0 - nelemi = 0 - -! --- First step: check whether there are special points that should be -! treated first. If so fill elements. - - coarmin = coarsemin - - if ( ncoar>0 ) then - -! --- Place special nodes and fill elements: - - call msho35 ( npoint, coor, xstart, ystart, dism, - + coar, ncoar, icube, nx, kmeshc, nelem, - + kstapl, kstap, itri, isurnr, userpoints, - + kbndpt, nbndpt ) - -! --- Adjust number of initial ("fixed") points -! (Make choice: only the point itself, or also -! the surrounding points) -! --- In case of also the surrounding points -! nipnt = nipnt + 7 * ncoar -! --- Choice: only the point itself: - - nipnt = nipnt + 7 * ncoar - nelemi = nelem - - do i=1, ncoar - if ( coar(3,i)npunt ) then - if ( debug ) write(irefwr,*) 'Error while kstap = ',kstap - call errint ( npunt , 1 ) - call errint ( npoint, 2 ) - call errsub ( 900, 2, 0, 0 ) - end if - - if ( nelem>nkmeshc ) then - write(irefwr,*) 'Estimated length of element array too small' - write(irefwr,*) 'Number of elements found is more than the' - write(irefwr,*) 'used estimate',nkmeshc,'in SEPRAN.' - write(irefwr,*) 'Most probable cause: too much difference' - write(irefwr,*) 'in the coarseness along the boundary.' - write(irefwr,*) 'Try to divide your original region in' - write(irefwr,*) 'smaller sections with less coarseness variety' - write(irefwr,*) 'or check and change the local coarsenesses in' - write(irefwr,*) 'the userpoints of the original region.' - write(irefwr,*) 'If nothing helps: Please inform SEPRA' - call errsub ( 901, 0, 0, 0 ) - end if - - if ( ierror/=0 ) goto 1000 - -! --- Here follow helpstatements for debugging, normally these statements -! are skipped, using debug = .false.: - - debug = .false. - -! --- debug = .false. - - if ( debug .and. nochan==0 .and. nelem>0 ) then - i1 = kmeshc(1,nelem) - i2 = kmeshc(2,nelem) - i3 = kmeshc(3,nelem) - call msho19( coor, i1, i2, i3, surf1 ) - write(irefwr,*) 'element',nelem,' - ',i1,i2,i3 - if ( 0>1 ) then - do i=1, kstap - i1 = kstapl(2*i-1) - i2 = kstapl(2*i) - write(irefwr,*) 'Stuk',i1,i2 - end do - write(irefwr,*) 'coordinates' - do i=1,kstap - i1 = kstapl(2*i-1) - xm = coor(1,i1) - ym = coor(2,i1) - write(irefwr,*) i1,xm,ym - end do - write(irefwr,*) 'End of boundary' - end if - end if - - if ( nochan==0 .and. nelem==-3 ) then - write(irefwr,*) 'elem',nelem,'nodes',(kmeshc(i,nelem),i=1,3) - i1 = kmeshc(1,nelem) - i2 = kmeshc(2,nelem) - i3 = kmeshc(3,nelem) - call msho19( coor, i1, i2, i3, surf1 ) - write(irefwr,*) 'surface of element = ',surf1 - if ( surf1<10*epsmac ) then - write(irefwr,*) 'Results, kstap =',kstap - do i=1, npoint - xm = coor(1,i) - ym = coor(2,i) - write(irefwr,'(i6,(2f10.5))' ) i,xm,ym - end do - write(irefwr,*) 'Elements' - do i=1,nelem - i1 = kmeshc(1,i) - i2 = kmeshc(2,i) - i3 = kmeshc(3,i) - write(irefwr,'(4i5)') i,i1,i2,i3 - end do - write(irefwr,*) 'the end ' - go to 950 - end if - end if - debug = .false. - - iperm = 0 - -! --- Statements to indicate at which stage the subdivision is - - if ( debug .and. (nelem-1000*(nelem/1000))==0.and.nochan==0 ) then - write(irefwr,*) 'nelem = ',nelem - write(irefwr,*) 'kstap = ',kstap - end if - - if ( debug .and. nelem>100 ) then - -! --- Check kstapl - - write(irefwr,*) 'Check kstapl, nelem =',nelem,'kstap',kstap - call mshcurvinters2 ( kstapl, kstap, coor, isurnr ) - if ( ierror/=0 ) then - write(irefwr,*) - + 'Intersection, error! nelem = ',nelem - goto 1000 - end if - end if - - if ( debug .and. (nelem-1000*(nelem/1000))==0.and.nochan==0) then - write(irefwr,*) 'Control: nelem = ',nelem - -! --- Check whether all elements are given right and adjust array kstapl - - write(irefwr,*) 'Check via msho08 ' - call msho08 ( kstapl, kstap, coor, xstart, dismin, holeinfo, - + nholes, .true. ) - if ( ierror/=0 ) goto 1000 - write(irefwr,*) 'No error during check for nelem = ',nelem - call msho40 ( coor, kmeshc, npoint, nelem, iperm ) - end if - - if ( debug .and. nochan>0 ) then - write(irefwr,*) 'nelem = ',nelem,' nochan = ',nochan - write(irefwr,*) 'no element for',i1,'- ',i2 - end if - if ( debug .and. isurnr==-15 ) then - write(irefwr,*) 'surface number is',isurnr - write(irefwr,*) 'nelem = ',nelem,'kstap = ',kstap - if ( nochan==0 .and. nelem>0 ) then - write(irefwr,*) (kmeshc(i,nelem),i=1,3) - end if - end if - - if ( debug .and. nochan==0 .and. nelem>0 ) then - -! --- Print all elements one after one - - write(irefwr,*) 'Element',nelem,(kmeshc(i,nelem),i=1,3) - end if - - debug = .false. - -! --- Determine value for first group of boundary pieces to be considered: - - if ( nochan=idebug ) then - write(irefwr,*) 'extra check, kstap, npoint, icount ', - + kstap, npoint , icount - - call msho08 ( kstapl, kstap, coor, xstart, dismin, - + holeinfo, nholes, .true. ) - -! --- The next statements can be used if the process "hangs" - - write(irefwr,*) 'kstap, nochan,nelem ', kstap, nochan,nelem - end if - - if ( debug .and. nelem==-20000 ) then - write(irefwr,*) 'nelem = ',nelem,' checks' - call mshchkstapl ( kstapl, kstap, 'geval nelem' ) - write(irefwr,*) 'na mshchkstapl ierror =',ierror - call mshcurvinters2 ( kstapl, kstap, coor, isurnr ) - write(irefwr,*) 'na mshcurvinters2, ierror =',ierror - write(irefwr,*) 'nog ok?' - end if - - if ( debug ) then - -! --- Debug information - - end if - - debug = .false. - -! --- Check for smallest element: - - if ( ichan>0 ) call msho25 ( kstapl, ichan, coor ) - - angle = -0.1d0 - -! --- Remark: factor determines the number of elements -! Decreasing factor to for example 0.8 gives a much smoother mesh, -! but also a lot of extra points and elements - - factor = 1d0 - -! --- Change values in case of no convergence - - if ( nochan>10 .or. nochan>kstap ) then - angle = -0.7d0 - factor = 0.6d0 - end if - - if ( nochan >2 * kstap ) then - angle = -0.95d0 - factor = 0.50d0 - end if - -! --- If no convergence possible stop - - if ( nochan>3*kstap ) then - !write(irefwr,*) 'nochan =',nochan,' and kstap =',kstap - -! --- nochan too large - - if ( debug .or. 1>0 ) then - write(irefwr,*) 'Error 902, see information' - - do i=1, kstap - write(irefwr,*) kstapl(2*i-1),kstapl(2*i) - end do - do i=1, kstap - ja = kstapl(2*i-1) - write(*,*) 'P',ja,'=',coor(1,ja),coor(2,ja) - end do - write(irefwr,*) 'npoint = ',npoint - write(irefwr,*) 'Enough info?' - end if - - call errint ( nochan, 1 ) - call errint ( 3*kstap, 2 ) - call errint ( kstap, 3 ) - call errsub ( 902, 3, 0, 0 ) - - end if - if ( ierror/=0 ) goto 1000 - -! --- Check for ready - - if ( kstap==0 ) goto 500 - -! --- Transform in triangles, run through kstapl - - i1 = kstapl(1) - i2 = kstapl(2) - -! --- Change array itri - - itri(i1) = itri(i1) - 1 - itri(i2) = itri(i2) - 1 - -! --- First check whether triangle can be formed with other -! boundary lines, compute nodes and angles - - call msho12 ( coor, kstapl, kstap, i1, i2, iex1, iex2, - + angle1, angle2 ) - -! --- In emergency case: - - if ( nochan>kstap .and. 0>1 ) then - -! --- Try shortcut, compute surfaces: - - call msho19( coor, iex1, i1, i2, surf1 ) - call msho19( coor, i1, i2, iex2, surf2 ) - - write(irefwr,*) 'Shortcut, Emergency used:' - if ( surf1>0 .and. surf1>surf2 ) then - call msho10( kmeshc, nelem, i1, i2, iex1, - + kstapl, kstap, itri ) - write(irefwr,*) i1,i2,iex1 - nochan = 0 - - goto 300 - - else if ( surf2>0 .and. surf2>surf1 ) then - - call msho10( kmeshc, nelem, i1, i2, iex2, - + kstapl, kstap, itri ) - write(irefwr,*) i1,i2,iex2 - nochan = 0 - - goto 300 - - end if - end if - -! --- Check for errors - - if ( ierror/=0 ) goto 1000 - - ja = 0 - - if ( nochan>kstap .and. kstap>4 ) then - -! --- Combination of difficult triangles ? - - call msho12( coor, kstapl, kstap, iex1, i1, j1, j2, e1, e2 ) - if ( j1==iex2 ) ja = 1 - end if - if ( ierror/=0 ) goto 1000 - - if ( kstap==4 .or. ja==1 ) then - -! --- Special situation - - call msho19( coor, iex1, i1, i2, surf1 ) - call msho19( coor, i2, iex2, iex1, surf2 ) - - if ( surf1<0 .or. surf2<0 ) then - -! --- Difficult situation, first next triangle - - call msho19( coor, i1, i2, iex2, surf1 ) - if ( surf1>0 ) then - call msho10( kmeshc, nelem, i1, i2, iex2, kstapl, - + kstap, itri ) - nochan = 0 - goto 300 - end if - end if - end if - if ( ierror/=0 ) goto 1000 - - if ( iex1==iex2 ) then - -! --- Consider triangle i1 - i2 - iex1 = iex2, compute area - - call msho19( coor, i1, i2, iex1, surf ) - - iperm = 0 - if ( inside==1 ) - + call msho28( coor, i1, i2, iex1, xn, yn, npoint, - + itri, iperm ) - - if ( surf>=0 .and. iperm==0 ) then - - call msho10( kmeshc, nelem, i1, i2, iex1, - + kstapl, kstap, itri ) - nochan = 0 - - goto 300 - - end if - - if ( surf<=0 .and. kstap==3 ) then - -! --- Error: may be that later on repositioning solves this problem: - - write(irefwr,*) 'Emergency: Temporary bad element created' - write(irefwr,*) 'element has nodes' - write(irefwr,*) i1,' - ',i2,' - ',iex1 - call msho10( kmeshc, nelem, i1, i2, iex1, - + kstapl, kstap, itri ) - nochan = 0 - - goto 300 - - end if - - end if - -! --- Check for angles not greater than 180 degrees and determine -! which points are potential for new triangles - - call msho19( coor, i1, i2, iex1, surf1 ) - if ( ierror/=0 ) goto 1000 - - if ( surf1angle .and. angle2>=angle1 ) then - - call msho11 ( i1, iex1, iex2, coor, angleh ) - - if ( angleh<-0.5 ) then - -! --- Try i1 - i2 - iex1 - - ja = 1 - -! --- Adjust computation (surface is always computed) - - call msho19 ( coor, i2, iex2, iex1, surf ) - if ( surf<100 * eps ) ja = 0 - -! --- Check if none of the boundary nodes is in the new triangle: - - iperm = 0 - if ( ja==1 ) - + call msho28 ( coor, i1, i2, iex1, xn, yn, npoint, - + itri, iperm ) - - if ( ja==1 .and. iperm==0 ) then - -! --- Check whether i2 - iex1 is permitted - - call msho24 ( kstapl, kstap, coor, i2, iex1, icheck ) - - if ( icheck==0 ) then - - call msho10( kmeshc, nelem, i1, i2, iex1, kstapl, - + kstap, itri ) - nochan = 0 - - goto 300 - - end if - - else - - surf1 = rinfin - - end if - - else ! (angleh>angle ) - -! --- Try i1 - i2 - iex2 - - ja = 1 - -! --- Adjust computation (surface is always computed) - - call msho19 ( coor, i1, i2, iex2, surf ) - if ( surf<100 * eps ) ja = 0 - -! --- Check if none of the boundary nodes in the new triangle: - - iperm = 0 - if ( ja==1 ) - + call msho28 ( coor, i1, i2, iex2, xn, yn, npoint, - + itri, iperm ) - - if ( ja==1 .and. iperm==0 ) then - -! --- Check whether i1 - iex2 is permitted - - call msho24 ( kstapl, kstap, coor, i1, iex2, icheck ) - - if ( icheck==0 ) then - - call msho10( kmeshc, nelem, i1, i2, iex2, kstapl, - + kstap, itri ) - nochan = 0 - - goto 300 - - end if - - else - - surf2 = rinfin - - end if - - end if - - end if - - if ( ierror/=0 ) goto 1000 - - if ( surf1angle .and. angle1>=angle2 ) then - - call msho11 ( i2, iex2, iex1, coor, angleh ) - - if ( angleh<-0.5 ) then - -! --- Try i1 - i2 - iex2 - - ja = 1 - -! --- Adjust computation (surface is always computed) - - call msho19 ( coor, i1, iex2, iex1, surf ) - if ( surf<100 * eps ) ja = 0 - -! --- Check if none of the boundary nodes is in the new triangle: - - iperm = 0 - if ( ja==1 ) - + call msho28 ( coor, i1, i2, iex2, xn, yn, npoint, - + itri, iperm ) - - if ( ja==1 .and. iperm==0 ) then - -! --- Check whether i1 - iex2 is permitted - - call msho24 ( kstapl, kstap, coor, i1, iex2, icheck ) - - if ( icheck==0 ) then - call msho10( kmeshc, nelem, i1, i2, iex2, kstapl, - + kstap, itri ) - nochan = 0 - goto 300 - end if - else - surf2 = rinfin - end if - else ! (angleh>angle ) - -! --- Try i1 - i2 - iex1 - - ja = 1 - -! --- Adjust computation (surface is always computed) - - call msho19 ( coor, i1, i2, iex1, surf ) - if ( surf<100 * eps ) ja = 0 - -! --- Check if none of the boundary nodes is in the new triangle: - - iperm = 0 - if ( ja==1 ) - + call msho28 ( coor, i1, i2, iex1, xn, yn, npoint, - + itri, iperm ) - if ( ja==1 .and. iperm==0 ) then - -! --- Check whether i2 - iex1 is permitted - - call msho24 ( kstapl, kstap, coor, i2, iex1, icheck ) - - if ( icheck==0 ) then - call msho10( kmeshc, nelem, i1, i2, iex1, kstapl, - + kstap, itri ) - nochan = 0 - goto 300 - end if - else - surf1 = rinfin - end if - end if - end if - - if ( ierror/=0 ) goto 1000 - - if ( surf2 nx ) then - n1 = nx - end if - n2 = int ( (yn-ystart) / dism ) - if ( n2 < 0 ) then - n2 = 0 - else if ( n2 > ny - 1 ) then - n2 = ny - 1 - end if - nc = 1 + n1 + n2*nx - -! --- Find helpcoarseness - - cdis = cube(nc) - -! --- New guess using both coarsenesses: - coa = (disold + 2 * cdis)/3d0 - - xn = xm + coa * e1 - yn = ym + coa * e2 - -! --- Check whether new point belongs to volume - - ja = 0 - - call msho07( xn, yn, xstart, coor, kstapl, kstap, ja ) - - if ( ierror/=0 ) goto 1000 - -! --- Determine extra values for case that new point has to be placed - - if ( cdis > 1.2 * disold ) then - xnx = xm + coa * e1 - yny = ym + coa * e2 - else if ( cdis < 0.8 * disold ) then - xnx = xm + 0.7 * coa * e1 - yny = ym + 0.7 * coa * e2 - else - xnx = xm + 0.85 * coa * e1 - yny = ym + 0.85 * coa * e2 - end if - -! --- Check whether new point is allowed or is there a common -! point with another line - - call msho13( coor, i1, i2, kdrie, kstapl, kstap, xn, yn ) - -! --- Check for double crossinglines: - - if ( kdrie==-1 ) then - -! --- Double crossings: change array kstapl - - if ( debug ) then - write(irefwr,*) 'Check msho13: Double crossing: skip' - end if - call msho20(kstapl,kstap,itri) - nochan = nochan + 1 - goto 300 - end if - - if ( ierror/=0 ) goto 1000 - -! --- Check for impossible situation - - if ( ja==0 .and. kdrie==0 ) then - -! --- Rearrange, impossible - - xn = xn - dismin * 1d-3 + dismin * 1d-4 - yn = yn + dismin * 1d-3 + dismin * 1d-4 - - ja = 0 - call msho07( xn, yn, xstart, coor, kstapl, kstap, ja ) - - call msho13( coor, i1, i2, kdrie, kstapl, kstap, xn, yn ) - - if ( ja==0 .and. kdrie==0 .or. kdrie==-1 ) then - -! --- Really impossible, change - - if ( debug ) then - write(irefwr,*) 'Check msho13' - write(irefwr,*) 'Really impossible situation, skip' - write(irefwr,*) 'If your input is OK inform SEPRA' - end if - call msho20( kstapl, kstap, itri ) - nochan = nochan + 1 - goto 300 - end if - end if - if ( ierror/=0 ) goto 1000 - -420 if ( kdrie>0 ) then - -! --- Common point with line kdrie - - ii1 = kstapl( 2*kdrie - 1 ) - ii2 = kstapl( 2*kdrie ) - -! --- Triangle with one of these (old) points -! ( Check whether points are allowed ) - - jpn = 0 - - if ( ii1==i2 .and. surf2eps ) then - call msho10(kmeshc,nelem,i1,i2,ii2,kstapl, - + kstap,itri) - nochan = 0 - goto 300 - else if ( icheck>0 ) then - kdrie = icheck - goto 420 - end if - - end if - - end if - - if ( ii2==i1 .and. surf1eps ) then - call msho10(kmeshc,nelem,i1,i2,ii1,kstapl, - + kstap,itri) - nochan = 0 - goto 300 - else if ( icheck>0 ) then - kdrie = icheck - goto 420 - end if - - end if - - end if - - if ( ierror/=0 ) then - if ( debug ) write(irefwr,*) 'Halfway ierror =',ierror - goto 1000 - end if - - if ( i2/=ii1 .and. i1/=ii2 ) then - -! --- Point ii1 ? - - dist1 = rinfin - - dx = xnx - coor( 1,ii1 ) - dy = yny - coor( 2,ii1 ) - - dist1 = sqrt( dx*dx + dy*dy ) - jpn = ii1 - -! --- Point ii2 ? - - dx = xnx - coor( 1,ii2 ) - dy = yny - coor( 2,ii2 ) - - dist = sqrt( dx*dx + dy*dy ) - - if ( dist0 ) then - call msho19(coor,i1,i2,jpn,surf) - valare = ( chelp(icube(i1))+chelp(icube(i2)) )/2d0 - if ( nochanrinfin/2.) jpn = 0 - if ( jpn==iex2.and.surf2>rinfin/2.) jpn = 0 - end if - - iperm = 0 - if ( jpn>0 ) - + call msho28(coor,i1,i2,jpn,xn,yn,npoint,itri,iperm) - if ( iperm==1 ) jpn = 0 - - if ( jpn>0 ) then - call msho10(kmeshc,nelem,i1,i2,jpn,kstapl, - + kstap,itri) - nochan = 0 - - else - -! --- Change array kstapl - - call msho20(kstapl,kstap,itri) - nochan = nochan + 1 - end if - else - -! --- New point not to near to old point ? Run through array itri - - jpn = 0 - dista = 2. * coa - - call msho14(coor,jpn,npoint,itri,i1,i2,xnx,yny,dista) - - if ( dista>0.55d0 * coa ) jpn = 0 - - iperm = 0 - if ( jpn/=0 .and. inside==1 ) - + call msho28(coor,i1,i2,jpn,xn,yn,npoint,itri,iperm) - if ( iperm==1 ) then - call msho20(kstapl,kstap,itri) - nochan = nochan + 1 - goto 300 - end if - - if ( jpn/=0 .and. jpn/=iex1 .and. - + ipotn1==0 ) then - - call msho19(coor,iex1,i1,jpn,surf) - - valare = chelp(icube(i1)) - - if ( surf<0.15d0 * valare ) then - call msho20(kstapl,kstap,itri) - nochan = nochan + 1 - goto 300 - end if - - end if - - if ( jpn/=0 .and. jpn/=iex2 .and. - + ipotn2==0 ) then - - call msho19(coor,i2,iex2,jpn,surf) - - valare = chelp(icube(i2)) - - if ( surf<0.15d0 * valare ) then - call msho20(kstapl,kstap,itri) - nochan = nochan + 1 - goto 300 - end if - - end if - - inear = 0 - no = 0 - - if ( dista<0.55d0*coa ) then - inear = 1 - call msho24(kstapl,kstap,coor,i1,jpn,icheck) - if ( icheck/=0 ) no = 1 - call msho24(kstapl,kstap,coor,i2,jpn,icheck) - if ( icheck/=0 ) no = 1 - end if - - if ( jpn==0 ) then - ja = 0 - else - call msho19(coor,i1,i2,jpn,surf) - valare = ( chelp(icube(i1))+chelp(icube(i2)) )/2. - if ( nochan nx ) then - n1 = nx - end if - n2 = int ( (yny-ystart) / dism ) - if ( n2 < 0 ) then - n2 = 0 - else if ( n2 > ny - 1 ) then - n2 = ny - 1 - end if - - nc = 1 + n1 + n2*nx - - if ( nc>(nx*ny) ) then - write(irefwr,*) 'Error in msho2d' - write(irefwr,*) 'Please inform SEPRA' - write(irefwr,*) 'Execution NOT terminated' !AvD: do not stop -!AvD call instop - end if - - icube(npoint) = nc - - else - -! --- No solution found: change array kstapl - - call msho20(kstapl,kstap,itri) - nochan = nochan + 1 - end if - - end if - - if ( ierror/=0 ) then - if ( debug ) write(irefwr,*) 'Error: End of normal loop' - goto 1000 - end if - -! --- Array kstapl empty ? - - if ( kstap>0 ) goto 300 - -! --- Check itri (all entries of this array should by now be zero) - -500 itot = 0 - - if ( debug ) then - write(irefwr,*) 'Temporary output after label 500' - write(irefwr,*) 'nelem = ',nelem,'kstap = ',kstap - if ( nelem>0 ) then - write(irefwr,*) 'Listing of',nelem,'elements' - do i=1, nelem - write(irefwr,*) i,(kmeshc(i1,i),i1=1,3) - end do - write(irefwr,*) 'Output meshgeneration nodes' - write(irefwr,*) 'End msho2d with ',npoint,' nodes' - do i=1, npoint - write(irefwr,*) i,(coor(ja,i),ja=1,2) - end do - - write(irefwr,*) 'Array kbndpt: ( nbndpt = ',nbndpt,')' - write(irefwr,*) (kbndpt(i),i=1,nbndpt) - write(irefwr,*) 'Contents OK?' - end if - end if - - do i = 1, npoint - itot = itot + abs(itri(i)) - end do - - if ( itot/=0 ) then - write(irefwr,*) 'Error in connections array' - call errsub ( 903, 0, 0, 0 ) - end if - - if ( npoint>npunt ) then - call errint ( npoint, 1 ) - call errint ( npunt, 2 ) - call errsub ( 900, 2, 0, 0 ) - end if - - if ( nelem>nkmeshc ) then - call errsub ( 901, 0, 0, 0 ) - end if - if ( ierror/=0 ) goto 1000 - -! --- First solution found, save before extra actions: - - if ( nherha==0 ) then - -! --- Allocate space for helparrays coortmp and meshtmp: - -! --- Length coortmp is npoint: - - npndef = npoint + int(5 + npoint/10) - npntmp = npoint - -! --- Length meshtmp is nelem: - - neldef = nelem + int(5 + nelem/10) - neltmp = nelem - - allocate( coortmp( 2, npndef ) ) - allocate( meshtmp( 3, neldef ) ) - -! --- Fill helparrays temporary: -! --- Coordinates: - - do i = 1, npoint - coortmp(1,i) = coor(1,i) - coortmp(2,i) = coor(2,i) - end do - -! --- Elements: - do i = 1, nelem - meshtmp(1,i) = kmeshc(1,i) - meshtmp(2,i) = kmeshc(2,i) - meshtmp(3,i) = kmeshc(3,i) - end do - -! --- Determine characteristic ratiovalue for comparison reasons in -! the next steps: - - ratiop = rinfin - - do ielem = 1, nelem - i1 = kmeshc (1,ielem) - i2 = kmeshc (2,ielem) - i3 = kmeshc (3,ielem) - call msho33 ( coor, verh, i1, i2, i3 ) - call msho19 ( coor, i1, i2, i3, surf ) - if ( surf<0 ) then - verh = -verh - if ( debug ) then - write(irefwr,*) 'nherha = ',nherha - write(irefwr,*) 'verh = ',verh - write(irefwr,*) 'Triangle',ielem,' - ',i1,i2,i3 - end if - end if - ratiop = min( verh, ratiop ) - - end do ! ielem = 1, nelem - - if ( debug ) then - write(irefwr,*) 'End first subdivision, ratio = ',ratiop - end if - end if - -! --- Determine number of neighbours of points - -540 leng = nrepos - - do ih = 1, 3 - - call msho16(kmeshc,nelem,npoint,nipnt,itri,kstapl,leng) - -! --- Check length used - - if ( leng>nrepos ) then - call errsub ( 903, 0, 0, 0 ) - goto 1000 - end if - -! --- Remove internal points with three or four neighbours - - icancel = 1 - - do while ( icancel>0 ) - - icancel = 0 - - call msho29( kmeshc, nelem, npoint, itri, kstapl, nipnt, - + coor, icancel ) - - if ( ierror/=0 ) then - if ( debug ) write(irefwr,*) 'msho29 ierror =',ierror - goto 1000 - end if - -! --- Rearrange arrays COOR and KELEM - - do i = 1, npoint - itri(i) = 0 - end do - - do i = 1, nelem - i1 = kmeshc( 1,i ) - i2 = kmeshc( 2,i ) - i3 = kmeshc( 3,i ) - - itri(i1) = 1 - itri(i2) = 1 - itri(i3) = 1 - end do - - itot = 0 - - do i = 1, npoint - x = coor( 1,i ) - y = coor( 2,i ) - - if ( itri(i)==1 .or. i<=nipnt ) then - itot = itot + 1 - coor( 1,itot ) = x - coor( 2,itot ) = y - itri(i) = itot - end if - - end do - - ja = npoint - itot - npoint = itot - -! --- Renumber KELEM - - do i = 1, nelem - - i1 = kmeshc( 1,i ) - i2 = kmeshc( 2,i ) - i3 = kmeshc( 3,i ) - - kmeshc( 1,i ) = itri(i1) - kmeshc( 2,i ) = itri(i2) - kmeshc( 3,i ) = itri(i3) - end do - - end do ! while loop - - end do - -! --- Temporary for checking: -! if ( kstap==0 ) goto 900 - -! --- Check angles - - ifill = 0 - - do ielem = nelemi+1, nelem - - i1 = kmeshc( 1,ielem ) - i2 = kmeshc( 2,ielem ) - i3 = kmeshc( 3,ielem ) - -! --- Check all inside "diagonals": -! Start computing the angles of each triangle - - call msho03(i1,i2,coor,adis) - call msho03(i2,i3,coor,bdis) - call msho03(i3,i1,coor,cdis) - -! --- Check angles - - call msho22( adis, bdis, cdis, icase ) - - if ( icase>0 ) then - -! --- Triangle ielem has an angle that is larger than 90 degrees, -! try to change the diagonal - - ma = 1 - - jelem = ielem - - if ( icase==1 ) then - -! --- common line is i2 - i3 - - call msho26(kmeshc,nelem,i2,i3,jelem,i4) - -! --- Check whether i2-i3 is internal boundary: - - ja = 0 - call msho42( kinbnd,lenbnd, i2, i3, ja ) - if ( ja==1 ) i4 = 0 - if ( i4>0 .and. jelem/=ielem ) then - -! --- consider i1 - i2 - i3 - i4 - - j1 = i1 - call msho27(coor,i1,i2,i3,i4) - if ( j1/=i1 ) ifill = 1 - - j1 = i1 - j2 = i2 - j3 = i3 - j4 = i4 - else - ma = 0 - end if - else if ( icase==2 ) then - -! --- common line is i3 - i1 - - call msho26(kmeshc,nelem,i3,i1,jelem,i4) - -! --- Check whether i3-i1 is internal boundary: - - ja = 0 - call msho42( kinbnd, lenbnd, i3, i1, ja ) - if ( ja==1 ) i4 = 0 - if ( i4>0 .and. jelem/=ielem ) then - -! --- consider i2 - i3 - i1 - i4 - - j2 = i2 - call msho27(coor,i2,i3,i1,i4) - if ( j2/=i2 ) ifill = 1 - - j1 = i2 - j2 = i3 - j3 = i1 - j4 = i4 - else - ma = 0 - end if - else if ( icase==3 ) then - -! --- common line is i1 - i2 - - call msho26(kmeshc,nelem,i1,i2,jelem,i4) - -! --- Check whether i1-i2 is internal boundary: - - ja = 0 - call msho42( kinbnd, lenbnd, i1, i2, ja ) - if ( ja==1 ) i4 = 0 - if ( i4>0 .and. jelem/=ielem ) then - -! --- consider i3 - i1 - i2 - i4 - - j3 = i3 - call msho27(coor,i3,i1,i2,i4) - if ( j3/=i3 ) ifill = 1 - - j1 = i3 - j2 = i1 - j3 = i2 - j4 = i4 - else - ma = 0 - end if - end if - -! --- Refill element array - - if ( ma>0 ) then - kmeshc( 1,ielem ) = j1 - kmeshc( 2,ielem ) = j2 - kmeshc( 3,ielem ) = j3 - - kmeshc( 1,jelem ) = j2 - kmeshc( 2,jelem ) = j4 - kmeshc( 3,jelem ) = j3 - end if - end if - end do - - if ( ierror/=0 ) then - write(irefwr,*) 'Just past angle checking, ierror =',ierror - goto 1000 - end if - -! --- Check this mesh (all diagonals should are optimal now) - - dismin = rinfin - - do ielem = 1, nelem - i1 = kmeshc (1,ielem) - i2 = kmeshc (2,ielem) - i3 = kmeshc (3,ielem) - call msho33 ( coor, verh, i1, i2, i3 ) - call msho19 ( coor, i1, i2, i3, surf ) - if ( surf<0 ) then - verh = -verh - if ( debug ) then - write(irefwr,*) 'nherha = ',nherha - write(irefwr,*) 'verh = ',verh - write(irefwr,*) 'Triangle',ielem,' - ',i1,i2,i3 - end if - end if - dismin = min( verh, dismin ) - end do ! ielem = 1, nelem - -! --- Check whether this mesh is better: - - if ( dismin>ratiop ) then - -! --- Better mesh: - - if ( debug ) then - write(irefwr,*) 'ratio new mesh (diagonals) ',dismin - write(irefwr,*) 'ratio',dismin,'>old ratio',ratiop - write(irefwr,*) 'safe the better one' - end if - -! --- Use "best" mesh: -! Set equal to new number of points: - - npntmp = npoint - - if ( npntmp>npndef ) then - write(irefwr,*) 'Error in allocation temporary pointsarray' - write(irefwr,*) 'Please inform SEPRA' - write(irefwr,*) 'Execution stopped' - go to 1000 - end if - -! --- Coordinates: - - do i = 1, npoint - coortmp(1,i) = coor(1,i) - coortmp(2,i) = coor(2,i) - end do - -! --- Set number of elements: - - neltmp = nelem - if ( neltmp>neldef ) then - write(irefwr,*) 'Error in allocation temporary elemarray' - write(irefwr,*) 'Please inform SEPRA' - write(irefwr,*) 'Execution stopped' - go to 1000 - end if - -! --- Elements: - - do i = 1, nelem - meshtmp(1,i) = kmeshc(1,i) - meshtmp(2,i) = kmeshc(2,i) - meshtmp(3,i) = kmeshc(3,i) - end do - - ratiop = dismin - end if - - if ( debug .and. icount>=idebug ) then - write(irefwr,*) 'extra check, kstap, npoint, icount ', - + kstap, npoint , icount - call msho08 ( kstapl, kstap, coor, xstart, dismin, - + holeinfo, nholes, .true. ) - -! --- The next statements can be used if the process "hangs" - - write(irefwr,*) 'kstap, nochan,nelem ', kstap, nochan,nelem - end if - -! --- If convergence seems to be difficult and results are "acceptable" -! return - - if ( reposition .and. ( nherha>10 .and. ifill==0 ) .or. - + nherha>20 ) goto 900 - -! --- Repositioning - - nherha = nherha + 1 - leng = nrepos - - call msho16(kmeshc,nelem,npoint,nipnt,itri,kstapl,leng) - - if ( leng>nrepos ) then - write(irefwr,*) 'Just after msho16',leng,'>',nrepos - call errsub ( 903, 0, 0, 0 ) - goto 1000 - end if - - coa = dismin - - ! call msho18(kmeshc,nelem,coor,npoint,nipnt,itri,kstapl,coa) ! Perform a Laplacian repositioning of the nodes - - if ( debug .and. icount>=idebug ) then - jtimes = 1 - jtimes = 3 - jtimes = 0 - call msho08 ( kstapl, kstap, coor, xstart, dismin, - + holeinfo, nholes, .true. ) - -! --- The next statements can be used if the process "hangs" - - write(irefwr,*) 'kstap, nochan,nelem ', kstap, nochan,nelem - end if - -! --- Check result of Repositioning - - do i = nelemi+1, nelem - i1 = kmeshc( 1,i ) - i2 = kmeshc( 2,i ) - i3 = kmeshc( 3,i ) - -! --- Check only triangles that are fully inside: - - if ( i1>nipnt .and. i2>nipnt .and. i3>nipnt ) then - - call msho19(coor,i1,i2,i3,surf) - - valare = chelp(icube(i1))+chelp(icube(i2))+chelp(icube(i3)) - valare = valare / 3d0 - - if ( surf<0d0 .or. - + surf<0.1d0 * valare .and. nherha<50 .or. - + surf>1.0d1 * valare .and. nherha<50 ) then - -! --- Redivision for this triangle - - ielem = i - - call msho30( kmeshc, nelem, ielem, kstapl, kstap, npoint, - + itri , nelemi ) - -! --- Make a new division for this array kstapl - - if ( icount>=idebug ) then - - write(irefwr,*) 'nherha, leng ', nherha, leng - call msho08 ( kstapl, kstap, coor, xstart, dismin, - + holeinfo, nholes, .true. ) - -! --- The next statements can be used if the process "hangs" - - write(irefwr,*) 'kstap, nochan,nelem ', - + kstap, nochan,nelem - end if - - goto 300 - - end if - - end if - - end do - - if ( ierror/=0 ) then - if ( debug ) - + write(irefwr,*) 'Just before redivision, ierror =',ierror - goto 1000 - end if - -! --- No redivision needed, check again for points with four neighbours - - ja = 0 - - do i = nipnt+1,npoint - no = itri(i) - itri(i-1) - if ( no<5 ) ja = 1 - end do - - if ( debug ) write(irefwr,*) 'At the end of loop nherha = ',nherha - - if ( nherha<5 .or. ja==1 .or. ifill==1 ) goto 540 - -900 continue - -! --- Ready, no error, but check before leaving whether the temporary -! mesh as stored, is better by comparison of the ratio-values: - - dismin = rinfin - - do ielem = 1, nelem - - i1 = kmeshc(1,ielem) - i2 = kmeshc(2,ielem) - i3 = kmeshc(3,ielem) - call msho33 ( coor, verh, i1, i2, i3 ) - call msho19 ( coor, i1, i2, i3, surf ) - - if ( surf<0 ) verh = -verh - - dismin = min(verh,dismin) - - end do ! ielem = 1, nelem - -! --- Compare - - if ( debug ) then - write(irefwr,*) 'Check of last mesh' - write(irefwr,*) 'ratiop = ',ratiop - write(irefwr,*) 'dismin = ',dismin - write(irefwr,*) 'nherha = ',nherha - end if - - if ( dismin0 ) then - -! --- Information statements: - - write(irefwr,*) - + 'End msho2d: Check barycenters of',nelem,'elements' - iperm = 0 - call msho40 ( coor, kmeshc, npoint, nelem, iperm ) - write(irefwr,*) 'Ready with check, iperm = ',iperm - -! --- Compute total surface of all elements and check for negative -! values: - - surf = 0 - - do i = 1, nelem - i1 = kmeshc( 1,i ) - i2 = kmeshc( 2,i ) - i3 = kmeshc( 3,i ) - -! --- Check triangle and add surface: - - call msho19(coor,i1,i2,i3,surf1) - - if ( surf1<0 ) then - write(irefwr,*) 'error,surface',i1,i2,i3,'neg = ',surf1 - end if - - surf = surf + surf1 - - end do - - write(irefwr,*) 'Surface (all elements added) is ',surf - - write(irefwr,*) 'kstap = ',kstap - - if ( kstap>0 ) then - write(irefwr,*) 'kstap =',kstap,' end msho2d' - write(irefwr,*) (kstapl(i),i=1,2*kstap) - end if - - write(irefwr,*) 'Output meshgeneration elements and nodes' - write(irefwr,*) 'End msho2d with ',npoint,' nodes' - do i=1, npoint - write(irefwr,*) i,(coor(ja,i),ja=1,2) - end do - - write(irefwr,*) 'ok? ' - write(irefwr,*) 'End msho2d' - write(irefwr,*) 'Number of elements = ', nelem - write(irefwr,*) 'Contents array kbndpt, value nbndpt = ',nbndpt - write(irefwr,*) (kbndpt(i),i=1,nbndpt) - - end if - -! --- Check all triangles of this surface for the ratio-value: - - dismin = rinfin - ratiop = 0 - - do ielem = 1, nelem - - i1 = kmeshc(1,ielem) - i2 = kmeshc(2,ielem) - i3 = kmeshc(3,ielem) - call msho33 ( coor, verh, i1, i2, i3 ) - ratiop = ratiop + abs(verh) - - dismin = min(verh,dismin) - - end do ! ielem = 1, nelem - - if ( debug ) then - -! --- Compute mean value: - - ratiop = ratiop/nelem - write(irefwr,*) 'Smallest ratio in mesh =',dismin - write(irefwr,*) 'Mean ratio in mesh = ',ratiop - - end if - -! --- Check whether values have been changed and act accordingly: - - if ( maxratio>1d0 .and. dismin<0.15d0 ) then - -! --- Suggest new values for the coarsenesses of the userpoints - - write(irefwr,*) 'Bad-shaped elements found in surface',isurnr - write(irefwr,*) 'smallest ratiovalue = ',dismin - write(irefwr,*) 'Use eventually the following coarseness' - write(irefwr,*) 'values for the',nuspnt,'submitted userpoints' - do i=2, nuspnt+1 - write(irefwr,*) 'node',i-1,'coarseness',coaval(i) - end do - end if - -! --- Delete the temporary helparrays - -950 deallocate( userco ) - deallocate( coaval ) - deallocate( chelp ) - deallocate( cube ) - deallocate( icube ) - deallocate( itri ) - deallocate( jcube ) - deallocate( kstapl ) - - if ( neltmp>0 ) then - deallocate( coortmp ) - deallocate( meshtmp ) - end if - - if ( lenbnd>0 ) deallocate ( kinbnd ) - -! --- Close - -1000 call erclos( 'msho2d' ) - - end diff --git a/extern/sepran/msho30.for b/extern/sepran/msho30.for deleted file mode 100644 index d29ab8a86..000000000 --- a/extern/sepran/msho30.for +++ /dev/null @@ -1,266 +0,0 @@ - subroutine msho30 ( kelem, nelem, ielem, kstapl, kstap, npoint, - + itri , nelmfix) -! ====================================================================== -! -! programmer Niek Praagman -! version 3.3 date 09-04-2009 use nelmfix i.s.o. nelemi -! version 3.2 date 18-03-2005 Extra parameter nelemi -! version 3.1 date 15-02-2005 Update -! version 3.0 date 11-01-2005 Remove nipnt -! version 2.1 date 14-08-2002 Consider Plaxis boundaries -! version 2.0 date 28-01-1994 Complete new version -! version 1.1 date 19-02-1993 New layout -! version 1.0 date 13-06-1989 -! -! copyright (c) 1989-2009 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Subroutine to refill arrays KSTAPL and ITRI after a Repositioning -! error -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! ********************************************************************** -! -! MODULES USED -! - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer kelem(3,*), nelem, ielem, kstapl(2,*), kstap, - + npoint, itri(*), nelmfix - -! ielem i element to be cancelled -! itri o indicator whether point i is in boundary or not -! kelem i/o New KMESH part c with respect to the surface elements -! All elements have the same number of nodes -! kstap o number of line segments in KSTAP -! kstapl o new array of boundary segments -! nelem i/o Number of elements -! nelmfix i Number of elements that is fixed -! npoint i Number of nodal points -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer i, ia, ib, ic, nextra, i1, i2, i3, j1, j2, jp, jtal, - + iaan, is - -! i counting variable -! i1 help node number -! i2 help node number -! i3 help node number -! ia node number of triangle to be considered -! iaan indicator whether segment has been cancelled or not -! ib node number of triangle to be considered -! ic node number of triangle to be considered -! is counting variable -! j1 segment node -! j2 segment node -! jp indicator whether element should be reconsidered -! or not -! jtal temporary number of segments in kstapl -! nextra number of elements which are not cancelled -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! none -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! determine the three node numbers of the triangle to be cancelled -! run through all elements -! if element has at least one node in common with triangle -! cancel element and fill the three segments in kstapl -! refill itri -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Determine the three node numbers of the triangle to be skipped - - ia = kelem( 1, ielem ) - ib = kelem( 2, ielem ) - ic = kelem( 3, ielem ) - -! --- Set parameters KSTAP and NEXTRA - - kstap = 0 - nextra = nelmfix - -! --- Run through all elements that have at least one point in common -! with the triangle - - do i = nelmfix + 1 , nelem - - i1 = kelem( 1, i ) - i2 = kelem( 2, i ) - i3 = kelem( 3, i ) - - jp = 0 - - if ( i1==ia .or. i1==ib .or. i1==ic ) jp = 1 - if ( i2==ia .or. i2==ib .or. i2==ic ) jp = 1 - if ( i3==ia .or. i3==ib .or. i3==ic ) jp = 1 - - if ( jp==1 ) then - -! --- add three line segments to kstapl -! start with i1 - i2 - - if ( i1<=-1 .and. i2<=-1 ) then - - kstap = kstap + 1 - kstapl( 1, kstap ) = i1 - kstapl( 2, kstap ) = i2 - - else - -! --- Check whether i1 - i2 already belongs to kstapl - - jtal = 0 - iaan = 0 - - do is = 1, kstap - j1 = kstapl( 1, is ) - j2 = kstapl( 2, is ) - if ( j1==i2 .and. j2==i1 ) then - -! --- do nothing, i.e. skip segment - - iaan = 1 - else - jtal = jtal + 1 - kstapl( 1, jtal ) = j1 - kstapl( 2, jtal ) = j2 - end if - end do - if ( iaan==0 ) then - -! --- add segment - - jtal = jtal + 1 - kstapl( 1, jtal ) = i1 - kstapl( 2, jtal ) = i2 - end if - kstap = jtal - end if - -! --- next check whether i2 - i3 already belongs to kstapl - - jtal = 0 - iaan = 0 - - do is = 1, kstap - j1 = kstapl( 1, is ) - j2 = kstapl( 2, is ) - if ( j1==i3 .and. j2==i2 ) then - -! --- do nothing, i.e. skip segment - - iaan = 1 - else - jtal = jtal + 1 - kstapl( 1, jtal ) = j1 - kstapl( 2, jtal ) = j2 - end if - end do - if ( iaan==0 ) then - -! --- add segment - - jtal = jtal + 1 - kstapl( 1, jtal ) = i2 - kstapl( 2, jtal ) = i3 - end if - kstap = jtal - -! --- finally check whether i3 - i1 already belongs to kstapl - - jtal = 0 - iaan = 0 - - do is = 1, kstap - j1 = kstapl( 1, is ) - j2 = kstapl( 2, is ) - if ( j1==i1 .and. j2==i3 ) then - -! --- do nothing, i.e. skip segment - - iaan = 1 - else - jtal = jtal + 1 - kstapl( 1, jtal ) = j1 - kstapl( 2, jtal ) = j2 - end if - end do - if ( iaan==0 ) then - -! --- add segment - - jtal = jtal + 1 - kstapl( 1, jtal ) = i3 - kstapl( 2, jtal ) = i1 - end if - kstap = jtal - - else - -! --- triangle is outside interesting area - - nextra = nextra + 1 - kelem( 1, nextra ) = i1 - kelem( 2, nextra ) = i2 - kelem( 3, nextra ) = i3 - end if - end do - nelem = nextra - -! --- Refill array ITRI - - do i = 1 , npoint - itri(i) = 0 - end do - - do i = 1 , kstap - - i1 = kstapl( 1, i ) - i2 = kstapl( 2, i ) - - itri(i1) = itri(i1) + 1 - itri(i2) = itri(i2) + 1 - - end do - - end diff --git a/extern/sepran/msho31.for b/extern/sepran/msho31.for deleted file mode 100644 index 54a470967..000000000 --- a/extern/sepran/msho31.for +++ /dev/null @@ -1,413 +0,0 @@ - subroutine msho31 ( coor, npoint, kelem, nelem, kbound, nbn, - + extquanodes ) -! ====================================================================== -! -! programmer Niek Praagman -! version 3.2 date 29-10-2010 Dynamic allocation helparrays -! version 3.1 date 15-07-2009 Quadratic internal lines allowed -! version 3.0 date 15-02-2005 Update -! -! copyright (c) 1990-2010 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Create quadratic triangles in case of an existing -! linear triangular SEPRAN mesh as given in array KELEM. -! ********************************************************************** -! -! KEYWORDS -! -! 2d -! mesh_generation -! triangle -! quadratic -! ********************************************************************** -! -! MODULES USED -! - use mshdummymethods - use mshconstants - use msherror - - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cconst' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision coor(*) - integer npoint, kelem(*), nelem, nbn, kbound(*), extquanodes(*) - -! coor i/o coordinates array -! extquanodes i helparray for quadratic internal line elements -! kbound i array containing the endnodes of the boundary -! elements (length 2*nbn) -! kelem i,o array containing the triangular linear elements -! at input and quadratic at output -! nbn i number of boundary elements -! nelem i number of elements -! npoint i,o at input total number of points in triangular -! linear mesh, at output inj quadratic mesh -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer error, i, ip(6), meshtp, nummer, iextra, jstart, jstend, - + ii, ibrp, itotal, npnold, ibrlen, npt, nbr, ia, ib, - + ileng - integer, allocatable, dimension(:) :: istart - integer, allocatable, dimension(:) :: ibrpnt - integer, allocatable, dimension(:) :: kelemh - -! error Return value of allocate or deallocate -! i loop variable -! ia first node -! ib second node -! ibrlen declared length of neighbour array -! ibrp guess of number of neighbours for each point -! ibrpnt helparray containing the neighbours of each point -! iextra helpvariable for case of more than five neighbours -! ii loop variable -! ileng length helparray for quadratic case -! ip array to store node numbers -! istart helparray with starting positions for each node in ibrpnt -! itotal total number of nodes -! jstart start of do variable for neighbours -! jstend end of do variable for checking neighbours -! kelemh helparray used if node has more than five neighbours -! meshtp element type according to SEPRAN rules -! nbr number of neighbours -! npnold old number of points (before creation of quadratic -! elements) -! npt helpvariable for number of positions -! nummer helpvariable for new points -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERALLOC Produce error message in case allocate went wrong -! ERCLOS Resets old name of previous subroutine of higher level -! ERDEALLOC Produce error message in case deallocate went wrong -! EROPEN Produces concatenated name of local subroutine -! ERRINT Put integer in error message -! ERRSUB Error messages -! MSH401 Run through group of elements to determine neighbours -! MSH402 Place nodes of one line in neighbour array -! MSH403 Determine number refinement point in line piece -! MSH406 Place quadratic triangle in element array -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! 1274 Error extra points not recognized -! 1275 Not enough space reserved for neighbours -! ********************************************************************** -! -! PSEUDO CODE -! -! Create quadratic elements and needed points in two steps -! First place the old already existing midpoints in array ibrpnt -! next create the new points and place in ibrpnt -! finally determine the new elements -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen ( 'msho31' ) - -! --- Allocate space for helparrays - - allocate ( istart(npoint+1), ibrpnt((npoint+1)*10), - + kelemh(npoint), stat = error ) - if ( error/=0 ) call eralloc ( error, 12*npoint+11, 'istart' ) - if ( ierror/=0 ) go to 1000 - - istart = 0 ! Clear array istart - ibrpnt = 0 ! Clear array ibrpnt - - ibrp = 10 - -! --- Set used length kelemh - - kelemh(1) = 0 - -! --- Special value for meshtp - - meshtp = 3 - -! --- Fill arrays - - call msh401( npoint, kelem, nelem, istart, ibrp, ibrpnt, kelemh, - + meshtp, 3 , 1 , 0 , 0 ) - -! --- Make shift in array for all neighbour points - - iextra = 0 - nummer = 0 - -! --- First skip all empty places - - do i = 1 , npoint - jstart = ibrp * (i-1) + 1 - jstend = ibrp * i - do ii = jstart, jstend - if ( ibrpnt(ii)/=0 ) then - -! --- Place neighbour point - - nummer = nummer + 1 - ibrpnt(nummer) = ibrpnt(ii) - end if - end do - end do - -! --- Keep total number - - itotal = nummer - -! --- Number of positions needed in ibrpnt is 2 * nummer and number of -! positions declared is ibrlen - - ibrlen = ibrp * ( npoint + 1 ) - -! --- Check length - - if ( ibrlen<2 * nummer ) then - -! --- Error, not enough positions - - call errint ( 2*nummer, 1 ) - call errint ( ibrlen , 2 ) - call errsub ( 1275, 2, 0, 0 ) - go to 1000 - end if - -! --- Make shift - - npt = ibrlen - -! --- Run through all basis nodes - - do i = npoint, 1, -1 - -! --- Determine number of neighbours of i - - nbr = istart(i) - -! --- Check for extra points - - if ( nbr>ibrp ) then - -! --- There are extra points - - iextra = 1 - -! --- Make reservation of positions - - do ib = 1 , nbr-ibrp - ibrpnt(npt) = 0 - npt = npt - 1 - end do - -! --- Add to itotal - - itotal = itotal + nbr - ibrp - nbr = ibrp - end if - - do ib = 1 , nbr - ibrpnt( npt ) = ibrpnt( nummer ) - npt = npt - 1 - nummer = nummer - 1 - end do - - if ( nptibrlen ) then - call errint ( 2*nummer, 1 ) - call errint ( ibrlen , 2 ) - call errsub ( 1275, 2, 0, 0 ) - go to 1000 - end if - -! --- Set number of points for copiing later - - itotal = istart(npoint+1)-1 - - do i = 2, npoint+1 - istart(i) = 2 * istart(i)-1 - end do - -! --- Make place for new nodes - - do i = itotal, 1, -1 - ibrpnt(2*i ) = 0 - ibrpnt(2*i-1) = ibrpnt(i) - end do - -! --- Place new nodal-point numbers -! first the old numbers have to be placed again (determine the number -! while realizing that several gaps may exist in the boundary) - - do i = 1 , nbn - ip(1) = kbound( 2*i - 1 ) - ip(2) = kbound( 2*i ) - ip(3) = ip(1) + 1 - if ( ip(1)0 .and. ip(3)==0 ) then - -! --- Place new point and compute coordinates - - npoint = npoint + 1 - ibrpnt( ii+1 ) = npoint - coor(2*npoint-1)=(coor(2*i-1)+coor(2*ip(2)-1)) / 2d0 - coor(2*npoint )=(coor(2*i )+coor(2*ip(2) )) / 2d0 - end if - end do - end do - -! --- Create the new elements - - do i = nelem , 1 , -1 - ip(1) = kelem( 3*i - 2 ) - ip(3) = kelem( 3*i - 1 ) - ip(5) = kelem( 3*i ) - call msh403( npnold, ip(1), ip(3), ibrpnt, istart, ip(2) ) - call msh403( npnold, ip(3), ip(5), ibrpnt, istart, ip(4) ) - call msh403( npnold, ip(5), ip(1), ibrpnt, istart, ip(6) ) - call msh406( kelem, i, - + ip(1), ip(2), ip(3), ip(4), ip(5), ip(6) ) - end do - -! --- Finally deallocate helparrays - - deallocate( istart, ibrpnt, kelemh, stat = error ) - if ( error/=0 ) call erdealloc ( error, 'istart' ) - -! --- Close routine - -1000 call erclos ( 'msho31' ) - - end diff --git a/extern/sepran/msho32.for b/extern/sepran/msho32.for deleted file mode 100644 index 9fc5d61ed..000000000 --- a/extern/sepran/msho32.for +++ /dev/null @@ -1,98 +0,0 @@ - subroutine msho32 ( kelem, nelem, inpelm, npunt ) -! ====================================================================== -! -! programmer Niek Praagman -! version 3.0 date 15-02-2005 Update -! version 2.0 date 21-02-1994 New norms -! version 1.0 date 12-04-1991 -! -! copyright (c) 1991-2005 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Recreate a triangular mesh from quadratic triangles. -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! recreation -! ********************************************************************** -! -! MODULES USED -! - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer kelem(*), nelem, inpelm, npunt - -! inpelm i number of nodes in one element -! kelem i,o array containing the triangular quadratic elements -! at input and the linear ones at output -! nelem i number of elements -! npunt o highest point number in triangular mesh -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer i, j1, j2 - -! i loop variable -! j1 local pointer -! j2 local pointer -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! trivial -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Run through array kelem to make linear triangles - - do i = 1 , nelem - j1 = 3 * ( i - 1 ) - j2 = inpelm * ( i - 1 ) - kelem( j1 + 1 ) = kelem( j2 + 1 ) - kelem( j1 + 2 ) = kelem( j2 + 3 ) - kelem( j1 + 3 ) = kelem( j2 + 5 ) - end do - -! --- Find highest node number - - npunt = 0 - do i = 1 , 3 * nelem - if ( kelem(i)>npunt ) npunt = kelem(i) - end do - end diff --git a/extern/sepran/msho33.for b/extern/sepran/msho33.for deleted file mode 100644 index 1da566ccb..000000000 --- a/extern/sepran/msho33.for +++ /dev/null @@ -1,126 +0,0 @@ - subroutine msho33 ( coor, ratio, i1, i2, i3 ) -! ====================================================================== -! -! programmer Niek Praagman -! version 1.0 date 17-01-2007 -! -! copyright (c) 2007-2007 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Determine the ratio (2*Rout/Rin) for all triangles of the mesh -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! radius -! 2d -! ********************************************************************** -! -! MODULES USED -! - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer i1, i2, i3 - double precision ratio, coor(2,*) - -! coor i array with coordinates of nodes -! i1 i first node of triangle -! i2 i second node of triangle -! i3 i third node of triangle -! ratio o 2 * radius divided by radius outer circle -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision opp, ri, ro, s, s1, s2, s3, - + x1, x2, x3, y1, y2, y3 - -! opp surface -! ri radius inner circle -! ro radius outer circle -! s helpvariable to store sum of length of sides -! s1 euclidian distance side 1 -! s2 euclidian distance side 2 -! s3 euclidian distance side 3 -! x1 x-coordinate node 1 -! x2 x-coordinate node 2 -! x3 x-coordinate node 3 -! y1 y-coordinate node 1 -! y2 y-coordinate node 2 -! y3 y-coordinate node 3 -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! trivial -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Determine coordinates - - x1 = coor(1,i1) - y1 = coor(2,i1) - - x2 = coor(1,i2) - y2 = coor(2,i2) - - x3 = coor(1,i3) - y3 = coor(2,i3) - -! --- Determine length of the three sides: - - s1 = sqrt( (x2-x1)*(x2-x1) + (y2-y1)*(y2-y1) ) - s2 = sqrt( (x3-x2)*(x3-x2) + (y3-y2)*(y3-y2) ) - s3 = sqrt( (x1-x3)*(x1-x3) + (y1-y3)*(y1-y3) ) - - s = 0.5 * ( s1 + s2 + s3 ) - -! --- Calculate the surfacearea of the triangle: - - opp = sqrt( s * ( s - s1 ) * ( s - s2 ) * ( s - s3 ) ) - -! --- Calculate the values of the radii of outer and inner circle: - - ro = ( s1 * s2 * s3 ) / ( 4 * opp ) - - ri = opp / s - -! --- Finally determine the ratio value: - - ratio = 2 * ri / ro - - end diff --git a/extern/sepran/msho34.for b/extern/sepran/msho34.for deleted file mode 100644 index d936887f3..000000000 --- a/extern/sepran/msho34.for +++ /dev/null @@ -1,270 +0,0 @@ - subroutine msho34( kpoint, coor , ncurvs, curves, - + kbndpt, nbndpt, numcurvboun, - + boundary, nbound, nholes, userco, nuspnt, - + coaval, ius1, ius2 ) -! ====================================================================== -! -! programmer niek praagman -! version 1.1 date 07-12-2009 Determination istart adjusted -! version 1.0 date 10-11-2009 -! -! copyright (c) 2009-2009 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Subroutine to determine begin- and end user point of curve on -! which node kpoint is situated. -! In node kpoint special coarseness is required. -! Compute new coarsenesses for begin and end point of curve -! ********************************************************************** -! -! KEYWORDS -! -! mesh -! mesh_generation -! 2d -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -!AvDtmp include 'SPcommon/cmcdpr' -!AvDtmp include 'SPcommon/cmcdpi' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer kpoint, ncurvs, curves(ncurvs), numcurvboun, - + boundary(2,*),nbound, nholes, nbndpt, kbndpt(nbndpt), - + nuspnt, ius1, ius2 - double precision coor(2,*), userco(2,nuspnt), - + coaval(nuspnt+1) - -! boundary i array containing start and end nodes boundary curves -! coaval i array with first the user given unity of coarseness -! and from position 2 to nuspnt+1 the coarsenesses -! of all prescribed user points -! coor i coordinate array -! curves i array with number of nodes for each internal curve -! ius1 i start node curve -! ius2 i end node curve -! kbndpt i array containing numbers of all boundary points on -! all boundary curves, internal curves included -! kpoint i nodepoint with too large coarseness -! nbound i number of nodes in boundary curves - 1 -! nbndpt i length of boundary array kbndpt -! ncurvs i number of internal curves -! nholes i number of holes in boundary -! numcurvboun i number of boundary curves -! nuspnt i number of userpoints given by user -! userco i coordinate array userpoints -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision :: afst, dis, xt, yt, xst, yst, xen, yen, xk, yk - - integer :: i, istart, j, k, n1, n2 - - logical :: debug, found - -! afst local distance between sequential nodes -! debug indicator for debugging -! dis Euclidian distance -! found indicator for finding position -! i loop variable -! istart helpvariable to find discontinuties -! j loop variable -! k loop variable -! n1 help variable to determine ref number of node -! n2 help variable to determine reference number of node -! xen x-coordinate -! xk x-coordinate -! xst x-coordinate -! xt x-coordinate -! yen y-coordinate -! yk y-coordinate -! yst y-coordinate -! yt y-coordinate -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Set debug and found - - debug = .false. - found = .false. - -! debug = .false. - -! --- Coarseness problems in node kpoint. Coordinates are: - xk = coor(1,kpoint) - yk = coor(2,kpoint) - if ( debug ) then - write(irefwr,*) 'Debug info from msho34' - write(irefwr,*) 'Node considered',kpoint,'has crds',xk,yk - end if - -! --- Check contents of all submitted curves and nodes -! and give warning for coarseness value - istart = 0 - - xst = 9999d0 - yst = 9999d0 - - xen = 9999d0 - yen = 9999d0 - -! --- Determine start and endpoint of the curve on which kpoint is -! situated: - - if ( debug ) then - write(irefwr,*) 'Contents array boundary' - write(irefwr,*) 'Number of curves is numcurvboun',numcurvboun - do i = 1, numcurvboun - n1 = boundary(2,i) - n2 = boundary(2,i+1) - write(irefwr,*) 'curve',i,'nodepos',n1,'-',n2 - end do - write(irefwr,*) 'Contents array',kbndpt - do i=1,nbndpt - write(irefwr,*) 'pos',i,'value',kbndpt(i) - end do - end if - - i = 0 - do while ( .not.found .and. in1+1 ) then - n2 = n2 - 1 - istart = 0 - end if - - if ( debug ) then - write(irefwr,*) 'Curve number',boundary(1,i) - write(irefwr,*) 'Nodes sequentially',n1,'up to',n2 - end if - - !debug = .false. - do j = n1, n2 - if ( kpoint == kbndpt(j) ) then - if ( debug ) write(irefwr,*) 'On boundary-line',i - xst = coor(1,kbndpt(n1)) - yst = coor(2,kbndpt(n1)) - xen = coor(1,kbndpt(n2)) - yen = coor(2,kbndpt(n2)) - found = .true. - !write(irefwr,*) 'Found on line',n1,'- ',n2,'ready' - end if - end do - - end do - -! --- If not yet found: internal curves? - i = 0 - - do while ( .not. found .and. i0 ) then - - kstapl(1, kstap) = npn - kstapl(2, kstap) = npoint + 1 - - kstap = kstap + 1 - kstapl(1, kstap) = npoint + 1 - kstapl(2, kstap) = npn - - if ( istep==2 ) then -! --- Extra for neighbours array - - extquanodes(ibound+1) = npn - extquanodes(ibound+2) = npoint - extquanodes(ibound+3) = npoint+1 - - ibound = ibound + 3 - end if - - else - - kstapl(1, kstap) = npoint + 1 - istep - kstapl(2, kstap) = npoint + 1 - - kstap = kstap + 1 - kstapl(1, kstap) = npoint + 1 - kstapl(2, kstap) = npoint + 1 - istep - - if ( istep==2 ) then -! --- Extra for neighbours array - - extquanodes(ibound+1) = npoint - 1 - extquanodes(ibound+2) = npoint - extquanodes(ibound+3) = npoint + 1 - - ibound = ibound + 3 - end if - - end if - - end do - -! --- Add last node of line to coor array and fill -! kbndpt accordingly: - - j = nnodes + curves(i) - - x = cocurvs(1,j) - y = cocurvs(2,j) - - npn = 0 - -! --- Check nodes so far: - - do iext = 1 , npoint-1 - - dx = x - coor(1,iext) - dy = y - coor(2,iext) - - dis = sqrt(dx*dx + dy*dy) - - if ( dis0 ) then - coa = cube ( i ) - isml = i - end if - end do - -! --- Set smallest value: - - csmall = cube(isml) - - coa = 0d0 - - do i = 1, nx * ny -! --- Check each cube - if ( cube(i)>coa .and. jcube(i)>0 ) then - coa = cube ( i ) - ilrg = i - end if - end do - -! For future use??? -! clarge = cube(ilrg) - -! --- If Debug determine coordinates of these cubes: - if ( debug ) then - write(irefwr,*) 'nx = ',nx,' en ny = ',ny - write(irefwr,*) 'stepsize dist = ',dist - write(irefwr,*) 'xstart = ',xstart,'ystart = ',ystart - write(irefwr,*) 'xend = ',xstart+nx*dist,'yend = ', - + ystart+ny * dist - write(irefwr,*) 'en de y max = ',ystart+ny*dist - -! --- Compute n1 and n2 for cube with smallest coarseness: - n2 = int( isml/nx ) - n1 = isml - 1 - n2 * nx - - write(irefwr,*) 'Cube smallest coarseness' - write(irefwr,*) 'x- and y-coordinates centre of cube:' - write(irefwr,*) ' x=',xstart+(n1+0.5)*dist - write(irefwr,*) ' y=',ystart+(n2+0.5)*dist - -! --- Compute n1 and n2 for cube with largest coarseness: - n2 = int( ilrg/nx ) - n1 = ilrg - 1 - n2 * nx - - write(irefwr,*) 'Cube largest coarseness' - write(irefwr,*) 'coordinates:' - write(irefwr,*) ' x=',xstart+(n1+0.5)*dist - write(irefwr,*) ' y=',ystart+(n2+0.5)*dist - - end if - -! --- Check all local linepieces, running along -! the boundary - -! --- Initialize locbound array - do i = 1, numcurvboun - locbound(i) = 0 - end do - - istart = 1 - -! --- Eventually (not used now) check the boundary of this domain - if ( istart<0 ) then - - do i = 1, kstap - - i1 = kstapl(1,i) - i2 = kstapl(2,i) - - if ( i maxratio .or. dx1/dx2 > maxratio ) then -! --- Coarseness problems in node i2: - - write(irefwr,*) 'Problem for node',i2,'with crds',x2,y2 -! --- Find curve number for node i2: - do j = 1 , numcurvboun - write(irefwr,*) j,boundary(1,j),boundary(2,j) -! --- Find positions in boundary - n1 = boundary(2,j) - if ( j==numcurvboun) then - n2 = nbndpt - else - n2 = boundary(2,j+1) - end if - write(irefwr,*) 'Curve',boundary(1,j), 'Nodes' - do k = n1, n2 - xt = coor(1,k) - yt = coor(2,k) - write(irefwr,*) 'Node',kbndpt(k),xt,yt - - if ( i2==kbndpt(k) ) then - write(irefwr,*) 'Node is in curve',boundary(1,j) - locbound(j) = locbound(j)+1 - end if - end do - end do - end if - - end do - - iperm = 1 - do i = 1, numcurvboun - if ( locbound(i)>0 ) then - iperm = 0 - write(irefwr,*) - + 'Coarseness problems curve C with number',boundary(1,i), - + 'which is part of the boundary of surface',isurnr, - + 'coarsenesses start- and endnode differ too much!' - end if - locbound(i) = 0 - end do - - if ( iperm==0 ) then - write(irefwr,*) 'Check and adjust your input for the curves' - end if - - end if - -! --- Second step: check all internal mutual lines -! --- Check all nodes via internal "visible" lines: - -! --- Run through all prescribed points and consider mutual distances in relation -! to their local coarsenesses: -! (Give warning if points are not in one line) - - iperm = 1 - - eps = 1d-9 * coaval(1) - - do i = 1, npoint-1 - do j = i+1, npoint -! --- Be sure that nodes are really in linear mesh: - if ( coarse(i)> eps .and. coarse(j)>eps ) then -! --- Next step: check mutual visibility and -! if visible then check coarsenesses - - if ( debug ) write(irefwr,*) 'Check Point',i,'and point',j - -! --- Compute Euclidian distance - call msho03( i, j, coor, afst ) - -! --- Check whether coarsenesses and mutual distance are -! realistic. Find cmax and cmin of these two values: - if ( coarse(i)>coarse(j) ) then - cmax = coarse(i) - cmin = coarse(j) - kpoint = i - else - cmax = coarse(j) - cmin = coarse(i) - kpoint = j - end if - - coa = abs( (cmax - cmin)/(cmax+cmin) ) - -! --- Check possibilities: - if ( afst<0.2 * csmall ) then -! --- Check whether line does not cross outer or inner boundary: - call msho24( kstapl, kstap, coor, i, j, icheck) - - if ( icheck==0 ) then -! --- No intermediate points, give warning: too small distance - -! --- Find number of internal curve and values of coarseness - call msho34( kpoint, coor, ncurvs, curves, kbndpt, - + nbndpt, numcurvboun, boundary, nbound, - + nholes, userco, nuspnt, coaval, ius1, ius2 ) - if ( debug ) then - write(irefwr,*) 'msho38: problems in surface',isurnr - write(irefwr,*) 'Locally coarseness too small' - write(irefwr,*) 'Found value ',afst - write(irefwr,*) 'Position of nodes' - write(irefwr,*) ' Node ',i,' = ',coor(1,i),coor(2,i) - write(irefwr,*) ' Node ',j,' = ',coor(1,j),coor(2,j) - write(irefwr,*) 'Adjust coarsenesses of nodes ' - iperm = 0 - end if - end if - else if ( coa > 0.1 ) then -! --- Only action if there is a real coarseness difference - iallow = 1 - call msho39( cmax, cmin, afst, maxratio, iallow ) - if ( iallow==0 .and. debug ) - + write(irefwr,*) 'Routine msho39 iallow=0 use cmax =',cmax - icheck = 0 - if ( iallow==0 ) then -! --- Check visibility: - call msho24( kstapl, kstap, coor, i, j, icheck) - end if - - if ( iallow==0 .and. icheck==0 ) then -! --- Point is visible and coarseness is not ok - iperm = 0 - - if ( debug ) then - write(irefwr,*) 'Warning coarseness nodes',i,'and',j - write(irefwr,*) 'differs too much' - write(irefwr,*) 'Positions of the nodes are' - write(irefwr,*) ' Node ',i,' = ',coor(1,i),coor(2,i) - write(irefwr,*) ' Node ',j,' = ',coor(1,j),coor(2,j) - write(irefwr,*) 'Distance = ',afst - write(irefwr,*) 'coarseness first point = ',coarse(i) - write(irefwr,*) 'coarseness second point = ',coarse(j) - write(irefwr,*) 'Adjust Coarseness' - - end if -! --- Determine coarseness needed in kpoint: - call msho41( cmin, cmax, afst, maxratio ) -! --- Find start- and end-point of line: - call msho34( kpoint, coor, ncurvs, curves, kbndpt, - + nbndpt, numcurvboun, boundary, nbound, - + nholes, userco, nuspnt, coaval, ius1, ius2 ) - -! --- Determine new coarseness needed in ius1 and ius2: - if ( debug ) then - write(irefwr,*) 'cords kpoint',(coor(k,kpoint),k=1,2) - write(irefwr,*) 'cords ius1 ',(userco(k,ius1),k=1,2) - write(irefwr,*) 'cords ius2 ',(userco(k,ius2),k=1,2) - write(irefwr,*) 'coarsen i1 ',(coaval(ius1+1)) - write(irefwr,*) 'coarsen i2 ',(coaval(ius2+1)) - write(irefwr,*) 'coarsen kp ',cmax - write(irefwr,*) 'maxratio =',coaval(1),'tran=',tran - write(irefwr,*) (coaval(k),k=2,nuspnt+1) - end if -! --- Compute coarseness values in ius1 and ius2: -! (Use transformation coefs) - val1 = coaval(1)*coaval(ius1+1)/tran - val2 = coaval(1)*coaval(ius2+1)/tran -! --- Adjust values in coaval array: - if ( cmaxcmin ) then -! --- Check whether there is enough space from small to large: - afst = 0.6 * cmin - som = afst - - do while ( som1d0+eps ) goto 100 - opp = (x2*(y3-ym) + x3*(ym-y2) + xm*(y2-y3))/det - if ( opp<-eps .or. opp>1d0+eps ) goto 100 - opp = (x3*(y1-ym) + x1*(ym-y3) + xm*(y3-y1))/det - if ( opp<-eps .or. opp>1d0+eps ) goto 100 - -! --- Point (xm,ym) is inside: error - - write(irefwr,*) 'Error: barycentre of element',ielem - write(irefwr,*) 'is also inside triangle',jelem - write(irefwr,*) 'Essential error!' - iperm = 1 - end if -100 continue - end do - end do - - if ( iperm==1 ) then - write(irefwr,*) 'Execution stopped. Please inform SEPRA' -!AvD call instop - end if - -! --- Next consider all nodes: they should never be inside a triangle: - - do i = 1 , npoint - -! --- Run through all triangles: - - do ielem = 1, nelem - -! --- Determine nodenumbers: - - i1 = kelem(1,ielem) - i2 = kelem(2,ielem) - i3 = kelem(3,ielem) - if ( i/=i1.and.i/=i2.and.i/=i3 ) then - -! --- Check position of node i - - xm = coor(1,i) - ym = coor(2,i) - x1 = coor(1,i1) - y1 = coor(2,i1) - x2 = coor(1,i2) - y2 = coor(2,i2) - x3 = coor(1,i3) - y3 = coor(2,i3) - -! --- Check for double points: -! Extra check whether coordinates of nodes are exactly the -! same, -! i.e. check whether it concerns Plaxis points - - dis = (x1-xm)*(x1-xm) + (y1-ym)*(y1-ym) - det = abs(x1)+abs(xm)+abs(y1)+abs(ym) - if ( dis1d0+eps ) goto 200 - opp = (x2*(y3-ym) + x3*(ym-y2) + xm*(y2-y3))/det - if ( opp<-eps .or. opp>1d0+eps ) goto 200 - opp = (x3*(y1-ym) + x1*(ym-y3) + xm*(y3-y1))/det - if ( opp<-eps .or. opp>1d0+eps ) goto 200 - -! --- Point (xm,ym) is inside this triangle: error - - write(irefwr,*) 'Error: node',i,'inside element',ielem - write(irefwr,*) 'Essential error!' - iperm = 1 - end if -200 continue - end do - end do - -! --- Problems encountered? - - if ( iperm==1 ) then - write(irefwr,*) 'Execution stopped' - write(irefwr,*) 'Please inform SEPRA' -!AvD call instop - end if - - end diff --git a/extern/sepran/msho41.for b/extern/sepran/msho41.for deleted file mode 100644 index 9368c55f0..000000000 --- a/extern/sepran/msho41.for +++ /dev/null @@ -1,106 +0,0 @@ - subroutine msho41( cmin, cmax, dist, maxratio ) -! ====================================================================== -! -! programmer niek praagman -! version 1.0 date 10-11-2009 -! -! copyright (c) 2009-2009 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Compute the max allowed coarseness cmax in point B that is in -! accordance with given coarseness cmin in a point A. The -! Euclidian distance from A to B is dist and the max allowed ratio -! between two linepieces is maxratio. -! ********************************************************************** -! -! KEYWORDS -! -! mesh -! mesh_generation -! 2d -! ********************************************************************** -! -! MODULES USED -! - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - double precision cmax, cmin, dist, maxratio - -! cmax i/o i: given coarseness in point B -! o: max allowed coarseness in point B -! cmin i coarseness point A -! dist i Euclidian distance A to B -! maxratio i max allowed multiplication in two neighbouring -! elements (i.e. linepieces) -! ********************************************************************** -! -! LOCAL PARAMETERS -! - double precision afst, som - -! afst local distance between sequential nodes -! som temporary distance -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! Trivial -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! -! --- Check possibilities: - - if ( dist < cmin ) then -! --- Length dist too small: - cmax = cmin - else if ( dist>cmin ) then -! --- Check whether there is enough space from small to large: - afst = 0.65 * cmin - som = afst - - do while ( som xj then -! If x1 <> x2 then -! Determine x-coordinate of common point xs -! If xs lies between xi and xj then -! If xs lies between x1 and x2 then -! There is a common point -! Endif -! Endif -! Else -! If yi = yj then -! If xi and xj lie on opposite sides of xs or -! yi and yj lie on opposite sides of xs then -! There is a common point -! Endif -! Else -! Determine y-coordinate of common point ys -! If ys lies between yi and yj then -! If ys lies between y1 and y2 then -! There is a common point -! Endif -! Endif -! Endif -! Endif -! Else -! If x1 <> x2 then -! If y1 = y2 then -! If yi and yj lie on opposite sides of y1 or -! x1 and x2 lie on opposite sides of xi then -! There is a common point -! Endif -! Else -! Determine y-coordinate of common point ys -! If ys lies between yi and yj then -! If ys lies between y1 and y2 then -! There is a common point -! Endif -! Endif -! Endif -! Else -! If x1 = xi then: a common point -! Endif -! Endif -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - character(len=260) localName - localName = 'msho75' - call eropen( localName ) - - eps = 10 * epsmac - -! --- Start with "no intersection" - - ih = 1 - -! --- Check boxes to find out whether an intersection is possible: -! Determine extreme values line i-j: - - xmin = min( xi, xj ) - xmax = max( xi, xj ) - ymin = min( yi, yj ) - ymax = max( yi, yj ) - -! --- Determine extreme values line 1-2: - - xmi = min( x1, x2 ) - xma = max( x1, x2 ) - ymi = min( y1, y2 ) - yma = max( y1, y2 ) - - if ( xmi>xmax .or. xmaymax .or. yma(eps * (abs(xi) + abs(xj)))) then - -! --- xi#xj - - if (abs(x1-x2)>(eps * (abs(x1) + abs(x2)))) then - -! --- xi#xj and x1#x2 -! determine value x-coordinate intersection - - r1 = ( y1 * x2 - y2 * x1 ) / ( x2 - x1 ) - r2 = ( yi * xj - yj * xi ) / ( xj - xi ) - r3 = ( yj - yi ) / ( xj - xi ) - r4 = ( y2 - y1 ) / ( x2 - x1 ) - if ( abs(r3-r4)>eps ) then - xs = ( r1 - r2 ) / ( r3 - r4 ) - if ( ( xixs ) .or. - + ( xjxs ) .or. - + ( abs(xi-xs)xs ) .or. - + ( x2xs ) .or. - + ( abs(x1-xs)xs .and. xj>xs ) .or. - + ( y1ys .and. y2>ys ) ) ) then - ih = 0 - end if - else - -! --- Determine y-coordinate intersection - - ys = ( (yj - yi) * x1 + yi * xj - yj * xi ) / (xj - xi) - if ( ( y1ys ) .or. - + ( y2ys ) .or. - + ( abs(y1-ys)ys ) .or. - + ( yjys ) .or. - + ( abs(yi-ys)( eps * ( abs(x1) + abs(x2)))) then - -! --- xi = xj and x1#x2 - - if ( abs(y1-y2)ys .and. yj>ys ) .or. - + ( x1xs .and. x2>xs ) ) ) then - ih = 0 - end if - - else - -! --- determine y-coordinate intersection - - ys = ( (y2 - y1) * xi + y1 * x2 - y2 * x1 ) / (x2 - x1) - if ( ( yiys ) .or. - + ( yi>ys .and. yjys ) .or. - + ( y2ys ) .or. - + ( abs(y1-ys)0 ) then - -! --- ncoar>0 - - call prinin ( userpoints, ncoar, 'userpoints' ) - call prinrl1 ( coar, ncoar, 2, 'coar' ) - end if ! ( ncoar>0 ) - if ( numextcurves>0 ) then - -! --- numextcurves>0 - - lenextracrvs = 0 - do i = 1, numextcurves - lenextracrvs = lenextracrvs+numnodextcurvs(i) - end do ! i = 1, numextcurves - call prinin ( numnodextcurvs, numextcurves, - + 'numnodextcurvs' ) - call prinin ( curvenumbers, numextcurves, 'curvenumbers' ) - call prinrl1 ( bcord(2*nbound+1), lenextracrvs, 2, - + 'coordinates extra curves' ) - end if ! ( ncoar>0 ) - 1 format ( a, 1x, (10i6) ) - end if ! ( debug ) - if ( ierror/=0 ) go to 1000 - if ( itime>0 ) call ersettime ( timebefore ) - -! --- Estimated number of points - npunt = npoint -! --- Fill array coor with boundary points -! Allocate temporary space for help array kbound - allocate( kbound( 2 * npunt ), stat = error ) - if ( error/=0 ) call eralloc ( error, 2*npunt, 'kbound' ) - - call mshcopyboun ( jpnt, nbound, bcord, coor, kbndpt, - + kbound, inside, nbn, .true. ) - - if ( ierror/=0 ) go to 1000 - - if ( jnew ) then - npoint = jpnt - istep = 1 - -! --- Check for quadratic - - if ( inpelm==6 .or. inpelm==7 ) then - -! --- Adjust istep, boundary array and eventually extra curves: - - istep = 2 - - nbn = nbn / 2 - - do i = 1, nbn - kbound(2*i-1) = kbound(4*i-3) - kbound(2*i ) = kbound(4*i ) - end do - -! --- Extra curves? - - nnodes = 1 - - if ( numextcurves>0 ) then - -! --- Determine the length of extra array for curves: - - nnodes = 0 - - do i=1, numextcurves - -! --- Run through line i of the internal curves: - - nnodes = nnodes + numnodextcurvs(i) - end do - -! --- Extra array needed to place temporarily the quadratic -! elements of the internal lines: -! Length needed: 2 * nnodes - - end if - - allocate( extquanodes( 2 * nnodes ), stat = ierror) - if ( error/=0 ) call eralloc (error,2*nnodes,'extquanodes') - extquanodes(1) = 0 - - if ( debug ) then - write(irefwr,*) 'extra points = ',nnodes - write(irefwr,*) 'numextcurves = ',numextcurves - end if - else - allocate( extquanodes( 1 ), stat = ierror) - extquanodes(1) = 0 - end if - -! --- Set initial number of points - - nbndpt = nbound - - call msho2d ( coor, npoint, kbound, nbn, kmeshc, - + nelem, boundary, numcurvboun, npunt, - + inside, holeinfo, nholes, .true., - + kbndpt, nbndpt, coar, ncoar, - + userpoints, bcord(2*nbound+1), numextcurves, - + numnodextcurvs, curvenumbers, istep, - + extquanodes, isurnr, rinput, - + nuspnt, ndim ) - - if ( debug ) then - write(irefwr,*) 'Contents array kbndpt after calling msho2d' - write(irefwr,*) (kbndpt(i),i=1,nbndpt) - write(irefwr,*) 'First part coor after calling msho2d' - do i=1, nbndpt - write(irefwr,*) i,coor(2*i-1),coor(2*i) - end do - write(irefwr,*) 'end first part coordinates array coor' - write(irefwr,*) 'number of extra curves = ',numextcurves - write(irefwr,*) 'number of extra nodes on curves' - write(irefwr,*) (numnodextcurvs(i),i=1,numextcurves) - write(irefwr,*) 'it concerns curves with numbers:' - write(irefwr,*) (curvenumbers(i),i=1,numextcurves) - end if - - if ( ierror/=0 ) go to 1000 - -! --- Special treatment if elements are quadratic - - if ( inpelm==6 .or. inpelm==7 ) then - -! --- inpelm = 6 or 7, extra nodes in elements - - call msho31 ( coor, npoint, kmeshc, nelem, kbound, nbn, - + extquanodes) - if ( inpelm==7 ) then - -! --- inpelm = 7, also fill centroid - - !AvD: We only do triangles (inpelm=3), so disable calls to mshtriancentr and mshd7 (routines are missing) - !AvD: call mshtriancentr ( kmeshc, npoint, nelem, inpelm ) - if ( ierror/=0 ) go to 1000 - !AvD: call mshd7 ( kmeshc, coor, nelem, 2 ) - end if - if ( ierror/=0 ) go to 1000 - end if - - deallocate( extquanodes, stat = error ) - if ( error/=0 ) call erdealloc ( error, 'extquanodes' ) - - else - -! --- jnew = .FALSE. hence only repositioning - - nbndpt = jpnt - - !AvD: Disable call mshrep (routine is missing): only used when generating - ! a mesh by REpositioning (given current mesh with only changed boundary - ! points, move inner points). - !AvD: call mshrep ( coor, npoint, kmeshc, nelem, inpelm, nbndpt ) - -! --- MSHREP uses ordering of GENERAL hence make a renumbering if -! inpelm>3 - - if ( inpelm==6 .or. inpelm==7 ) then - -! --- inpelm = 6 or 7, extra nodes in elements - - call msho32(kmeshc,nelem,inpelm,npunt) - if ( ierror/=0 ) go to 1000 - - if ( npunt>jpnt ) then - npoint = npunt - else - npoint = jpnt - end if - -! --- Adjust boundary points value and boundary node numbers - - nbn = nbn / 2 - -! --- Run through all pieces - - do i = 1 , nbn - kbound(2*i-1) = kbound(4*i-3) - kbound(2*i ) = kbound(4*i ) - end do - -! --- Extra internal curves? - - if ( numextcurves>0 ) then - -! --- Determine the length of extra array for curves: - - nnodes = 0 - -! --- Run through internal curves - - do i=1, numextcurves - -! --- Run through line i of the internal curves: - - nnodes = nnodes + numnodextcurvs(i) - end do - -! --- Extra array needed to place temporarily the quadratic -! elements of the internal lines: -! Length needed: 2 * nnodes - - allocate( extquanodes( 2 * nnodes ), stat = ierror) - if (error/=0) call eralloc (error,2*nnodes,'extquanodes') - else - -! --- No extra nodes internal curves: - - allocate( extquanodes( 1 ), stat = ierror) - extquanodes(1) = 0 - end if - - call msho31( coor, npoint, kmeshc, nelem, kbound, nbn, - + extquanodes) - - if ( inpelm==7 ) then - -! --- inpelm = 7, also fill centroid - - !AvD: We only do triangles (inpelm=3), so disable calls to mshtriancentr and mshd7 (routines are missing) - !AvD: call mshtriancentr ( kmeshc, npoint, nelem, inpelm ) - if ( ierror/=0 ) go to 1000 - !AvD: call mshd7 ( kmeshc, coor, nelem, 2 ) - end if - if ( ierror/=0 ) go to 1000 - - deallocate( extquanodes, stat = error ) - if ( error/=0 ) call erdealloc ( error, 'extquanodes' ) - end if - - end if - - if ( igobs==0 .and. inpelm>4 ) then - -! --- Quadratic elements, copy boundary again in order to get a really -! curved boundary - - call mshcopyboun ( jpnt, nbound, bcord, coor, kbndpt, - + kbound, inside, nbn, .false. ) - - end if - - deallocate( kbound, stat = error ) - if ( error/=0 ) call erdealloc ( error, 'kbound' ) - if ( itime==1 ) call printtime('TRIANGLE', timebefore) -1000 call erclos ( 'mshoce' ) - if ( debug ) then - write(irefwr,*) 'Debug information end mshoce' - -! --- Debug information - - write(irefwr,1) 'nholes, npoint, ncoar, nelem, nbound', - + nholes, npoint, ncoar, nelem, nbound - call prinin ( kbndpt, nbound, 'kbndpt' ) - if ( nholes>0 ) then - call prinin1 ( holeinfo(1,0), nholes+2, 2, 'holeinfo' ) - end if ! ( nholes>0 ) - call prinin1 ( kmeshc, nelem, inpelm, 'kmeshc' ) - - write(irefwr,*) 'End msho2d with ',npoint,' nodes' - do i=1, npoint - write(irefwr,*) i,'x-y',coor(2*i-1),coor(2*i) - end do - write(irefwr,*) 'End mshoce' - end if - end diff --git a/extern/sepran/mshtrans2dsur.for b/extern/sepran/mshtrans2dsur.for deleted file mode 100644 index 55ce89f64..000000000 --- a/extern/sepran/mshtrans2dsur.for +++ /dev/null @@ -1,218 +0,0 @@ - subroutine mshtrans2dsur ( coor, npoint, xmint, ymint, tran, - + ncoar, coar, ncurvs, curves, cocurvs, - + userco, nuspnt ) -! ====================================================================== -! -! programmer Guus Segal -! version 1.1 date 10-11-2009 Add array of userpoints -! version 1.0 date 19-08-2009 -! -! copyright (c) 2009-2009 "Ingenieursbureau SEPRA" -! permission to copy or distribute this software or documentation -! in hard copy or soft copy granted only by written license -! obtained from "Ingenieursbureau SEPRA". -! all rights reserved. no part of this publication may be reproduced, -! stored in a retrieval system ( e.g., in memory, disk, or core) -! or be transmitted by any means, electronic, mechanical, photocopy, -! recording, or otherwise, without written permission from the -! publisher. -! ********************************************************************** -! -! DESCRIPTION -! -! Transform 2d region to region of unit length in first quadrant -! -! ********************************************************************** -! -! KEYWORDS -! -! mesh_generation -! 2d -! transformation -! map -! coordinate -! ********************************************************************** -! -! MODULES USED -! - use mshconstants - use mshdummymethods - use msherror - implicit none -! ********************************************************************** -! -! COMMON BLOCKS -! -! include 'SPcommon/cmcdpi' -! include 'SPcommon/cconst' -! include 'SPcommon/cinout' - -! ********************************************************************** -! -! INPUT / OUTPUT PARAMETERS -! - integer npoint, ncoar, ncurvs, nuspnt, curves(ncurvs) - double precision coor(2,npoint), xmint, ymint, tran, coar(3,*), - + cocurvs(2,*), userco(2,nuspnt) - -! coar i/o array containing coordinates and coarseness of -! special points to be used in later calculations: -! positions of these points are fixed! -! cocurvs i/o array containing the crds of the fixed line nodes -! coor i/o array containing the coordinates of the points -! curves i the curve numbers of the extra internal curves -! ncoar i number of special points in array coar -! ncurvs i number: extra internal curves submitted by user -! npoint i Number of nodal points in boundary -! nuspnt i Number of userpoints -! tran o scaling parameter -! userco i/o array containing the coords of the user points -! xmint o min x for transformation -! ymint o min y for transformation -! ********************************************************************** -! -! LOCAL PARAMETERS -! - integer i, i1, i2, nnodes - double precision xmax, ymax - logical debug - -! debug If true debug statements are carried out otherwise -! they are not -! i Counting variable -! i1 Help parameter to store a constant -! i2 Help parameter to store a constant -! nnodes Number of nodes in curve -! xmax Maximum x-value -! ymax Maximum y-value -! ********************************************************************** -! -! SUBROUTINES CALLED -! -! ERCLOS Resets old name of previous subroutine of higher level -! EROPEN Produces concatenated name of local subroutine -! PRINRL1 Print 2d real vector -! ********************************************************************** -! -! I/O -! -! ********************************************************************** -! -! ERROR MESSAGES -! -! ********************************************************************** -! -! PSEUDO CODE -! -! ********************************************************************** -! -! DATA STATEMENTS -! -! ====================================================================== -! - call eropen ( 'mshtrans2dsur' ) - debug = .false. !.and. ioutp>=0 !AvD ioutp? - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'Debug information from mshtrans2dsur' - 1 format ( a, 1x, (10i6) ) - 2 format ( a, 1x, (5d12.4) ) - - end if ! ( debug ) - if ( ierror/=0 ) go to 1000 - -! --- Replace all nodes temporarily to the first (positive) quadrant: -! (Determine translation parameters x- and y-tran) - - xmint = RINFIN - xmax = -RINFIN - ymint = RINFIN - ymax = -RINFIN - do i = 1, npoint - xmint = min(xmint,coor(1,i)) - xmax = max(xmax ,coor(1,i)) - ymint = min(ymint,coor(2,i)) - ymax = max(ymax ,coor(2,i)) - end do - - if ( debug ) then - write(irefwr,2) 'xmin, xmax', xmint, xmax - write(irefwr,2) 'ymin, ymax', ymint, ymax - end if - -! --- Make temporary transformation: - - if ( xmax - xmint>ymax - ymint ) then - tran = xmax - xmint - else - tran = ymax - ymint - end if - -! --- Scale all submitted points of coor array: - - coor(1,:) = 1d0 + ( coor(1,:) - xmint ) / tran - coor(2,:) = 1d0 + ( coor(2,:) - ymint ) / tran - -!AvD if ( debug ) -! + call prinrl1 ( coor, npoint, 2, -! + 'New coordinates, after scaling' ) - -! --- Scale all user points (userco array): - - userco(1,:) = 1d0 + ( userco(1,:) - xmint ) / tran - userco(2,:) = 1d0 + ( userco(2,:) - ymint ) / tran - -!AvD if ( debug ) -! + call prinrl1 ( userco, nuspnt, 2, -! + 'New userpoint coordinates, after scaling' ) - - if ( ncoar>0 ) then -! --- ncoar>0, change internal points - - coar(1,1:ncoar) = 1d0 + ( coar(1,1:ncoar) - xmint ) / tran - coar(2,1:ncoar) = 1d0 + ( coar(2,1:ncoar) - ymint ) / tran - coar(3,1:ncoar) = coar(3,1:ncoar) / tran - - if ( debug ) - + call prinrl1 ( coar, ncoar, 3, - + 'Internal points after scaling' ) - - end if ! ( ncoar>0 ) - - if ( ncurvs>0 ) then - -! --- Scale nodes on submitted internal curves -! Start computing number of nodes on the curves: - - nnodes = 0 - - do i = 1, ncurvs - if ( debug ) - + write(irefwr,1) 'internal curve', i - -! --- Run through line i of the internal curves: - - i1 = nnodes + 1 - i2 = nnodes + curves(i) - cocurvs(1,i1:i2) = 1d0+(cocurvs(1,i1:i2) - xmint) / tran - cocurvs(2,i1:i2) = 1d0+(cocurvs(2,i1:i2) - ymint) / tran -!AvD if ( debug ) -! + call prinrl1 ( cocurvs(1,i1), curves(i), 2, -! + 'coordinates' ) - nnodes = i2 - end do ! i = 1, ncurvs - - end if ! ( ncurvs>0 ) - -1000 call erclos ( 'mshtrans2dsur' ) - if ( debug ) then - -! --- Debug information - - write(irefwr,*) 'End mshtrans2dsur' - - end if ! ( debug ) - - end From ba3b257530d53301c681ada359dea4a00d4922e4 Mon Sep 17 00:00:00 2001 From: BillSenior Date: Mon, 13 Jul 2026 12:56:20 +0200 Subject: [PATCH 43/43] GRIDEDIT-2102 Fix compilation under macos --- cmake/compiler_config.cmake | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/cmake/compiler_config.cmake b/cmake/compiler_config.cmake index ac757e2be..580bf54cd 100644 --- a/cmake/compiler_config.cmake +++ b/cmake/compiler_config.cmake @@ -15,6 +15,13 @@ if(APPLE) message(STATUS "Configuring build for macOS with ${CMAKE_CXX_COMPILER_ID} (${CMAKE_CXX_COMPILER_VERSION}).") # Common warning and visibility flags add_compile_options("-fvisibility=hidden;-Wall;-Wextra;-pedantic;-Werror;-Wno-unused-function") + + cmake_host_system_information(RESULT os_release QUERY OS_RELEASE) + + if(os_release VERSION_GREATER_EQUAL "26.0") + add_compile_options("-Wno-character-conversion") + endif() + # Conditionally suppress unused parameter warnings (used for platform-specific compiler issues) if(SUPPRESS_UNUSED_PARAMETER_WARNING) add_compile_options("-Wno-unused-parameter") @@ -27,7 +34,6 @@ if(APPLE) add_compile_options("$<$:-g>") # Disable warnings about implicit conversions between character types # This is required because of a compatibility issue between clang++ and googletest - add_compile_options("-Wno-character-conversion") else() message(FATAL_ERROR "Unsupported compiler on macOS. Supported: AppleClang/Clang. Found ${CMAKE_CXX_COMPILER_ID}.") endif()