OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
qgrhead.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!|| qgrhead ../starter/source/elements/solid_2d/quad/qgrhead.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.f
29!|| fretitl2 ../starter/source/starter/freform.F
30!||--- uses -----------------------------------------------------
31!|| message_mod ../starter/share/message_module/message_mod.F
32!||====================================================================
33 SUBROUTINE qgrhead(
34 1 IXQ ,PM ,GEO ,INUM ,ISEL ,
35 2 ITR1 ,EADD ,INDEX ,ITRI ,IPARTQ ,
36 3 ND ,IGRSURF ,IGRQUAD ,CEP ,MAT_PARAM,
37 5 XEP ,IGEO ,IPM ,IQUAOFF )
38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE message_mod
42 USE groupdef_mod
43 USE matparam_def_mod
44 USE names_and_titles_mod , ONLY : nchartitle
45C-----------------------------------------------
46C A R G U M E N T S
47C-----------------------------------------------
48C IXQ(7,NUMELQ) TABLEAU CONECS+PID+MID+NOS SOLIDES 4N E
49C PM(NPROPM,NUMMAT) TABLEAU DES CARACS DES MATERIAUX E
50C GEO(NPROPG,NUMGEO)TABLEAU DES CARACS DES PID E
51C INUM(8,NUMELQ) TABLEAU DE TRAVAIL E/S
52C ISEL(NSELQ) TABLEAU DES SOLIDES 4N CHOISIS POUR TH E/S
53C ITR1(NSELQ) TABLEAU DE TRAVAIL E/S
54C EADD(NUMELQ) TABLEAU DES ADRESEES DANS IDAM CHGT DAMIER S
55C INDEX(NUMELQ) TABLEAU DE TRAVAIL E/S
56C ITRI(5,NUMELQ) TABLEAU DE TRAVAIL E/S
57C IPARTQ(NUMELQ) TABLEAU PART E/S
58C CEP(NUMELQ) TABLEAU DE TRAVAIL E/S
59C XEP(NUMELQ) TABLEAU DE TRAVAIL E/S
60C IQUAOFF(NUMELQ) FLAG ELEM RBY ON/OFF E/S
61C-----------------------------------------------
62C I M P L I C I T T Y P E S
63C-----------------------------------------------
64#include "implicit_f.inc"
65C-----------------------------------------------
66C C O M M O N B L O C K S
67C-----------------------------------------------
68#include "vect01_c.inc"
69#include "com04_c.inc"
70#include "param_c.inc"
71#include "scr17_c.inc"
72C-----------------------------------------------
73C D U M M Y A R G U M E N T S
74C-----------------------------------------------
75 INTEGER IXQ(7,*),ISEL(*),INUM(9,*),IPARTQ(*),
76 . EADD(*),ITR1(*),INDEX(*),ITRI(5,*),ND, CEP(*),XEP(*),
77 . IGEO(NPROPGI,NUMGEO), IPM(NPROPMI,NUMMAT),
78 . IQUAOFF(*)
79 my_real :: pm(npropm,nummat), geo(npropg,numgeo)
80C-----------------------------------------------
81 TYPE (GROUP_) , DIMENSION(NGRQUAD) :: IGRQUAD
82 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
83 TYPE (matparam_struct_) ,DIMENSION(NUMMAT),INTENT(IN) :: mat_param
84C-----------------------------------------------
85C L O C A L V A R I A B L E S
86C-----------------------------------------------
87 INTEGER
88 . I,J,K,L, NG, NN, N, MLN, MID, PID ,
89 . II,JJ, II1,JJ1,II2,JJ2,II3,JJ3,II4,JJ4,
90 . MODE, ML1, ML2, MT1, MT2,IGT,
91 . mskmln,mskjal,mskmid,mskpid,ieos,
92 . mskjeu,mskjtu,mskjth,mskjpo,
93 . iplast, ialel, mt,irep,iint,issn,ngtvx,ifail,irb,
94 . jale_from_mat,jale_from_prop
95 INTEGER ID
96 CHARACTER(LEN=NCHARTITLE)::TITR
97 INTEGER WORK(70000)
98 EXTERNAL MY_SHIFTL,MY_SHIFTR,MY_AND
99 INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND
100C
101 DATA mskmln /o'07770000000'/
102 DATA mskjal /o'00000070000'/
103 DATA mskjeu /o'00000007000'/
104 DATA mskjtu /o'00000000700'/
105 DATA mskjth /o'00000000070'/
106 DATA mskjpo /o'00000000007'/
107 DATA mskmid /o'07777777777'/
108 DATA mskpid /o'07777777777'/
109C
110C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
111
112C----------------------------------------------------------
113C TRI GLOBAL SUR TOUS LES CRITERES POUR TOUS LES ELEMENTS
114C----------------------------------------------------------
115C
116 DO i=1,numelq
117 eadd(i)=1
118 itri(4,i)=i
119 index(i)=i
120 inum(1,i)=ipartq(i)
121 inum(2,i)=ixq(1,i)
122 inum(3,i)=ixq(2,i)
123 inum(4,i)=ixq(3,i)
124 inum(5,i)=ixq(4,i)
125 inum(6,i)=ixq(5,i)
126 inum(7,i)=ixq(6,i)
127 inum(8,i)=ixq(7,i)
128 inum(9,i)=iquaoff(i)
129 ENDDO
130C
131 DO i=1,numelq
132 xep(i)=cep(i)
133 ENDDO
134C
135C
136 DO i = 1, numelq
137 ii = i
138 npt=1
139 jpor=0
140 mid= ixq(1,ii)
141 pid= ixq(6,ii)
142 iplast= 1
143 irep = 0
144 jcvt = 0
145 ifail = 0
146 ieos = 0
147 IF (pid/=0) THEN
148 igt = igeo(11,pid)
149 IF (igt /= 15) iplast = igeo(9,pid)
150 IF (igt==15)jpor=2*nint(geo(28,pid))
151 jcvt = igeo(16,pid)
152 ENDIF
153 mln = nint(pm(19,abs(mid)))
154 IF(mid<0)THEN
155 IF(mln==6.AND.jpor/=2)mln=17
156 IF(mln==46)mln=47
157 mid=iabs(mid)
158 ENDIF
159 ifail = mat_param(mid)%NFAIL
160 jale_from_mat = nint(pm(72,mid))
161 jale_from_prop = igeo(62,pid)
162 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader
163 jlag=0
164 IF(jale==0.AND.mln/=18)jlag=1
165 jeul=0
166 IF(jale==2)THEN
167 jale=0
168 jeul=1
169 ENDIF
170 jtur=nint(pm(70,mid))
171 jthe=nint(pm(71,mid))
172 jmult=0
173 IF(mln==20)THEN
174 jmult=nint(pm(20,mid))
175 mt1=nint(pm(21,mid))
176 mt2=nint(pm(22,mid))
177 ml1=nint(pm(19,mt1))
178 ml2=nint(pm(19,mt2))
179 ELSE
180 jmult=0
181 ml1=0
182 ml2=0
183 ENDIF
184C
185 IF(jcvt/=0.AND.(jlag==0.OR.mln==20))THEN
186 id=igeo(1,pid)
187 CALL fretitl2(titr,
188 . igeo(npropgi-ltitr+1,pid),ltitr)
189 CALL ancmsg(msgid=608,
190 . msgtype=msgwarning,
191 . anmode=aninfo_blind_1,
192 . i1=id,
193 . c1=titr,
194 . i2=ixq(7,i))
195 jcvt=0
196 END IF
197 ieos = ipm(4,mid)
198C tri sur elem delete des rigidbody
199C IRB = 0 : elem actif
200C IRB = 1 : elem inactif et optimise pour en SPMD
201C IRB = 2 : elem inactif mais optimise pour etre actif en SPMD
202 irb = iquaoff(i)
203C
204C NPT = 1 ; JHBE = 0 ; JIVF = 0 et JLAG non utilise
205C Key 1---------------------------------
206 jpor=my_shiftl(jpor,0)
207 jthe=my_shiftl(jthe,3)
208 jtur=my_shiftl(jtur,6)
209 jeul=my_shiftl(jeul,9)
210 jale=my_shiftl(jale,12)
211 mln=my_shiftl(mln,21)
212c IRB=MY_SHIFTL(IRB,0)
213 itri(1,i)=mln+jale+jeul+jtur+jthe+jpor+irb
214C Key 2---------------------------------
215 iplast=my_shiftl(iplast,0)
216 ifail = my_shiftl(ifail,3)
217 ml1=my_shiftl(ml1,5)
218 ml2=my_shiftl(ml2,13)
219 igt=my_shiftl(igt,21)
220 jcvt=my_shiftl(jcvt,28)
221 itri(2,i)=iplast+ml1+ml2+igt+jcvt + ifail
222C Key 3---------------------------------
223 itri(3,i)=mid
224C Key 4---------------------------------
225 itri(4,i)=pid
226C Key 5---------------------------------
227 ieos = my_shiftl(ieos,0)
228C next = MY_SHIFTL(next,4)
229 itri(5,i)=ieos
230
231 ENDDO
232C
233 mode=0
234 CALL my_orders( mode, work, itri, index, numelq , 5)
235C
236 DO i=1,numelq
237 ipartq(i) =inum(1,index(i))
238 iquaoff(i) = inum(9,index(i))
239 ENDDO
240 DO i=1,numelq
241 cep(i)=xep(index(i))
242 ENDDO
243 DO k=1,7
244 DO i=1,numelq
245 ixq(k,i)=inum(k+1,index(i))
246 ENDDO
247 ENDDO
248
249C
250C INVERSE OF INDEX (ITR1)
251C
252 DO i=1,numelq
253 itr1(index(i))=i
254 ENDDO
255
256
257C
258C SURFACE RENUMBERING
259C
260 DO i=1,nsurf
261 nn=igrsurf(i)%NSEG
262 DO j=1,nn
263 IF(igrsurf(i)%ELTYP(j) == 2) igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
264 ENDDO
265 ENDDO
266C
267C RSOLID GROUPS RENUMBERING
268C
269 DO i=1,ngrquad
270 nn=igrquad(i)%NENTITY
271 DO j=1,nn
272 igrquad(i)%ENTITY(j) = itr1(igrquad(i)%ENTITY(j))
273 ENDDO
274 ENDDO
275C
276C--------------------------------------------------------------
277C BUILDING SUPER GROUPS
278C--------------------------------------------------------------
279 nd=1
280 DO i=2,numelq
281 ii=itri(1,index(i))
282 jj=itri(1,index(i-1))
283 ii1=itri(2,index(i))
284 jj1=itri(2,index(i-1))
285 ii2=itri(3,index(i))
286 jj2=itri(3,index(i-1))
287 ii3=itri(4,index(i))
288 jj3=itri(4,index(i-1))
289 ii4=itri(5,index(i))
290 jj4=itri(5,index(i-1))
291 IF(ii/=jj.OR.
292 . ii1/=jj1.OR.
293 . ii4/=jj4.OR.
294 . ii2/=jj2.OR.
295 . ii3/=jj3) THEN
296 nd=nd+1
297 eadd(nd)=i
298 ENDIF
299 ENDDO
300 eadd(nd+1) = numelq+1
301C
302 RETURN
303 END
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
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
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
qgrhead
subroutine qgrhead(ixq, pm, geo, inum, isel, itr1, eadd, index, itri, ipartq, nd, igrsurf, igrquad, cep, mat_param, xep, igeo, ipm, iquaoff)
Definition qgrhead.F:38
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
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
starter
program starter
Definition starter.F:39