OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
linedge.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| linedge ../starter/source/groups/linedge.F
25!||--- called by ------------------------------------------------------
26!|| hm_read_lines ../starter/source/groups/hm_read_lines.F
27!||--- calls -----------------------------------------------------
28!||--- uses -----------------------------------------------------
29!||====================================================================
30 SUBROUTINE linedge(NSEG0 ,NSEG ,BUFTMP ,SLIN_NODES ,KEY,
31 . FLAG ,SLIN_ELTYP ,SLIN_ELEM,LINE_NSEG0)
32 USE names_and_titles_mod , ONLY : ncharkey
33C-----------------------------------------------
34C I m p l i c i t T y p e s
35C-----------------------------------------------
36#include "implicit_f.inc"
37C-----------------------------------------------
38C C o m m o n B l o c k s
39C-----------------------------------------------
40C-----------------------------------------------
41C D u m m y A r g u m e n t s
42C-----------------------------------------------
43 INTEGER NSEG0,NSEG,FLAG,LINE_NSEG0
44 INTEGER BUFTMP(6,*),SLIN_NODES(LINE_NSEG0,*),SLIN_ELTYP(*),
45 . slin_elem(*)
46 CHARACTER(LEN=NCHARKEY) :: KEY
47C-----------------------------------------------
48C L o c a l V a r i a b l e s
49C-----------------------------------------------
50 INTEGER I,K,J1,J2,IPERM(4)
51C INTEGER IW1(4*NSEG0),IW2(4*NSEG0),IW5(4*NSEG0),IW6(4*NSEG0),
52C . INDEX(8*NSEG0),IWORK(70000), IPERM(4)
53 integer, dimension(:), allocatable :: IW1,IW2,IW5,IW6,INDEX,IWORK
54 DATA iperm /2,3,4,1/
55C=======================================================================
56 ALLOCATE(iw1(4*nseg0), iw2(4*nseg0), iw5(4*nseg0),iw6(4*nseg0), index(8*nseg0))
57 ALLOCATE(iwork(70000))
58 k=0
59 iw1 = 0
60 iw2 = 0
61 iw5 = 0
62 iw6 = 0
63 index = 0
64 DO i = 1,nseg0
65 DO j1=1,4
66 j2=iperm(j1)
67 IF(buftmp(j2,i)/=0.AND.
68 . buftmp(j1,i)>buftmp(j2,i))THEN
69 k=k+1
70 iw1(k)=buftmp(j2,i)
71 iw2(k)=buftmp(j1,i)
72 iw5(k)=buftmp(5,i)
73 iw6(k)=buftmp(6,i)
74 ELSEIF(buftmp(j1,i)/=0.AND.
75 . buftmp(j1,i)<buftmp(j2,i))THEN
76 k=k+1
77 iw1(k)=buftmp(j1,i)
78 iw2(k)=buftmp(j2,i)
79 iw5(k)=buftmp(5,i)
80 iw6(k)=buftmp(6,i)
81 ENDIF
82 ENDDO
83 ENDDO
84C-----------------------------------------------
85 CALL my_orders( 0,iwork,iw1,index,k,1)
86 CALL my_orders(10,iwork,iw2,index,k,1)
87C-----------------------------------------------
88 IF (key(1:4) == 'SURF') THEN
89C-----------------------------------------------
90C REMOVAL OF DOUBLE SEGMENTS
91C-----------------------------------------------
92 nseg=1
93 IF (flag == 0) THEN
94 DO i=2,k
95 IF(iw1(index(i-1))/=iw1(index(i)).OR.
96 . iw2(index(i-1))/=iw2(index(i))) nseg=nseg+1
97 ENDDO
98 ELSEIF (flag == 1) THEN
99 slin_nodes(1,1) = iw1(index(1))
100 slin_nodes(1,2) = iw2(index(1))
101 slin_eltyp(1) = iw5(index(1))
102 slin_elem(1) = iw6(index(1))
103 DO i=2,k
104 IF(iw1(index(i-1))/=iw1(index(i)).OR.
105 . iw2(index(i-1))/=iw2(index(i)))THEN
106 nseg=nseg+1
107 slin_nodes(nseg,1) = iw1(index(i))
108 slin_nodes(nseg,2) = iw2(index(i))
109 slin_eltyp(nseg) = iw5(index(i))
110 slin_elem(nseg) = iw6(index(i))
111 ENDIF
112 ENDDO
113 ENDIF ! IF (FLAG == 0)
114 ELSEIF (key(1:4) == 'EDGE') THEN
115C-----------------------------------------------
116C REMOVAL OF INTERNAL SEGMENTS (EXCEPT BORDERS)
117C-----------------------------------------------
118 nseg=0
119 IF (flag == 0) THEN
120 IF(iw1(index(1))/=iw1(index(2)).OR.
121 . iw2(index(1))/=iw2(index(2))) nseg=1
122 DO i=2,k-1
123 IF((iw1(index(i-1))/=iw1(index(i)).OR.
124 . iw2(index(i-1))/=iw2(index(i))).AND.
125 . (iw1(index(i+1))/=iw1(index(i)).OR.
126 . iw2(index(i+1))/=iw2(index(i)))) nseg=nseg+1
127 ENDDO
128 IF(iw1(index(k-1))/=iw1(index(k)).OR.
129 . iw2(index(k-1))/=iw2(index(k))) nseg=nseg+1
130C
131 ELSEIF (flag == 1) THEN
132 IF(iw1(index(1))/=iw1(index(2)).OR.
133 . iw2(index(1))/=iw2(index(2)))THEN
134 nseg=1
135 slin_nodes(nseg,1) = iw1(index(1))
136 slin_nodes(nseg,2) = iw2(index(1))
137 slin_eltyp(nseg) = iw5(index(1))
138 slin_elem(nseg) = iw6(index(1))
139 ENDIF
140 DO i=2,k-1
141 IF((iw1(index(i-1))/=iw1(index(i)).OR.
142 . iw2(index(i-1))/=iw2(index(i))).AND.
143 . (iw1(index(i+1))/=iw1(index(i)).OR.
144 . iw2(index(i+1))/=iw2(index(i))))THEN
145 nseg=nseg+1
146 slin_nodes(nseg,1) = iw1(index(i))
147 slin_nodes(nseg,2) = iw2(index(i))
148 slin_eltyp(nseg) = iw5(index(i))
149 slin_elem(nseg) = iw6(index(i))
150 ENDIF
151 ENDDO
152 IF(iw1(index(k-1))/=iw1(index(k)).OR.
153 . iw2(index(k-1))/=iw2(index(k)))THEN
154 nseg=nseg+1
155 slin_nodes(nseg,1) = iw1(index(k))
156 slin_nodes(nseg,2) = iw2(index(k))
157 slin_eltyp(nseg) = iw5(index(k))
158 slin_elem(nseg) = iw6(index(k))
159 ENDIF ! IF (FLAG == 0)
160 ENDIF ! IF (KEY(1:4) == 'SURF')
161C-----------
162 ENDIF
163C-----------
164 DEALLOCATE(iw1 ,iw2, iw5,iw6, index,iwork)
165
166 RETURN
167 END
linedge
subroutine linedge(nseg0, nseg, buftmp, slin_nodes, key, flag, slin_eltyp, slin_elem, line_nseg0)
Definition linedge.F:32
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1005