OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_quad.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_quad ../starter/source/elements/reader/hm_read_quad.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_quad(IXQ ,ITAB ,ITABM1,IPART,IPARTQ,
39 . IPM ,IGEO ,UNITAB ,LSUBMODEL)
40C-----------------------------------------------
41C ROUTINE DESCRIPTION :
42C ===================
43C READ /QUAD ELEMENTS USING HM_READER
44C-----------------------------------------------
45C DUMMY ARGUMENTS DESCRIPTION:
46C ===================
47C
48C NAME DESCRIPTION
49C
50C IXQ /QUAD ARRAY : CONNECTIVITY, ID, MID PID
51C ITAB USER ID OF NODES
52C ITABM1 REVERSE TAB ITAB
53C IPART PART ARRAY
54C IPARTQ INTERNAL PART ID OF A GIVEN QUAD (INTERNAL ID)
55C IPM MATERIAL ARRAY (INTEGER)
56C IGEO PROP ARRAY (INTEGER)
57C UNITAB UNIT ARRAY
58C LSUBMODEL SUBMODEL STRUCTURE
59C-----------------------------------------------
60C M o d u l e s
61C-----------------------------------------------
62 USE unitab_mod
63 USE message_mod
64 USE submodel_mod , ONLY : nsubmod, submodel_data
65 USE names_and_titles_mod , ONLY : nchartitle
66 USE reader_old_mod , ONLY : line
67 USE user_id_mod , ONLY : id_limit
68C--------------------------------------------------------
69C LECTURE DES ELEMENTS QUAD 4 NOEUDS
70C VERSIION NUMEROTATION DES NOEUDS LIBRE/MARS 90/DIM
71C--------------------------------------------------------
72C
73C-----------------------------------------------
74C I m p l i c i t T y p e s
75C-----------------------------------------------
76#include "implicit_f.inc"
77C-----------------------------------------------
78C A n a l y s e M o d u l e
79C-----------------------------------------------
80#include "analyse_name.inc"
81C-----------------------------------------------
82C C o m m o n B l o c k s
83C-----------------------------------------------
84#include "scr17_c.inc"
85#include "com04_c.inc"
86#include "units_c.inc"
87#include "scr03_c.inc"
88#include "param_c.inc"
89#include "titr_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,*)
100 INTEGER,INTENT(IN)::IPM(NPROPMI,*)
101 TYPE(submodel_data),INTENT(IN)::LSUBMODEL(NSUBMOD)
102C OUTPUT ARGUMENTS
103 INTEGER,INTENT(OUT)::IXQ(NIXQ,*)
104 INTEGER,INTENT(OUT)::IPARTQ(*)
105C-----------------------------------------------
106C L o c a l V a r i a b l e s
107C-----------------------------------------------
108 INTEGER I, J, I1, I2, ID,IDS,IPID,MT,N,MID,PID,UID,NDEGEN,JC,STAT,
109 . iflagunit,flag_fmt,flag_fmt_tmp,ifix_tmp,ishxfem,ioutn,ierror,index_part
110 CHARACTER MESS*40, MESS2*40
111 CHARACTER(LEN=NCHARTITLE) :: TITR
112 my_real bid,fac_l
113 INTEGER, DIMENSION(:), ALLOCATABLE :: SUB_QUAD,UID_QUAD
114C-----------------------------------------------
115C E x t e r n a l F u n c t i o n s
116C-----------------------------------------------
117 INTEGER NINTRN
118 INTEGER USR2SYS
119 DATA mess/'2D QUAD ELEMENTS DEFINITION '/
120 DATA mess2/'2D QUAD ELEMENTS SELECTION FOR TH PLOT '/
121C=======================================================================
122C--------------------------------------------------
123C ALLOCS & INITS
124c use NUMELQ IN PLACE OF NUMELC ( NBADMESH routine is modifying NUMELC )
125C--------------------------------------------------
126 ALLOCATE (sub_quad(numelq),stat=stat)
127 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,c1='SUB_QUAD')
128 ALLOCATE (uid_quad(numelq),stat=stat)
129 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,c1='UID_QUAD')
130 sub_quad(1:numelq) = 0
131 uid_quad(1:numelq) = 0
132 ndegen = 0
133 index_part = 1
134 uid = -1
135C--------------------------------------------------
136C READING QUADS INPUTS IN HM STRUCTURE
137C--------------------------------------------------
138 CALL cpp_quad_read(ixq,nixq,ipartq,sub_quad,uid_quad)
139C--------------------------------------------------
140C FILL OTHER STRUCTURES + CHECKS
141C--------------------------------------------------
142 DO i=1,numelq
143C--------------------------------------------------
144C SUBMODEL OFFSET
145C--------------------------------------------------
146 IF(sub_quad(i) /= 0)THEN
147 IF(uid_quad(i) == 0 .AND. lsubmodel(sub_quad(i))%UID /= 0) uid_quad(i) = lsubmodel(sub_quad(i))%UID
148 ENDIF
149C--------------------------------------------------
150C UNITS
151C--------------------------------------------------
152 IF(uid_quad(i) /= uid )THEN
153 uid = uid_quad(i)
154 iflagunit = 0
155 DO j=1,unitab%NUNITS
156 IF (unitab%UNIT_ID(j) == uid) THEN
157 fac_l = unitab%FAC_L(j)
158 iflagunit = 1
159 ENDIF
160 ENDDO
161 IF (uid/=0.AND.iflagunit==0) THEN
162 CALL ancmsg(msgid=643,anmode=aninfo,msgtype=msgerror,i1=uid,c1='/QUAD')
163 ENDIF
164 ENDIF
165C--------------------------------------------------
166C INTERNAL PART ID
167C--------------------------------------------------
168 IF( ipart(4,index_part) /= ipartq(i) )THEN
169 DO j=1,npart
170 IF(ipart(4,j)== ipartq(i) ) index_part = j
171 ENDDO
172 ENDIF
173 IF(ipart(4,index_part) /= ipartq(i)) THEN
174 CALL ancmsg(msgid=402,msgtype=msgerror,anmode=aninfo_blind_1,c1="QUAD",i1=ipartq(i),i2=ipartq(i),prmod=msg_cumu)
175 ENDIF
176 ipartq(i) = index_part
177C--------------------------------------------------
178 mt=ipart(1,index_part)
179 ipid=ipart(2,index_part)
180 ixq(1,i)=mt
181 ixq(6,i)=ipid
182 IF (ixq(nixq,i)>id_limit%GLOBAL)THEN
183 CALL ancmsg(msgid=509,anmode=aninfo,msgtype=msgerror,i1=ixq(nixq,i),c1=line,c2='/QUAD')
184 ELSEIF (nadmesh/=0.AND.ixq(nixq,i)>id_limit%ADMESH)THEN
185 CALL ancmsg(msgid=1069,anmode=aninfo,msgtype=msgerror,i1=ixq(nixq,i),c1=line,c2='/QUAD')
186 ENDIF
187 IF(( ixq(4,i) == ixq(5,i)) .OR. ( ixq(5,i) == 0 )) THEN
188 ndegen = ndegen + 1
189 CALL ancmsg(msgid=430,msgtype=msgwarning,i1=ixq(nixq,i),anmode=aninfo_blind_2,prmod=msg_cumu)
190 ENDIF
191
192 DO j=2,5
193 ixq(j,i)=usr2sys(ixq(j,i),itabm1,mess,id)
194 CALL anodset(ixq(j,i), check_shell)
195 ENDDO
196
197 ENDDO
198
199 IF(ALLOCATED(sub_quad)) DEALLOCATE(sub_quad)
200 IF(ALLOCATED(uid_quad)) DEALLOCATE(uid_quad)
201
202 i1=1
203 i2=min0(50,numelq)
204
205 IF(ipri>=5)THEN
206 90 WRITE (iout,'(//A/A//A,A/)')titre(110),titre(111),titre(102),titre(105)
207 DO i=i1,i2
208 mid = ipm(1,ixq(1,i))
209 pid = igeo(1,ixq(6,i))
210 WRITE (iout,fmt='(8(I10,1X),1PG20.13,1X,1PG20.13)') ixq(nixq,i),i,mid,pid,(itab(ixq(j,i)),j=2,5)
211 ENDDO
212 IF(i2==numelq)GOTO 200
213 i1=i1+50
214 i2=min0(i2+50,numelq)
215 GOTO 90
216 ENDIF
217C
218 200 CONTINUE
219C-----------
220 CALL ancmsg(msgid=402,msgtype=msgerror,anmode=aninfo_blind_1,prmod=msg_print)
221C-------------------------------------
222C Search Duplicated Ids
223C-------------------------------------
224 ids = 79
225 i = 0
226 j = 0
227 CALL vdouble(ixq(nixq,1),nixq,numelq,mess,0,bid)
228 ids = 17
229
230 RETURN
231
232 END
anodset
void anodset(int *id, int *type)
Definition analyse_node.c:321
my_real
#define my_real
Definition cppsort.cpp:32
hm_read_quad
subroutine hm_read_quad(ixq, itab, itabm1, ipart, ipartq, ipm, igeo, unitab, lsubmodel)
Definition hm_read_quad.F:40
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
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