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!|| nintrn ../starter/source/system/nintrn.F
31!|| usr2sys ../starter/source/system/sysfus.F
32!|| vdouble ../starter/source/system/sysfus.F
33!||--- uses -----------------------------------------------------
34!|| message_mod ../starter/share/message_module/message_mod.F
35!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
36!|| submodel_mod ../starter/share/modules1/submodel_mod.F
37!||====================================================================
38 SUBROUTINE hm_read_tria(IXTG ,ITAB ,ITABM1 ,IPART ,IPARTTG ,
39 . PM ,GEO ,ICNOD ,IGEO ,IPM ,
40 . UNITAB ,LSUBMODEL)
41C-----------------------------------------------
42C ROUTINE DESCRIPTION :
43C ===================
44C READ /TRIA ELEMENTS USING HM_READER
45C-----------------------------------------------
46C DUMMY ARGUMENTS DESCRIPTION:
47C ===================
48C
49C NAME DESCRIPTION
50C
51C IXTG /TRIA ARRAY : CONNECTIVITY, ID, MID PID
52C ITAB USER ID OF NODES
53C ITABM1 REVERSE TAB ITAB
54C IPART PART ARRAY
55C IPARTTG INTERNAL PART ID OF A GIVEN TRIA (INTERNAL ID)
56C PM MATERIAL ARRAY
57C GEO PROP ARRAY (REAL)
58C ICNOD FLAG FOR TRIA WITH ISH3N = 31
59C IGEO PROP ARRAY (INTEGER)
60C IPM MATERIAL ARRAY (INTEGER)
61C UNITAB UNIT ARRAY
62C LSUBMODEL SUBMODEL STRUCTURE
63C-----------------------------------------------
64C M o d u l e s
65C-----------------------------------------------
66 USE unitab_mod
67 USE message_mod
68 USE submodel_mod , ONLY : nsubmod, submodel_data
69 USE reader_old_mod , ONLY : line
70 USE user_id_mod , ONLY : id_limit
71C--------------------------------------------------------
72C LECTURE 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,JC,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
126 INTEGER NINTRN
127C=======================================================================
128C--------------------------------------------------
129C ALLOCS & INITS
130c use NUMELTG0 IN PLACE OF NUMELTG ( NBADMESH routine is modifying NUMELTG )
131C--------------------------------------------------
132 ALLOCATE (sub_tria(numeltg0),stat=stat)
133 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
134 . msgtype=msgerror,
135 . c1='SUB_TRIA')
136 ALLOCATE (uid_tria(numeltg0),stat=stat)
137 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
138 . msgtype=msgerror,
139 . c1='UID_TRIA')
140 ALLOCATE (tmp_ixtg(nixtg,numeltg0),stat=stat)
141 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
142 . msgtype=msgerror,
143 . c1='TMP_IXTG')
144 ALLOCATE (tmp_iparttg(numeltg0),stat=stat)
145 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
146 . msgtype=msgerror,
147 . c1='TMP_IPARTTG')
148 sub_tria(1:numeltg0) = 0
149 uid_tria(1:numeltg0) = 0
150 tmp_ixtg(1:nixtg,1:numeltg0) = 0
151 tmp_iparttg(1:numeltg0) = 0
152 index_part = 1
153 uid = -1
154 kk=3
155 i = 0
156C--------------------------------------------------
157C READING TRIAS INPUTS IN HM STRUCTURE
158C--------------------------------------------------
159 CALL cpp_tria_read(tmp_ixtg,nixtg,tmp_iparttg,sub_tria,uid_tria)
160C--------------------------------------------------
161C FILL OTHER STRUCTURES + CHECKS
162C--------------------------------------------------
163 numeltg6 = 0
164 DO WHILE (kk <= 6)
165 DO n=1,numeltg0
166 iparttg_tmp = tmp_iparttg(n)
167
168 IF( ipart(4,index_part) /= iparttg_tmp)THEN
169 DO j=1,npart
170 IF(ipart(4,j)== iparttg_tmp )index_part = j
171 ENDDO
172 ENDIF
173 ish3n = igeo(18,ipart(2,index_part))
174 IF(kk == 6 .AND. ish3n==31) numeltg6 = numeltg6 + 1
175
176 IF((kk==3.AND.ish3n/=31).OR.(kk==6.AND.ish3n==31))THEN
177 i = i + 1
178 icnod(i)=kk
179 DO j=1,nixtg
180 ixtg(j,i) = tmp_ixtg(j,n)
181 ENDDO
182 iparttg(i) = tmp_iparttg(n)
183C--------------------------------------------------
184 IF(sub_tria(n) /= 0)THEN
185 IF(uid_tria(n) == 0 .AND. lsubmodel(sub_tria(n))%UID /= 0)
186 . uid_tria(n) = lsubmodel(sub_tria(n))%UID
187 ENDIF
188C--------------------------------------------------
189C UNITS
190C--------------------------------------------------
191 IF(uid_tria(n) /= uid )THEN
192 uid = uid_tria(n)
193 iflagunit = 0
194 DO j=1,unitab%NUNITS
195 IF (unitab%UNIT_ID(j) == uid) THEN
196 fac_l = unitab%FAC_L(j)
197 iflagunit = 1
198 ENDIF
199 ENDDO
200 IF (uid/=0.AND.iflagunit==0) THEN
201 CALL ancmsg(msgid=643,anmode=aninfo,msgtype=msgerror,
202 . i1=uid,c1='/TRIA')
203 ENDIF
204 ENDIF
205C--------------------------------------------------
206C INTERNAL PART ID
207C--------------------------------------------------
208 IF( ipart(4,index_part) /= iparttg(i) )THEN
209 DO j=1,npart
210 IF(ipart(4,j)== iparttg(i) ) index_part = j
211 ENDDO
212 ENDIF
213 IF( ipart(4,index_part) /= iparttg(i) ) THEN
214 CALL ancmsg(msgid=402,
215 . msgtype=msgerror,
216 . anmode=aninfo_blind_1,
217 . c1="TRIA",
218 . i1=iparttg(i),
219 . i2=iparttg(i),
220 . prmod=msg_cumu)
221 ENDIF
222 iparttg(i) = index_part
223C--------------------------------------------------
224 mt=ipart(1,index_part)
225 ipid=ipart(2,index_part)
226 ixtg(1,i)=mt
227 ixtg(5,i)=ipid
228 IF (ixtg(nixtg,i)>id_limit%GLOBAL)THEN
229 CALL ancmsg(msgid=509,anmode=aninfo,msgtype=msgerror,
230 . i1=ixtg(nixtg,i),c1=line,c2='/TRIA')
231 ELSEIF (nadmesh/=0.AND.ixtg(nixtg,i)>id_limit%ADMESH)THEN
232 CALL ancmsg(msgid=1069,anmode=aninfo,msgtype=msgerror,
233 . i1=ixtg(nixtg,i),c1=line,c2='/TRIA')
234 ENDIF
235
236 DO j=2,4
237 ixtg(j,i)=usr2sys(ixtg(j,i),itabm1,mess,id)
238 CALL anodset(ixtg(j,i), check_shell)
239 ENDDO
240 ENDIF
241 IF (i == numeltg0) kk = 7
242 ENDDO
243 IF (i < numeltg0) THEN
244 kk = 6
245 ELSE
246c exit from DOWHILE (kk <=6)
247 kk = 7
248 ENDIF
249 ENDDO
250 IF(ALLOCATED(sub_tria)) DEALLOCATE(sub_tria)
251 IF(ALLOCATED(uid_tria)) DEALLOCATE(uid_tria)
252
253 IF(ALLOCATED(tmp_ixtg)) DEALLOCATE(tmp_ixtg)
254 IF(ALLOCATED(tmp_iparttg)) DEALLOCATE(tmp_iparttg)
255C
256 i1=1
257 i2=min0(50,numeltg0)
258C
259 IF(ipri>=5)THEN
260 90 WRITE (iout,'(//A/A//A/)')' 2D TRIANGULAR ELEMENTS ',
261 & ' ELEMENT INTERNAL MATER PRSET NODE1 NODE2 NODE3'
262 DO i=i1,i2
263 mid = ipm(1,ixtg(1,i))
264 pid = igeo(1,ixtg(5,i))
265 WRITE (iout,'(7(I10,1X))') ixtg(nixtg,i),i,mid,pid,
266 . (itab(ixtg(j,i)),j=2,4)
267 ENDDO
268 IF(i2==numeltg0)GOTO 200
269 i1=i1+50
270 i2=min0(i2+50,numeltg0)
271 GOTO 90
272 ENDIF
273C
274 200 CONTINUE
275C-----------
276 CALL ancmsg(msgid=402,
277 . msgtype=msgerror,
278 . anmode=aninfo_blind_1,
279 . prmod=msg_print)
280C-------------------------------------
281C Recherche des ID doubles
282C-------------------------------------
283 ids = 79
284 i = 0
285 j = 0
286c
287 CALL vdouble(ixtg(nixtg,1),nixtg,numeltg0,mess,0,bid)
288c CALL ANCNTG(IDS,I,J)
289 ids = 44
290c CALL ANCHECK(IDS)
291C
292 RETURN
293 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:41
message_mod
Definition message_mod.F:1249
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
unitab_mod
Definition unitab_mod.F:513
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
vdouble
subroutine vdouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:884
submodel_mod::submodel_data
Definition submodel_mod.F:723