OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_surfsurf.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!|| hm_read_surfsurf ../starter/source/groups/hm_read_surfsurf.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| hm_get_int_array_index ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
30!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
31!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
32!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
33!||--- uses -----------------------------------------------------
34!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
35!|| message_mod ../starter/share/message_module/message_mod.F
36!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
37!|| submodel_mod ../starter/share/modules1/submodel_mod.F
38!||====================================================================
39 SUBROUTINE hm_read_surfsurf(IGRSURF ,INSEG ,FLAG ,ICOUNT ,ITER ,NSETS, LSUBMODEL)
40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE my_alloc_mod
44 USE message_mod
45 USE groupdef_mod
46 USE submodel_mod , ONLY : nsubmod, submodel_data
47 USE hm_option_read_mod
48 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
49 USE reader_old_mod , ONLY : line, kline
50C-----------------------------------------------
51C I m p l i c i t T y p e s
52C-----------------------------------------------
53#include "implicit_f.inc"
54C-----------------------------------------------
55C C o m m o n B l o c k s
56C-----------------------------------------------
57#include "scr17_c.inc"
58#include "com01_c.inc"
59#include "com04_c.inc"
60#include "param_c.inc"
61C-----------------------------------------------
62C D u m m y A r g u m e n t s
63C-----------------------------------------------
64 INTEGER INSEG,FLAG,ICOUNT,ITER ,NSETS
65!
66 TYPE (SURF_) , DIMENSION(NSURF+NSETS) :: IGRSURF
67 TYPE(submodel_data), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
68C-----------------------------------------------
69C L o c a l V a r i a b l e s
70C-----------------------------------------------
71 INTEGER I,J,K,L,ID,IGS,IGRS,JREC,IADV,NSEG,NSEGV,SRFTYP,
72 . SKIPFLAG,UID,IAD_TMP,BUFTMP_1,NSEG_TOT,
73 . IWORK(70000),IERROR, II
74 INTEGER, DIMENSION(:,:) , ALLOCATABLE :: ITRI
75 INTEGER, DIMENSION(:) , ALLOCATABLE :: INDEX,BUFTMP
76
77 CHARACTER(LEN=NCHARTITLE) :: TITR
78 CHARACTER(LEN=NCHARKEY) :: KEY,KEY2,KEY3
79 INTEGER :: NB_IDS, NB_NEG_IDS
80 INTEGER, DIMENSION(:), ALLOCATABLE :: IDS
81 LOGICAL :: IS_AVAILABLE
82 INTEGER :: NN(4),NF,IMIN,NMIN,INOD(4),NPERM(4,4),ISIGN_NOD(4),IORD
83 DATA nperm/1,2,3,4,
84 . 2,3,4,1,
85 . 3,4,1,2,
86 . 4,1,2,3/
87C-----------------------------------------------
88! IGRSURF(IGS)%ID :: SURFACE identifier
89! IGRSURF(IGS)%TITLE :: SURF title
90! IGRSURF(IGS)%NSEG :: Number of surfaces within /SURF
91! IGRSURF(IGS)%NSEG_IGE :: Number of iso-surfaces
92! IGRSURF(IGS)%TYPE :: OPEN / CLOSED surface flag
93! SURF_TYPE = 0 : SEGMENTS
94! SURF_TYPE = 100 : HYPER-ELLIPSOIDE MADYMO.
95! surf_type = 101 : hyper-ellipsoide radioss.
96! SURF_TYPE = 200 : INFINITE PLANE
97! IGRSURF(IGS)%ID_MADYMO :: Coupled madimo surface identifier
98! (computed in Radioss Engine, when receiving Datas from MaDyMo).
99! ID MaDyMo - for entity type which impose surface movement:
100! No systeme MaDyMo for entity type which impose surface movement
101! IGRSURF(IGS)%NB_MADYMO :: No de l'entite qui impose le mvt de la surface.
102! --> No systeme Radioss ou MaDyMO.
103! IGRSURF(IGS)%TYPE_MADYMO :: Entity type which impose surface movement.
104! = 1 : Rigid Body.
105! = 2 : MADYMO Hyper-ellipsoide.
106! IGRSURF(IGS)%IAD_BUFR :: Analytical Surfaces address (reals BUFSF - temp)
107! IGRSURF(IGS)%LEVEL :: FLAG "SUBLEVEL DONE" FOR SURFACES OF SURFACES
108! = 0 ! initialized surface
109! = 1 ! uninitialized surface
110! IGRSURF(IGS)%TH_SURF :: FLAG for /TH/SURF
111! = 0 ! unsaved surface for /TH/SURF
112! = 1 ! saved surface for /TH/SURF
113! IGRSURF(IGS)%ISH4N3N :: FLAG = 1 (only SH4N and SH3N considered - for airbags)
114! IGRSURF(IGS)%NSEG_R2R_ALL :: Multidomaines -> number of segments before split
115! IGRSURF(IGS)%NSEG_R2R_SHARE :: shared on boundary subdomain segments
116! IGRSURF(IGS)%ELTYP(J) :: type of element attached to the segment of the surface
117! ITYP = 0 - surf of segments
118! ITYP = 1 - surf of solids
119! ITYP = 2 - surf of quads
120! ITYP = 3 - surf of SH4N
121! ITYP = 4 - line of trusses
122! ITYP = 5 - line of beams
123! ITYP = 6 - line of springs
124! ITYP = 7 - surf of SH3N
125! ITYP = 8 - line of XELEM (nstrand element)
126! ITYP = 101 - ISOGEOMETRIQUE
127! IGRSURF(IGS)%ELEM(J) :: element attached to the segment of the surface
128! IGRSURF(IGS)%NODES(J,4) :: 4 nodes of the segment for /SURF
129C-----------------------------------------------
130C SURFACES FORMEE DE SURFACES
131C=======================================================================
132 ALLOCATE(itri(5,inseg),stat=ierror)
133 IF(ierror/=0)CALL ancmsg(msgid=268,anmode=aninfo,
134 . msgtype=msgerror,
135 . c1='SURFSURF')
136
137 ALLOCATE(index(2*inseg),stat=ierror)
138 IF(ierror/=0)CALL ancmsg(msgid=268,anmode=aninfo,
139 . msgtype=msgerror,
140 . c1='SURFSURF')
141
142 ALLOCATE(buftmp(inseg),stat=ierror)
143 IF(ierror/=0)CALL ancmsg(msgid=268,anmode=aninfo,
144 . msgtype=msgerror,
145 . c1='SURFSURF')
146
147 IF (flag == 0) icount=0
148 igs =0
149C boucle sur les surfaces
150 CALL hm_option_start('/surf')
151 DO I = 1, NSURF
152 CALL HM_OPTION_READ_KEY(LSUBMODEL,
153 . OPTION_ID = ID,
154 . OPTION_TITR = TITR ,
155 . UNIT_ID = UID,
156 . KEYWORD2 = KEY ,
157 . KEYWORD3 = KEY2)
158
159 SKIPFLAG = 0
160 NSEG=0
161 KLINE=LINE
162
163 IGS=IGS+1
164 IF (KEY(1:4) == 'surf') THEN
165 NB_IDS = 0
166 NB_NEG_IDS = 0
167 CALL HM_GET_INTV('idsmax', NB_IDS, IS_AVAILABLE, LSUBMODEL)
168 CALL HM_GET_INTV('negativeidsmax', NB_NEG_IDS, IS_AVAILABLE, LSUBMODEL)
169 IF (NB_IDS + NB_NEG_IDS == 0) CYCLE
170 ALLOCATE(IDS(NB_IDS + NB_NEG_IDS))
171 DO II = 1, NB_IDS
172 CALL HM_GET_INT_ARRAY_INDEX('ids', IDS(II), II, IS_AVAILABLE, LSUBMODEL)
173 ENDDO
174 DO II = 1, NB_NEG_IDS
175 CALL HM_GET_INT_ARRAY_INDEX('negativeids', IDS(II + NB_IDS), II, IS_AVAILABLE, LSUBMODEL)
176 IDS(II + NB_IDS) = - IDS(II + NB_IDS)
177 ENDDO
178C-----------
179.AND. IF (FLAG == 0 IGRSURF(IGS)%NSEG == -1) THEN
180 DO II = 1, NB_IDS + NB_NEG_IDS
181 ! Get surf internal id
182 IGRS = 0
183 DO K = 1, NSURF
184 IF (IABS(IDS(II)) == IGRSURF(K)%ID) THEN
185 IGRS = K
186 EXIT
187 ENDIF
188 ENDDO
189 IF (IGRS == 0)THEN
190 CALL ANCMSG(MSGID=188, MSGTYPE=MSGWARNING, ANMODE=ANINFO,
191 . I1=ID, C1=TITR, I2=IDS(II))
192.OR. ELSE IF (IGRSURF(IGRS)%TYPE==100 IGRSURF(IGRS)%TYPE==101) THEN
193 CALL ANCMSG(MSGID=187, MSGTYPE=MSGERROR, ANMODE=ANINFO,
194 . I1=ID, C1=TITR, I2=IDS(II))
195 ELSEIF (IGRSURF(IGRS)%LEVEL == 0) THEN
196 IF (ITER > NSURF) THEN
197 CALL ANCMSG(MSGID=189, MSGTYPE=MSGERROR, ANMODE=ANINFO,
198 . C1='surface', c2='SURFACE', c3='SURFACE', c4=titr, c5='SURFACE',
199 . i1=id, i2=igrsurf(igs)%ID)
200 IF(ALLOCATED(itri)) DEALLOCATE(itri)
201 IF(ALLOCATED(index)) DEALLOCATE(index)
202 IF(ALLOCATED(buftmp)) DEALLOCATE(buftmp)
203 RETURN
204 ENDIF
205 igrsurf(igs)%NSEG=-1
206 igrsurf(igs)%LEVEL=0
207 icount=1
208 nseg = 0
209 skipflag = 1
210 EXIT
211 ELSE
212 nsegv=igrsurf(igrs)%NSEG
213 nseg =nseg+nsegv
214 ENDIF
215 ENDDO
216C-----
217 IF (skipflag == 0) THEN
218 inseg=inseg+nisx*nseg
219 igrsurf(igs)%NSEG=nseg
220 CALL my_alloc(igrsurf(igs)%NODES,nseg,4)
221 igrsurf(igs)%NODES(1:nseg,1:4) = 0
222 CALL my_alloc(igrsurf(igs)%ELTYP,nseg)
223 igrsurf(igs)%ELTYP(1:nseg) = 0
224 CALL my_alloc(igrsurf(igs)%ELEM,nseg)
225 igrsurf(igs)%ELEM(1:nseg) = 0
226 ENDIF
227C-----------
228 ELSEIF (flag == 1 .AND. igrsurf(igs)%LEVEL == 0 .AND.
229 . igrsurf(igs)%NSEG > -1) THEN
230 nseg_tot = 0
231 DO ii = 1, nb_ids + nb_neg_ids
232! Get surf internal id
233 igrs = 0
234 DO k = 1, nsurf
235 IF (iabs(ids(ii)) == igrsurf(k)%ID) THEN
236 igrs = k
237 EXIT
238 ENDIF
239 ENDDO
240 IF (igrs == 0) cycle
241 IF (igrsurf(igrs)%NSEG == -1) THEN
242 EXIT
243 ELSE
244 nsegv=igrsurf(igrs)%NSEG
245 IF(ids(ii) > 0)THEN
246 DO l=1,nsegv
247 nseg_tot = nseg_tot + 1
248 igrsurf(igs)%NODES(nseg_tot,1) = igrsurf(igrs)%NODES(l,1)
249 igrsurf(igs)%NODES(nseg_tot,2) = igrsurf(igrs)%NODES(l,2)
250 igrsurf(igs)%NODES(nseg_tot,3) = igrsurf(igrs)%NODES(l,3)
251 igrsurf(igs)%NODES(nseg_tot,4) = igrsurf(igrs)%NODES(l,4)
252 igrsurf(igs)%ELTYP(nseg_tot) = igrsurf(igrs)%ELTYP(l)
253 igrsurf(igs)%ELEM(nseg_tot) = igrsurf(igrs)%ELEM(l)
254 ENDDO
255 ELSE
256 IF(n2d==0)THEN
257 DO l=1,nsegv
258 nseg_tot = nseg_tot + 1
259 igrsurf(igs)%NODES(nseg_tot,1) = igrsurf(igrs)%NODES(l,4)
260 igrsurf(igs)%NODES(nseg_tot,2) = igrsurf(igrs)%NODES(l,3)
261 igrsurf(igs)%NODES(nseg_tot,3) = igrsurf(igrs)%NODES(l,2)
262 igrsurf(igs)%NODES(nseg_tot,4) = igrsurf(igrs)%NODES(l,1)
263 igrsurf(igs)%ELTYP(nseg_tot) = igrsurf(igrs)%ELTYP(l)
264 igrsurf(igs)%ELEM(nseg_tot) = igrsurf(igrs)%ELEM(l)
265 ENDDO
266 ELSE
267 DO l=1,nsegv
268 nseg_tot = nseg_tot + 1
269 igrsurf(igs)%NODES(nseg_tot,1) = igrsurf(igrs)%NODES(l,2)
270 igrsurf(igs)%NODES(nseg_tot,2) = igrsurf(igrs)%NODES(l,1)
271 igrsurf(igs)%NODES(nseg_tot,3) = igrsurf(igrs)%NODES(l,3)
272 igrsurf(igs)%NODES(nseg_tot,4) = igrsurf(igrs)%NODES(l,4)
273 igrsurf(igs)%ELTYP(nseg_tot) = igrsurf(igrs)%ELTYP(l)
274 igrsurf(igs)%ELEM(nseg_tot) = igrsurf(igrs)%ELEM(l)
275 ENDDO
276 ENDIF
277 ENDIF
278 ENDIF
279 ENDDO
280 igrsurf(igs)%LEVEL=1
281 ENDIF
282 DEALLOCATE(ids)
283 ELSEIF (key(1:5) == 'DSURF') THEN
284 nb_ids = 0
285 nb_neg_ids = 0
286 CALL hm_get_intv('idsmax', nb_ids, is_available, lsubmodel)
287 CALL hm_get_intv('negativeIdsmax', nb_neg_ids, is_available, lsubmodel)
288 IF (nb_ids + nb_neg_ids == 0) cycle
289 ALLOCATE(ids(nb_ids + nb_neg_ids))
290 DO ii = 1, nb_ids
291 CALL hm_get_int_array_index('ids', ids(ii), ii, is_available, lsubmodel)
292 ENDDO
293 DO ii = 1, nb_neg_ids
294 CALL hm_get_int_array_index('negativeIds', ids(ii + nb_ids), ii, is_available, lsubmodel)
295 ids(ii + nb_ids) = - ids(ii + nb_ids)
296 ENDDO
297
298 IF (flag == 0 .AND. igrsurf(igs)%NSEG == -1) THEN
299 DO ii = 1, nb_ids + nb_neg_ids
300! Get surf internal id
301 igrs = 0
302 DO k = 1, nsurf
303 IF (iabs(ids(ii)) == igrsurf(k)%ID) THEN
304 igrs = k
305 EXIT
306 ENDIF
307 ENDDO
308 IF (igrs == 0)THEN
309 CALL ancmsg(msgid=188, msgtype=msgwarning, anmode=aninfo,
310 . i1=id, c1=titr, i2=ids(ii))
311 ELSE IF (igrsurf(igrs)%TYPE==100 .OR. igrsurf(igrs)%TYPE==101) THEN
312 CALL ancmsg(msgid=187, msgtype=msgerror, anmode=aninfo,
313 . i1=id, c1=titr, i2=ids(ii))
314 ELSEIF (igrsurf(igrs)%LEVEL == 0) THEN
315 IF (iter > nsurf) THEN
316 CALL ancmsg(msgid=189, msgtype=msgerror, anmode=aninfo,
317 . c1='SURFACE', c2='SURFACE', c3='SURFACE', c4=titr, c5='SURFACE',
318 . i1=id, i2=igrsurf(igs)%ID)
319 IF(ALLOCATED(itri)) DEALLOCATE(itri)
320 IF(ALLOCATED(index)) DEALLOCATE(index)
321 IF(ALLOCATED(buftmp)) DEALLOCATE(buftmp)
322 RETURN
323 ENDIF
324 igrsurf(igs)%NSEG=-1
325 igrsurf(igs)%LEVEL=0
326 icount=1
327 nseg = 0
328 skipflag = 1
329 EXIT
330 ELSE
331 nsegv=igrsurf(igrs)%NSEG
332 nseg =nseg+nsegv
333 ENDIF
334 ENDDO
335
336 IF (skipflag == 0) THEN
337 inseg=inseg+nisx*nseg
338 igrsurf(igs)%NSEG=nseg
339 CALL my_alloc(igrsurf(igs)%NODES,nseg,4)
340 igrsurf(igs)%NODES(1:nseg,1:4) = 0
341 CALL my_alloc(igrsurf(igs)%ELTYP,nseg)
342 igrsurf(igs)%ELTYP(1:nseg) = 0
343 CALL my_alloc(igrsurf(igs)%ELEM,nseg)
344 igrsurf(igs)%ELEM(1:nseg) = 0
345 ENDIF
346C-----------
347 ELSEIF (flag == 1 .AND. igrsurf(igs)%LEVEL == 0 .AND.
348 . igrsurf(igs)%NSEG > -1) THEN
349 nseg = 0
350 nseg_tot = 0
351 iad_tmp = 1
352 DO ii = 1, nb_ids + nb_neg_ids
353! Get surf internal id
354 igrs = 0
355 DO k = 1, nsurf
356 IF (iabs(ids(ii)) == igrsurf(k)%ID) THEN
357 igrs = k
358 EXIT
359 ENDIF
360 ENDDO
361 IF (igrs == 0) cycle
362 IF (igrsurf(igrs)%NSEG == -1) THEN
363 EXIT
364 ELSE
365 nsegv=igrsurf(igrs)%NSEG
366 IF (ids(ii) > 0)THEN
367 DO l=1,nsegv
368 buftmp(iad_tmp)=igrsurf(igrs)%NODES(l,1)
369 iad_tmp=iad_tmp+1
370 buftmp(iad_tmp)=igrsurf(igrs)%NODES(l,2)
371 iad_tmp=iad_tmp+1
372 buftmp(iad_tmp)=igrsurf(igrs)%NODES(l,3)
373 iad_tmp=iad_tmp+1
374 buftmp(iad_tmp)=igrsurf(igrs)%NODES(l,4)
375 iad_tmp=iad_tmp+1
376 buftmp(iad_tmp)=igrsurf(igrs)%ELTYP(l)
377 iad_tmp=iad_tmp+1
378 buftmp(iad_tmp)=igrsurf(igrs)%ELEM(l)
379 iad_tmp=iad_tmp+1
380 ENDDO
381 ELSE
382 DO l=1,nsegv
383 buftmp(iad_tmp)= -igrsurf(igrs)%NODES(l,1)
384 iad_tmp=iad_tmp+1
385 buftmp(iad_tmp)= -igrsurf(igrs)%NODES(l,2)
386 iad_tmp=iad_tmp+1
387 buftmp(iad_tmp)= -igrsurf(igrs)%NODES(l,3)
388 iad_tmp=iad_tmp+1
389 buftmp(iad_tmp)= -igrsurf(igrs)%NODES(l,4)
390 iad_tmp=iad_tmp+1
391 buftmp(iad_tmp)= -igrsurf(igrs)%ELTYP(l)
392 iad_tmp=iad_tmp+1
393 buftmp(iad_tmp)= -igrsurf(igrs)%ELEM(l)
394 iad_tmp=iad_tmp+1
395 ENDDO
396 ENDIF
397 nseg=nseg+nsegv
398 ENDIF
399 ENDDO
400! --------------
401! pretreatment of surface node permutation
402! --------------
403 DO l=1,nseg
404 IF (buftmp((l-1)*nisx+1) /= 0) THEN
405 ! nodes of surface segment
406 inod(1) = iabs(buftmp((l-1)*nisx+1))
407 inod(2) = iabs(buftmp((l-1)*nisx+2))
408 inod(3) = iabs(buftmp((l-1)*nisx+3))
409 inod(4) = iabs(buftmp((l-1)*nisx+4))
410 ! sign of nodes
411 isign_nod(1) = isign(1,buftmp((l-1)*nisx+1))
412 isign_nod(2) = isign(1,buftmp((l-1)*nisx+2))
413 isign_nod(3) = isign(1,buftmp((l-1)*nisx+3))
414 isign_nod(4) = isign(1,buftmp((l-1)*nisx+4))
415 ! check valid nodes
416 nf=0
417 DO j=1,4
418 k=inod(j)
419 IF (k /= 0) THEN
420 nf=nf+1
421 inod(nf)=k
422 ENDIF
423 ENDDO
424 ! check for min node ID
425 imin = 1
426 nmin = inod(imin)
427 DO j=2,nf
428 IF (nmin > inod(j)) imin = j
429 nmin = min(nmin,inod(j))
430 ENDDO
431 ! start node pemutation
432 nn(1) = inod(nperm(imin,1))
433 nn(2) = inod(nperm(imin,2))
434 nn(3) = inod(nperm(imin,3))
435 nn(4) = inod(nperm(imin,4))
436 ! permuted nodes temporary storage for further treatments (sorting, double removing)
437 buftmp((l-1)*nisx+1) = nn(1)*isign_nod(1)
438 buftmp((l-1)*nisx+2) = nn(2)*isign_nod(2)
439 buftmp((l-1)*nisx+3) = nn(3)*isign_nod(3)
440 buftmp((l-1)*nisx+4) = nn(4)*isign_nod(4)
441 ENDIF ! IF (BUFTMP((L-1)*NISX+1) /= 0)
442 ENDDO
443C-------
444 !---------
445 ! 3 node element surface rearrangement ( N4 = N3 ) after permutation
446 !---------
447 DO l=1,nseg
448 inod(1) = buftmp((l-1)*nisx+1)
449 inod(2) = buftmp((l-1)*nisx+2)
450 inod(3) = buftmp((l-1)*nisx+3)
451 inod(4) = buftmp((l-1)*nisx+4)
452!
453 iord = 0
454!
455 IF ( inod(1) /= 0 .OR. inod(2) /= 0 .OR.
456 . inod(3) /= 0 .OR. inod(4) /= 0 ) THEN
457!
458 IF (inod(4) == 0) inod(4)=inod(3)
459!
460 IF (inod(1) == inod(4)) THEN
461 inod(4)=inod(3)
462 iord = iord + 1
463 ELSEIF (inod(2) == inod(3)) THEN
464 inod(3)=inod(4)
465 iord = iord + 1
466 ELSEIF(inod(1) == inod(2)) THEN
467 inod(2)=inod(3)
468 inod(3)=inod(4)
469 iord = iord + 1
470 ENDIF
471 ENDIF
472!
473 IF (iord > 0) THEN
474 buftmp((l-1)*nisx+1) = inod(1)
475 buftmp((l-1)*nisx+2) = inod(2)
476 buftmp((l-1)*nisx+3) = inod(3)
477 buftmp((l-1)*nisx+4) = inod(4)
478 ENDIF ! IF (IORD > 0)
479 ENDDO ! DO L=1,NSEG
480C-------
481C------------------------------
482C sorting
483C------------------------------
484 DO l=1,nseg
485 index(l)=l
486 IF(buftmp((l-1)*nisx+1) /= 0) THEN
487 itri(1,l) = iabs(buftmp((l-1)*nisx+1))
488 itri(2,l) = iabs(buftmp((l-1)*nisx+2))
489 itri(3,l) = iabs(buftmp((l-1)*nisx+3))
490 itri(4,l) = iabs(buftmp((l-1)*nisx+4))
491 itri(5,l) = buftmp((l-1)*nisx+1) / iabs(buftmp((l-1)*nisx+1))
492 ENDIF
493 ENDDO
494 CALL my_orders(0,iwork,itri,index,nseg,5)
495C------------------------------
496C Segment deletion
497C------------------------------
498 l = 1
499 DO WHILE( l < nseg)
500 IF( iabs(buftmp( (index(l)-1) * nisx + 1)) == iabs(buftmp( (index(l+1)-1) * nisx + 1)) .AND.
501 . iabs(buftmp( (index(l)-1) * nisx + 2)) == iabs(buftmp( (index(l+1)-1) * nisx + 2)).AND.
502 . iabs(buftmp( (index(l)-1) * nisx + 3)) == iabs(buftmp( (index(l+1)-1) * nisx + 3)).AND.
503 . iabs(buftmp( (index(l)-1) * nisx + 4)) == iabs(buftmp( (index(l+1)-1) * nisx + 4)) ) THEN
504 IF( itri(5,index(l)) + itri(5,index(l+1)) == 0)THEN
505 DO j=1,nisx
506 buftmp((index(l)-1) *nisx+j) = 0
507 buftmp((index(l+1)-1)*nisx+j) = -iabs(buftmp((index(l+1)-1)*nisx+j))
508 ENDDO
509 ELSEIF( itri(5,index(l)) + itri(5,index(l+1)) /= 0)THEN
510 DO j=1,nisx
511 buftmp((index(l)-1) *nisx+j) = 0
512 buftmp((index(l+1)-1)*nisx+j) = buftmp((index(l+1)-1)*nisx+j)
513 ENDDO
514 ENDIF
515 END IF
516 l = l + 1
517 ENDDO
518C------ for re-allocation %NODES
519 nsegv = 0
520 DO l=1,nseg
521 IF((buftmp( (index(l)-1) *nisx+1) > 0) .OR.
522 . (buftmp( (index(l)-1) *nisx+2) > 0) .OR.
523 . (buftmp( (index(l)-1) *nisx+3) > 0) .OR.
524 . (buftmp( (index(l)-1) *nisx+4) > 0) )THEN
525 nsegv=nsegv+1
526 ENDIF
527 ENDDO
528 IF (nsegv /= nseg) THEN
529 DEALLOCATE(igrsurf(igs)%NODES)
530 CALL my_alloc(igrsurf(igs)%NODES,nsegv,4)
531 igrsurf(igs)%NODES(1:nsegv,1:4) = 0
532 ENDIF
533 DO l=1,nseg
534 IF((buftmp( (index(l)-1) *nisx+1) > 0) .OR.
535 . (buftmp( (index(l)-1) *nisx+2) > 0) .OR.
536 . (buftmp( (index(l)-1) *nisx+3) > 0) .OR.
537 . (buftmp( (index(l)-1) *nisx+4) > 0) )THEN
538 nseg_tot=nseg_tot+1
539 igrsurf(igs)%NODES(nseg_tot,1) = buftmp((index(l)-1) *nisx+1)
540 igrsurf(igs)%NODES(nseg_tot,2) = buftmp((index(l)-1) *nisx+2)
541 igrsurf(igs)%NODES(nseg_tot,3) = buftmp((index(l)-1) *nisx+3)
542 igrsurf(igs)%NODES(nseg_tot,4) = buftmp((index(l)-1) *nisx+4)
543 igrsurf(igs)%ELTYP(nseg_tot) = buftmp((index(l)-1) *nisx+5)
544 igrsurf(igs)%ELEM(nseg_tot) = buftmp((index(l)-1) *nisx+6)
545 ENDIF
546 ENDDO
547 igrsurf(igs)%NSEG=nseg_tot
548 igrsurf(igs)%LEVEL=1
549C-----------
550 ENDIF
551 DEALLOCATE(ids)
552 ENDIF ! IF (FLAG == 0 .AND. ISURF(2,IGS) == -1)
553 ENDDO ! DO I=1,NSURF
554C-----------
555 IF(ALLOCATED(itri)) DEALLOCATE(itri)
556 IF(ALLOCATED(index)) DEALLOCATE(index)
557 IF(ALLOCATED(buftmp)) DEALLOCATE(buftmp)
558
559 RETURN
560 900 CONTINUE
561 CALL ancmsg(msgid=189,
562 . msgtype=msgerror,
563 . anmode=aninfo,
564 . c1='SURFACE',
565 . c2='SURFACE',
566 . i1=id,
567 . c3='SURFACE',
568 . c4=titr,
569 . c5='SURFACE',
570 . i2=igrsurf(igs)%ID)
571 IF(ALLOCATED(itri)) DEALLOCATE(itri)
572 IF(ALLOCATED(index)) DEALLOCATE(index)
573 IF(ALLOCATED(buftmp)) DEALLOCATE(buftmp)
574
575 RETURN
576C-----------
577 IF(ALLOCATED(itri)) DEALLOCATE(itri)
578 IF(ALLOCATED(index)) DEALLOCATE(index)
579 IF(ALLOCATED(buftmp)) DEALLOCATE(buftmp)
580 RETURN
581 END
hm_get_int_array_index
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
Definition hm_get_int_array_index.F:164
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
hm_read_surfsurf
subroutine hm_read_surfsurf(igrsurf, inseg, flag, icount, iter, nsets, lsubmodel)
Definition hm_read_surfsurf.F:40
min
#define min(a, b)
Definition macros.h:20
id
initmumps id
Definition multiplerhs_example.m:4
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
groupdef_mod
Definition groupdef_mod.F:662
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
radioss
program radioss
Definition radioss.F:34
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
submodel_mod::submodel_data
Definition submodel_mod.F:723