OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_tria.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_tria ../starter/source/elements/reader/hm_read_tria.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| anodset ../starter/source/output/analyse/analyse_node.c
30!|| usr2sys ../starter/source/system/sysfus.F
31!|| vdouble ../starter/source/system/sysfus.F
32!||--- uses -----------------------------------------------------
33!|| message_mod ../starter/share/message_module/message_mod.F
34!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
35!|| submodel_mod ../starter/share/modules1/submodel_mod.F
36!||====================================================================
37 SUBROUTINE hm_read_tria(IXTG ,ITAB ,ITABM1 ,IPART ,IPARTTG ,
38 . PM ,GEO ,ICNOD ,IGEO ,IPM ,
39 . UNITAB ,LSUBMODEL)
40C-----------------------------------------------
41C ROUTINE DESCRIPTION :
42C ===================
43C READ /TRIA ELEMENTS USING HM_READER
44C-----------------------------------------------
45C DUMMY ARGUMENTS DESCRIPTION:
46C ===================
47C
48C NAME DESCRIPTION
49C
50C IXTG /TRIA ARRAY : CONNECTIVITY, ID, MID PID
51C ITAB USER ID OF NODES
52C ITABM1 REVERSE TAB ITAB
53C IPART PART ARRAY
54C IPARTTG INTERNAL PART ID OF A GIVEN TRIA (INTERNAL ID)
55C PM MATERIAL ARRAY
56C GEO PROP ARRAY (REAL)
57C ICNOD FLAG FOR TRIA WITH ISH3N = 31
58C IGEO PROP ARRAY (INTEGER)
59C IPM MATERIAL ARRAY (INTEGER)
60C UNITAB UNIT ARRAY
61C LSUBMODEL SUBMODEL STRUCTURE
62C-----------------------------------------------
63C M o d u l e s
64C-----------------------------------------------
65 USE unitab_mod
66 USE message_mod
67 USE submodel_mod , ONLY : submodel_data
68 USE reader_old_mod , ONLY : line
69 USE user_id_mod , ONLY : id_limit
70 use element_mod , only : nixtg
71C--------------------------------------------------------
72C READING DES ELEMENTS 2D TRIANGULAIRES
73C--------------------------------------------------------
74C-----------------------------------------------
75C I m p l i c i t T y p e s
76C-----------------------------------------------
77#include "implicit_f.inc"
78C-----------------------------------------------
79C A n a l y s e M o d u l e
80C-----------------------------------------------
81#include "analyse_name.inc"
82C-----------------------------------------------
83C C o m m o n B l o c k s
84C-----------------------------------------------
85#include "com04_c.inc"
86#include "units_c.inc"
87#include "scr03_c.inc"
88#include "scr17_c.inc"
89#include "param_c.inc"
90#include "remesh_c.inc"
91C-----------------------------------------------
92C D u m m y A r g u m e n t s
93C-----------------------------------------------
94C INPUT ARGUMENTS
95 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
96 INTEGER,INTENT(IN)::ITAB(*)
97 INTEGER,INTENT(IN)::ITABM1(*)
98 INTEGER,INTENT(IN)::IPART(LIPART1,*)
99 INTEGER,INTENT(IN)::IGEO(NPROPGI,NUMGEO)
100 INTEGER,INTENT(IN)::IPM(NPROPMI,*)
101 my_real,
102 . INTENT(IN)::geo(npropg,*)
103 my_real,
104 . INTENT(IN)::pm(npropm,*)
105 TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)
106C OUTPUT ARGUMENTS
107 INTEGER,INTENT(OUT)::IXTG(NIXTG,*)
108 INTEGER,INTENT(OUT)::IPARTTG(*)
109 INTEGER,INTENT(OUT)::ICNOD(*)
110C-----------------------------------------------
111C L o c a l V a r i a b l e s
112C-----------------------------------------------
113 my_real
114 . bid,fac_l
115 INTEGER I, J, I1, I2, ID,IDS,IPID,MT,N,MID,PID,UID,STAT,IPARTTG_TMP
116 INTEGER INDEX_PART
117 CHARACTER*40 MESS
118 DATA mess /'2D TRIANGULAR ELEMENT DEFINITION '/
119 INTEGER ISH3N,KK,IFLAGUNIT
120 INTEGER, DIMENSION(:), ALLOCATABLE :: SUB_TRIA,UID_TRIA,TMP_IPARTTG
121 INTEGER, DIMENSION(:,:), ALLOCATABLE :: TMP_IXTG
122C-----------------------------------------------
123C FUNCTION
124C-----------------------------------------------
125 INTEGER USR2SYS
126C=======================================================================
127C--------------------------------------------------
128C ALLOCS & INITS
129c use NUMELTG0 IN PLACE OF NUMELTG ( NBADMESH routine is modifying NUMELTG )
130C--------------------------------------------------
131 ALLOCATE (sub_tria(numeltg0),stat=stat)
132 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
133 . msgtype=msgerror,
134 . c1='SUB_TRIA')
135 ALLOCATE (uid_tria(numeltg0),stat=stat)
136 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
137 . msgtype=msgerror,
138 . c1='UID_TRIA')
139 ALLOCATE (tmp_ixtg(nixtg,numeltg0),stat=stat)
140 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
141 . msgtype=msgerror,
142 . c1='TMP_IXTG')
143 ALLOCATE (tmp_iparttg(numeltg0),stat=stat)
144 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
145 . msgtype=msgerror,
146 . c1='TMP_IPARTTG')
147 sub_tria(1:numeltg0) = 0
148 uid_tria(1:numeltg0) = 0
149 tmp_ixtg(1:nixtg,1:numeltg0) = 0
150 tmp_iparttg(1:numeltg0) = 0
151 index_part = 1
152 uid = -1
153 kk=3
154 i = 0
155C--------------------------------------------------
156C READING TRIAS INPUTS IN HM STRUCTURE
157C--------------------------------------------------
158 CALL cpp_tria_read(tmp_ixtg,nixtg,tmp_iparttg,sub_tria,uid_tria)
159C--------------------------------------------------
160C FILL OTHER STRUCTURES + CHECKS
161C--------------------------------------------------
162 numeltg6 = 0
163 DO WHILE (kk <= 6)
164 DO n=1,numeltg0
165 iparttg_tmp = tmp_iparttg(n)
166
167 IF( ipart(4,index_part) /= iparttg_tmp)THEN
168 DO j=1,npart
169 IF(ipart(4,j)== iparttg_tmp )index_part = j
170 ENDDO
171 ENDIF
172 ish3n = igeo(18,ipart(2,index_part))
173 IF(kk == 6 .AND. ish3n==31) numeltg6 = numeltg6 + 1
174
175 IF((kk==3.AND.ish3n/=31).OR.(kk==6.AND.ish3n==31))THEN
176 i = i + 1
177 icnod(i)=kk
178 DO j=1,nixtg
179 ixtg(j,i) = tmp_ixtg(j,n)
180 ENDDO
181 iparttg(i) = tmp_iparttg(n)
182C--------------------------------------------------
183 IF(sub_tria(n) /= 0)THEN
184 IF(uid_tria(n) == 0 .AND. lsubmodel(sub_tria(n))%UID /= 0)
185 . uid_tria(n) = lsubmodel(sub_tria(n))%UID
186 ENDIF
187C--------------------------------------------------
188C UNITS
189C--------------------------------------------------
190 IF(uid_tria(n) /= uid )THEN
191 uid = uid_tria(n)
192 iflagunit = 0
193 DO j=1,unitab%NUNITS
194 IF (unitab%UNIT_ID(j) == uid) THEN
195 fac_l = unitab%FAC_L(j)
196 iflagunit = 1
197 ENDIF
198 ENDDO
199 IF (uid/=0.AND.iflagunit==0) THEN
200 CALL ancmsg(msgid=643,anmode=aninfo,msgtype=msgerror,
201 . i1=uid,c1='/TRIA')
202 ENDIF
203 ENDIF
204C--------------------------------------------------
205C INTERNAL PART ID
206C--------------------------------------------------
207 IF( ipart(4,index_part) /= iparttg(i) )THEN
208 DO j=1,npart
209 IF(ipart(4,j)== iparttg(i) ) index_part = j
210 ENDDO
211 ENDIF
212 IF( ipart(4,index_part) /= iparttg(i) ) THEN
213 CALL ancmsg(msgid=402,
214 . msgtype=msgerror,
215 . anmode=aninfo_blind_1,
216 . c1="TRIA",
217 . i1=iparttg(i),
218 . i2=iparttg(i),
219 . prmod=msg_cumu)
220 ENDIF
221 iparttg(i) = index_part
222C--------------------------------------------------
223 mt=ipart(1,index_part)
224 ipid=ipart(2,index_part)
225 ixtg(1,i)=mt
226 ixtg(5,i)=ipid
227 IF (ixtg(nixtg,i)>id_limit%GLOBAL)THEN
228 CALL ancmsg(msgid=509,anmode=aninfo,msgtype=msgerror,
229 . i1=ixtg(nixtg,i),c1=line,c2='/TRIA')
230 ELSEIF (nadmesh/=0.AND.ixtg(nixtg,i)>id_limit%ADMESH)THEN
231 CALL ancmsg(msgid=1069,anmode=aninfo,msgtype=msgerror,
232 . i1=ixtg(nixtg,i),c1=line,c2='/TRIA')
233 ENDIF
234
235 DO j=2,4
236 ixtg(j,i)=usr2sys(ixtg(j,i),itabm1,mess,id)
237 CALL anodset(ixtg(j,i), check_shell)
238 ENDDO
239 ENDIF
240 IF (i == numeltg0) kk = 7
241 ENDDO
242 IF (i < numeltg0) THEN
243 kk = 6
244 ELSE
245c exit from DOWHILE (kk <=6)
246 kk = 7
247 ENDIF
248 ENDDO
249 IF(ALLOCATED(sub_tria)) DEALLOCATE(sub_tria)
250 IF(ALLOCATED(uid_tria)) DEALLOCATE(uid_tria)
251
252 IF(ALLOCATED(tmp_ixtg)) DEALLOCATE(tmp_ixtg)
253 IF(ALLOCATED(tmp_iparttg)) DEALLOCATE(tmp_iparttg)
254C
255 i1=1
256 i2=min0(50,numeltg0)
257C
258 IF(ipri>=5)THEN
259 90 WRITE (iout,'(//A/A//A/)')' 2D TRIANGULAR ELEMENTS ',
260 & ' ELEMENT INTERNAL MATER PRSET NODE1 NODE2 NODE3'
261 DO i=i1,i2
262 mid = ipm(1,ixtg(1,i))
263 pid = igeo(1,ixtg(5,i))
264 WRITE (iout,'(7(I10,1X))') ixtg(nixtg,i),i,mid,pid,
265 . (itab(ixtg(j,i)),j=2,4)
266 ENDDO
267 IF(i2==numeltg0)GOTO 200
268 i1=i1+50
269 i2=min0(i2+50,numeltg0)
270 GOTO 90
271 ENDIF
272C
273 200 CONTINUE
274C-----------
275 CALL ancmsg(msgid=402,
276 . msgtype=msgerror,
277 . anmode=aninfo_blind_1,
278 . prmod=msg_print)
279C-------------------------------------
280C Search for double IDs
281C-------------------------------------
282 ids = 79
283 i = 0
284 j = 0
285c
286 CALL vdouble(ixtg(nixtg,1),nixtg,numeltg0,mess,0,bid)
287c CALL ANCNTG(IDS,I,J)
288 ids = 44
289c CALL ANCHECK(IDS)
290C
291 RETURN
292 END
anodset
void anodset(int *id, int *type)
Definition analyse_node.c:321
my_real
#define my_real
Definition cppsort.cpp:32
hm_read_tria
subroutine hm_read_tria(ixtg, itab, itabm1, ipart, iparttg, pm, geo, icnod, igeo, ipm, unitab, lsubmodel)
Definition hm_read_tria.F:40
id
initmumps id
Definition multiplerhs_example.m:4
message_mod
Definition message_mod.F:1257
submodel_mod
Definition submodel_mod.F:717
unitab_mod
Definition unitab_mod.F:517
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:895
vdouble
subroutine vdouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:868
submodel_mod::submodel_data
Definition submodel_mod.F:728