OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
thquad.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!|| thquad ../engine/source/output/th/thquad.F
25!||--- called by ------------------------------------------------------
26!|| hist2 ../engine/source/output/th/hist2.F
27!||--- calls -----------------------------------------------------
28!|| initbuf ../engine/share/resol/initbuf.F
29!|| qrota3 ../engine/source/output/anim/generate/qrota3.F
30!||--- uses -----------------------------------------------------
31!|| alefvm_mod ../common_source/modules/ale/alefvm_mod.F
32!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
33!|| initbuf_mod ../engine/share/resol/initbuf.F
34!|| multi_fvm_mod ../common_source/modules/ale/multi_fvm_mod.F90
35!||====================================================================
36 SUBROUTINE thquad(ELBUF_TAB,NTHGRP2 , ITHGRP ,
37 1 IPARG ,ITHBUF ,WA ,
38 2 IPM ,IXQ ,IXTG ,
39 3 X ,MULTI_FVM,V ,
40 4 W ,ITHERM ,PM ,
41 . NUMELQ ,NUMMAT ,NUMNOD ,SITHBUF, NUMELTG)
42
43C-----------------------------------------------
44C D e s c r i p t i o n
45C-----------------------------------------------
46C
47C /TH/QUAD : BUFFER FOR TIME HISTORY OUTPUT
48C
49C This subroutine is writing buffer related to /TH/QUAD option in
50C order to be written in Time History files : T01, T02, etc...
51C Each channel (index) is standing for a given physical quantity as desbibed below
52C Time History file is requested with Engine option /TFILE
53C
54C-------------------------
55C CHANNEL KEY DESCRIPTION [MAT LAW]
56C
57C 1 OFF
58C 2 SX SIGX
59C 3 SY SIGY
60C 4 SZ SIGZ
61C 5 SXY SIGXY
62C 6 SYZ SIGYZ
63C 7 SXZ SIGZX
64C 8 IE INTERNAL ENERGIE / VOLUME0
65C 9 DENS DENSITY
66C 10 BULK BULK VISCOSITY
67C 11 VOL VOLUME (ALE) OR INITIAL VOLUME (LAG)
68C 12 PLAS EPS PLASTIQUE [2,3,4,7,8,9,16,22,23,26,33-38]
69C 13 TEMP TEMPERATURE [4,6,7,8,9,11,16,17,26,33-38]
70C 14 PLSR STRAIN RATE [4,7,8,9,16,26,33-38]
71C 15 DAMA1 DAMAGE 1 [14]
72C 16 DAMA2 DAMAGE 2 [14]
73C 17 DAMA3 DAMAGE 3 [14]
74C 18 DAMA4 DAMAGE 4 [14]
75C 19 DAMA DAMAGE [24]
76C 20(14) SA1 STRESS RE1 [24]
77C 21(15) SA2 STRESS RE2 [24]
78C 22(16) SA3 STRESS RE3 [24]
79C 23(17) CR CRACKS VOL [24]
80C 24(18) CAP CAP PARAM [24]
81C 25(13) K0 HARD. PARAM [24]
82C 26(12) RK TURBUL. ENER. [6,11,17]
83C 27(14) TD TURBUL. DISS. [6,11,17]
84C 28(14) EFIB FIBER STRAIN [14]
85C 29(16) ISTA PHASE STATE [16]
86C 30(12) VPLA VOL. EPS PLA. [10,21]
87C 31 BFRAC BURN FRACTION [5,41,51,97,151]
88C 32(12) WPLA PLAS. WORK [14]
89C ...
90C 239547 VX X-VELOCITY (MEAN VALUE FOR STAGGERED SCHEME, CELL VALUE FOR COLOCATED SCHEME)
91C 239548 VY Y-VELOCITY (MEAN VALUE FOR STAGGERED SCHEME, CELL VALUE FOR COLOCATED SCHEME)
92C 239549 VZ Z-VELOCITY (MEAN VALUE FOR STAGGERED SCHEME, CELL VALUE FOR COLOCATED SCHEME)
93C 239550 SSP SOUND SPEED
94C 239551 MACH MACH NUMBER
95C-----------------------------------------------
96C M o d u l e s
97C-----------------------------------------------
98 USE initbuf_mod
99 USE elbufdef_mod
100 USE multi_fvm_mod
101 USE alefvm_mod , only:alefvm_param
102C-----------------------------------------------
103C I m p l i c i t T y p e s
104C-----------------------------------------------
105#include "implicit_f.inc"
106C-----------------------------------------------
107C C o m m o n B l o c k s
108C-----------------------------------------------
109#include "vect01_c.inc"
110#include "com01_c.inc"
111#include "task_c.inc"
112#include "param_c.inc"
113C-----------------------------------------------
114C D u m m y A r g u m e n t s
115C-----------------------------------------------
116 INTEGER,INTENT(IN) :: NUMELQ, NUMMAT, NUMNOD ,SITHBUF, NUMELTG
117 INTEGER,INTENT(IN) :: IPARG(NPARG,NGROUP),ITHBUF(SITHBUF),IXQ(NIXQ,NUMELQ),IPM(NPROPMI,NUMMAT),IXTG(NIXTG,NUMELTG)
118 INTEGER, INTENT(IN) :: NTHGRP2
119 INTEGER, INTENT(IN) :: ITHERM
120 INTEGER, DIMENSION(NITHGR,*), INTENT(IN) :: ITHGRP
121 my_real,INTENT(IN) :: pm(npropm,nummat)
122 my_real,INTENT(INOUT) :: wa(*)
123 my_real,INTENT(IN) :: x(3,numnod), v(3,numnod), w(3,numnod)
124 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
125 TYPE(multi_fvm_struct), INTENT(IN) :: MULTI_FVM
126C-----------------------------------------------
127C L o c a l V a r i a b l e s
128C-----------------------------------------------
129 INTEGER II, KRK, LL, I, J, K, L ,N, IH, IP, NG, MTE, NUVAR,
130 . nc1, nc2, nc3, nc4, nel, mtn1,kk(6),ij,nptr,npts,
131 . ir,is,jj(6),niter,iadb,nn,iadv,nvar,ityp,ijk,is_ale
132 my_real
133 . sy , sz, ty , tz, suma,
134 . y1,y2,y3,y4,z1,z2,z3,z4,
135 . r11,r12,r13,r21,r22,r23,r31,r32,r33,
136 . g22,g23,g32,g33,
137 . t22,t23,t32,t33,
138 . s1,s2,s3,s4,
139 . t1,t2,t3,t4,cs,ct,evar(6),gama(6),
140 . tmp(3,4),vel(3),ssp,bfrac,rho0
141 my_real, dimension(:), allocatable :: wwa
142 TYPE(l_bufel_) ,POINTER :: LBUF,LBUF1,LBUF2
143 TYPE(G_BUFEL_) ,POINTER :: GBUF
144 TYPE(BUF_MAT_) ,POINTER :: MBUF
145C-----------------------------------------------
146C S o u r c e L i n e s
147C-----------------------------------------------
148 ALLOCATE(wwa(239555))
149 ijk = 0
150 DO niter=1,nthgrp2
151 ityp=ithgrp(2,niter)
152 nn =ithgrp(4,niter)
153 iadb =ithgrp(5,niter)
154 nvar=ithgrp(6,niter)
155 iadv=ithgrp(7,niter)
156 ii=0
157 IF(ityp==2.OR.ityp==117)THEN
158! -----------------------------
159 nuvar = 0
160 ii=0
161 ih=iadb
162 IF(ityp == 117) ityp = 7
163
164
165C IH shifting
166 DO WHILE((ithbuf(ih+nn)/=ispmd).AND.(ih<iadb+nn))
167 ih = ih + 1
168 ENDDO
169C----
170 IF (ih>=iadb+nn) GOTO 666
171C----
172c
173 DO ng=1,ngroup
174 ity=iparg(5,ng)
175 is_ale = iparg(7,ng)
176
177
178 IF (ity == ityp) THEN
179 gbuf => elbuf_tab(ng)%GBUF
180 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
181 mbuf => elbuf_tab(ng)%BUFLY(1)%MAT(1,1,1)
182c
183 nptr = elbuf_tab(ng)%NPTR
184 npts = elbuf_tab(ng)%NPTS
185C------
186 CALL initbuf(iparg ,ng ,
187 2 mte ,nel ,nft ,iad ,ity ,
188 3 npt ,jale ,ismstr ,jeul ,jtur ,
189 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
190 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
191 6 irep ,iint ,igtyp ,israt ,isrot ,
192 7 icsen ,isorth ,isorthg ,ifailure,jsms )
193
194 IF(mte /= 13) THEN
195C
196 DO i=1,nel
197 n=i+nft
198 k=ithbuf(ih)
199 ip=ithbuf(ih+nn)
200!
201 DO ij=1,6
202 kk(ij) = nel*(ij-1)
203 ENDDO
204
205 evar(1:6) = zero
206C
207 IF (k==n)THEN
208 ih=ih+1
209 !spmd treatment
210 ! find related 'ii'
211 ii = ((ih-1) - iadb)*nvar
212 DO WHILE((ithbuf(ih+nn)/=ispmd).AND.(ih<iadb+nn))
213 ih = ih + 1
214 ENDDO
215c-------------------------------------
216 IF (ih > iadb+nn) GOTO 666
217c-------------------------------------
218 DO l=1,1000
219 wwa(l)=zero
220 ENDDO
221 wwa(1) = gbuf%OFF(i)
222 wwa(8) = gbuf%EINT(i)
223 wwa(9) = gbuf%RHO(i)
224 wwa(10)= gbuf%QVIS(i)
225 wwa(11)= gbuf%VOL(i)
226 IF (isorth == 0) THEN
227 gama(1)=one
228 gama(2)=zero
229 gama(3)=zero
230 gama(4)=zero
231 gama(5)=one
232 gama(6)=zero
233 ELSE
234 gama(1)=gbuf%GAMA(kk(1) + i)
235 gama(2)=gbuf%GAMA(kk(2) + i)
236 gama(3)=gbuf%GAMA(kk(3) + i)
237 gama(4)=gbuf%GAMA(kk(4) + i)
238 gama(5)=gbuf%GAMA(kk(5) + i)
239 gama(6)=gbuf%GAMA(kk(6) + i)
240 END IF
241C-----------
242C SOUND SPEED, MATERIAL VELOCITY, AND MACH NUMBER.
243C-----------
244 vel(1:3)=zero
245 wwa(239547) = zero !VZ
246 wwa(239548) = zero !VY
247 wwa(239549) = zero !VZ
248 wwa(239551) = zero !SSP
249 wwa(239551) = zero !MACH
250 IF(is_ale /= 0)THEN
251c ! ale
252 IF(ity == 2)THEN
253 tmp(1,1:4)=v(1,ixq(2:5,n))-w(1,ixq(2:5,n))
254 tmp(2,1:4)=v(2,ixq(2:5,n))-w(2,ixq(2:5,n))
255 tmp(3,1:4)=v(3,ixq(2:5,n))-w(3,ixq(2:5,n))
256 vel(1) = sum(tmp(1,1:4))*fourth
257 vel(2) = sum(tmp(2,1:4))*fourth
258 vel(3) = sum(tmp(3,1:4))*fourth
259 ELSEIF(ity == 7)THEN
260 tmp(1,1:3)=v(1,ixtg(2:4,n))-w(1,ixtg(2:4,n))
261 tmp(2,1:3)=v(2,ixtg(2:4,n))-w(2,ixtg(2:4,n))
262 tmp(3,1:3)=v(3,ixtg(2:4,n))-w(3,ixtg(2:4,n))
263 vel(1) = sum(tmp(1,1:3))*third
264 vel(2) = sum(tmp(2,1:3))*third
265 vel(3) = sum(tmp(3,1:3))*third
266 ENDIF
267 ELSE
268 !euler and lagrange
269 IF(ity == 2)THEN
270 tmp(1,1:4)=v(1,ixq(2:5,n))
271 tmp(2,1:4)=v(2,ixq(2:5,n))
272 tmp(3,1:4)=v(3,ixq(2:5,n))
273 vel(1) = sum(tmp(1,1:4))*fourth
274 vel(2) = sum(tmp(2,1:4))*fourth
275 vel(3) = sum(tmp(3,1:4))*fourth
276 ELSE
277 tmp(1,1:3)=v(1,ixtg(2:4,n))
278 tmp(2,1:3)=v(2,ixtg(2:4,n))
279 tmp(3,1:3)=v(3,ixtg(2:4,n))
280 vel(1) = sum(tmp(1,1:3))*third
281 vel(2) = sum(tmp(2,1:3))*third
282 vel(3) = sum(tmp(3,1:3))*third
283 ENDIF
284 ENDIF
285
286 wwa(239547) = vel(1)
287 wwa(239548) = vel(2)
288 wwa(239549) = vel(3)
289
290 IF(elbuf_tab(ng)%BUFLY(1)%L_SSP /= 0)THEN
291 wwa(239550)= lbuf%SSP(i) !sound speed
292 wwa(239551)= sqrt(vel(1)*vel(1)+vel(2)*vel(2)+vel(3)*vel(3))/lbuf%SSP(i) !mach number
293 ENDIF
294
295 IF(elbuf_tab(ng)%GBUF%G_BFRAC /= 0)THEN
296 wwa(31) = gbuf%BFRAC(i)
297 ENDIF
298C------------------------------------------------------------------------------
299C TH tab filling with stresses in the global (WA(2:7)
300C and local system(WA(35:40)
301C------------------------------------------------------------------------------
302 DO j=1,6
303 evar(j)=gbuf%SIG(kk(j)+i)
304 ENDDO
305 IF (jcvt <= 0) THEN
306 DO j=1,6
307 wwa(2+j-1)=evar(j)
308 ENDDO
309 IF(ity == 2) CALL qrota3(x,ixq(1,n),jcvt,evar,gama,isorth)
310 DO j=1,6
311 wwa(35+j-1)=evar(j)
312 ENDDO
313 ELSE
314 DO j=1,6
315 wwa(35+j-1)=evar(j)
316 ENDDO
317 IF(ity == 2) CALL qrota3(x,ixq(1,n),jcvt,evar,gama,isorth)
318 DO j=1,6
319 wwa(2+j-1)=evar(j)
320 ENDDO
321 ENDIF
322c
323 IF (mte==2)THEN
324 wwa(12)=gbuf%PLA(i)
325 ELSEIF(mte==3) THEN
326 wwa(12)=gbuf%PLA(i)
327 wwa(13)=gbuf%TEMP(i)
328 ELSEIF (mte==4) THEN
329 wwa(12)=gbuf%PLA(i)
330 wwa(13)=gbuf%TEMP(i)
331 wwa(14)=gbuf%EPSD(i)
332 ELSEIF (mte==5) THEN
333 wwa(31)=gbuf%BFRAC(i)
334 wwa(13)=gbuf%TEMP(i)
335 ELSEIF (mte==6) THEN
336 wwa(13)=gbuf%TEMP(i)
337 wwa(26)=lbuf%RK(i)
338 wwa(27)=lbuf%RE(i)
339 ELSEIF (mte==7.OR.mte==8.OR.mte==9) THEN
340 wwa(12)=zero
341 wwa(13)=zero
342 wwa(14)=zero
343 ELSEIF (mte==10) THEN
344 wwa(12)=lbuf%EPSQ(i)
345 wwa(30)=lbuf%PLA(i)
346 ELSEIF (mte==11) THEN
347 wwa(13)=lbuf%TEMP(i)
348 wwa(26)=lbuf%RK(i)
349 wwa(27)=lbuf%RE(i)
350 ELSEIF (mte==14) THEN
351 wwa(32)=lbuf%PLA(i)
352 wwa(33)=lbuf%SIGF(i)
353 wwa(28)=lbuf%EPSF(i)
354 wwa(15)=lbuf%DAM(kk(1)+i)
355 wwa(16)=lbuf%DAM(kk(2)+i)
356 wwa(17)=lbuf%DAM(kk(3)+i)
357 wwa(18)=lbuf%DAM(kk(4)+i)
358 wwa(34)=lbuf%DAM(kk(5)+i)
359 ELSEIF (mte==16) THEN
360 wwa(12)=lbuf%PLA(i)
361 wwa(13)=lbuf%TEMP(i)
362 wwa(14)=lbuf%XST(i)
363 ELSEIF (mte==17) THEN
364 IF (itherm > 0) wwa(13)=lbuf%TEMP(i)
365 wwa(26)=lbuf%RK(i)
366 wwa(27)=lbuf%RE(i)
367 ELSEIF (mte==18) THEN
368 wwa(13)=lbuf%TEMP(i)
369 ELSEIF (mte==20) THEN ! Bimat
370 lbuf1 => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
371 lbuf2 => elbuf_tab(ng)%BUFLY(2)%LBUF(1,1,1)
372 IF(gbuf%G_PLA>0) wwa(12)=gbuf%PLA(i)
373 IF(gbuf%G_TEMP>0)wwa(13)=gbuf%TEMP(i)
374 ! SUBMATERIAL 1
375 !MTN1=IPARG(25,NG)
376 DO j = 1,6
377 wwa(1624 + j) = lbuf1%SIG(kk(j)+i)
378 ENDDO
379 wwa(1624 + 7 ) = lbuf1%EINT(i)
380 wwa(1624 + 8 ) = lbuf1%RHO(i)
381 wwa(1624 + 9 ) = lbuf1%VOL(i)
382 IF(elbuf_tab(ng)%BUFLY(1)%L_TEMP>0)
383 . wwa(1624 +11 )=lbuf1%TEMP(i)
384 !SUBMATERIAL 2
385 !MTN1=IPARG(26, NG)
386 DO j = 1,6
387 wwa(1635 + j) = lbuf2%SIG(kk(j)+i)
388 ENDDO
389 wwa(1635 + 7 ) = lbuf2%EINT(i)
390 wwa(1635 + 8 ) = lbuf2%RHO(i)
391 wwa(1635 + 9 ) = lbuf2%VOL(i)
392 IF(elbuf_tab(ng)%BUFLY(2)%L_TEMP>0)
393 . wwa(1635 +11 )=lbuf2%TEMP(i)
394 ELSEIF (mte==21) THEN
395 wwa(12)=lbuf%EPSQ(i) ! NB11
396 wwa(30)=gbuf%PLA(i) ! NB10
397 ELSEIF (mte==22.OR.mte==23) THEN
398 wwa(12)=lbuf%PLA(i)
399 ELSEIF (mte==24) THEN
400 wwa(19)=lbuf%DAM(kk(1)+i)+lbuf%DAM(kk(2)+i)+lbuf%DAM(kk(3)+i)
401 wwa(20)=lbuf%SIGA(kk(1)+i)
402 wwa(21)=lbuf%SIGA(kk(2)+i)
403 wwa(22)=lbuf%SIGA(kk(3)+i)
404 wwa(23)=lbuf%CRAK(kk(1)+i)+lbuf%CRAK(kk(2)+i)+lbuf%CRAK(kk(3)+i)
405 wwa(24)=lbuf%DSUM(i)
406 wwa(25)=lbuf%VK(i)
407 ELSEIF (mte==26) THEN
408 wwa(12)=lbuf%PLA(i)
409 wwa(13)=lbuf%TEMP(i)
410 wwa(14)=lbuf%Z(i)
411 ELSEIF (mte==32.OR.mte==43) THEN ! not solid compatible !!
412 wwa(12)=zero
413 wwa(13)=zero
414 wwa(14)=zero
415 ELSEIF (mte==46.OR.mte==47) THEN
416 wwa(12)=mbuf%VAR(i)
417 wwa(13)=mbuf%VAR(i+nel)
418c WWA(14)=MBUF%VAR(I+NEL*2)
419 ELSEIF (mte==49) THEN
420 wwa(12)=lbuf%PLA(i)
421 wwa(13)=lbuf%TEMP(i)
422 wwa(14)=lbuf%EPSD(i)
423 ELSEIF (mte>=29.AND.mte/=67) THEN
424C User laws for quads
425 nuvar = elbuf_tab(ng)%BUFLY(1)%NVAR_MAT
426 IF (nuvar > 0) wwa(12)=mbuf%VAR(i)
427 IF (nuvar > 1) wwa(13)=mbuf%VAR(i+nel)
428 IF (nuvar > 2) wwa(14)=mbuf%VAR(i+nel*2)
429 ELSEIF (mte==67) THEN
430C Temperature
431 wwa(12)=zero
432 wwa(13)=mbuf%VAR(i)
433 wwa(14)=zero
434 ENDIF
435 IF (mte >= 29) THEN
436 IF(ity == 2) THEN
437 nuvar =ipm(8,ixq(1,nft+1))
438 ELSEIF(ity == 7) THEN
439 nuvar =ipm(8,ixtg(1,nft+1))
440 ENDIF
441 DO j=1,nuvar
442 wwa(136+j)=mbuf%VAR((j-1)*nel+i)
443 ENDDO
444 ENDIF
445C
446C------------------------------------------------------------------------------
447C TH tab filling with stain in element and per integration point
448C EPSXIJK,EPSYIJK,EPSZIJK,EPSXYIJK,EPSXZIJK,EPSYZIIJK => WWA(239060)
449C EPSXX,EPSYY,EPSZZ,EPSXY,EPSXZ,EPSYZ => WWA(1618)
450C L_EPSXX,L_EPSYY,L_EPSZZ,L_EPSXY,LEPSXZ,LEPSYZ => WWA(239030)
451C------------------------------------------------------------------------------
452c EPS
453 evar(1:6)=zero
454 IF (elbuf_tab(ng)%BUFLY(1)%L_STRA > 0) THEN
455 DO is=1,npts
456 DO ir=1,nptr
457 lbuf1 => elbuf_tab(ng)%BUFLY(1)%LBUF(ir,is,1)
458 evar(1) = evar(1) + lbuf1%STRA(kk(1) + i)/npt
459 evar(2) = evar(2) + lbuf1%STRA(kk(2) + i)/npt
460 evar(4) = evar(4) + lbuf1%STRA(kk(4) + i)*half/npt
461 ENDDO
462 ENDDO
463 ENDIF
464
465 IF (jcvt == 0) THEN
466C EPS IN THE GLOBAL SYSTEM
467 DO j=1,6
468 wwa(1619+j-1)=evar(j)
469 ENDDO
470 IF(ity == 2) CALL qrota3(x,ixq(1,n),jcvt,evar,gama,isorth)
471C LEPS IN THE LOCAL SYSTEM
472 DO j=1,6
473 wwa(239030+j-1)=evar(j)
474 ENDDO
475 ELSE
476C LEPS IN THE LOCAL SYSTEM
477 DO j=1,6
478 wwa(239030+j-1)=evar(j)
479 ENDDO
480 IF(ity == 2) CALL qrota3(x,ixq(1,n),jcvt,evar,gama,isorth)
481C EPS IN THE GLOBAL SYSTEM
482 DO j=1,6
483 wwa(1619+j-1)=evar(j)
484 ENDDO
485 ENDIF
486C EPS111, EPS121, EPS211, EPS221 IN THE GLOBAL SYSTEM
487 IF (elbuf_tab(ng)%BUFLY(1)%L_STRA > 0) THEN
488 DO is=1,npts
489 DO ir=1,nptr
490 lbuf1 => elbuf_tab(ng)%BUFLY(1)%LBUF(ir,is,1)
491 evar(1:6)=zero
492 evar(1) = lbuf1%STRA(kk(1) + i)
493 evar(2) = lbuf1%STRA(kk(2) + i)
494 evar(4) = lbuf1%STRA(kk(4) + i)
495 IF (jcvt == 0) THEN
496 DO j=1,6
497 wwa(239030+30+(is-1)*6+(ir-1)*18+j) = evar(j)
498 ENDDO
499 ELSE
500 IF(ity == 2) CALL qrota3(x,ixq(1,n),jcvt,evar,gama,isorth)
501 DO j=1,6
502 wwa(239030+30+(is-1)*6+(ir-1)*18+j) = evar(j)
503 ENDDO
504 ENDIF
505 ENDDO
506 ENDDO
507 ENDIF
508C
509C
510 IF (mte==151) THEN !specific buffer with colocated scheme, generic storage from above are erased
511C BFRAC
512 IF(ALLOCATED(multi_fvm%BFRAC))THEN
513 bfrac = zero
514 DO ir=1,multi_fvm%NBMAT
515 bfrac = max(bfrac, multi_fvm%BFRAC(ir,n))
516 ENDDO
517 wwa(31)=bfrac
518 ENDIF
519C VX / VY / VZ
520 wwa(239547)= multi_fvm%VEL(1, n)
521 wwa(239548)= multi_fvm%VEL(2, n)
522 wwa(239549)= multi_fvm%VEL(3, n)
523C SSP
524 wwa(239550)= multi_fvm%SOUND_SPEED(n)
525C MACH NUMBER
526 wwa(239551)= sqrt(multi_fvm%VEL(1, n)*multi_fvm%VEL(1, n)+
527 . multi_fvm%VEL(2, n)*multi_fvm%VEL(2, n)+
528 . multi_fvm%VEL(3, n)*multi_fvm%VEL(3, n)) /
529 . multi_fvm%SOUND_SPEED(n)
530
531 ELSEIF(alefvm_param%ISOLVER>1)THEN
532C SSP
533 wwa(239550)= lbuf%SSP(i)
534 IF(elbuf_tab(ng)%BUFLY(1)%L_SSP /= 0)THEN
535 jj(1) = nel*(1-1)
536 jj(2) = nel*(2-1)
537 jj(3) = nel*(3-1)
538 vel(1) = gbuf%MOM(jj(1) + i) / gbuf%RHO(i)
539 vel(2) = gbuf%MOM(jj(2) + i) / gbuf%RHO(i)
540 vel(3) = gbuf%MOM(jj(3) + i) / gbuf%RHO(i)
541 wwa(239547)= vel(1)
542 wwa(239548)= vel(2)
543 wwa(239549)= vel(3)
544 wwa(239551)= sqrt(vel(1)*vel(1)+vel(2)*vel(2)+vel(3)*vel(3))/lbuf%SSP(i)
545 ENDIF
546
547 ENDIF
548
549 !VOLUMETRIC STRAIN (MU)
550 IF(numeltg > 0)THEN
551 rho0 = pm(01,ixtg(1,1+nft))
552 ELSE
553 rho0 = pm(01,ixq(1,1+nft))
554 ENDIF
555 IF(rho0 > zero)THEN
556 wwa(239555) = gbuf%RHO(i) / rho0 - one
557 ELSE
558 wwa(239555) = zero
559 ENDIF
560c
561 DO l=iadv,iadv+nvar-1
562 k=ithbuf(l)
563 ijk=ijk + 1
564 wa(ijk)=wwa(k)
565 ENDDO
566 ijk=ijk + 1
567 wa(ijk)=ii
568 ENDIF
569 ENDDO
570c --------------
571 ENDIF ! mte /= 13
572 ENDIF
573 ENDDO ! next group
574! -----------------------------
575 ENDIF
576 666 continue
577 ENDDO
578 DEALLOCATE(wwa)
579C-----------
580 RETURN
581 END
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
alefvm_mod
Definition alefvm_mod.F:88
alefvm_mod::alefvm_param
type(alefvm_param_), target alefvm_param
Definition alefvm_mod.F:121
initbuf_mod
Definition initbuf.F:160
initbuf_mod::initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, mid, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure, jsms)
Definition initbuf.F:261
nvar
integer function nvar(text)
Definition nvar.F:32
qrota3
subroutine qrota3(x, ixq, kcvt, tens, gama, isorth)
Definition qrota3.F:31
thquad
subroutine thquad(elbuf_tab, nthgrp2, ithgrp, iparg, ithbuf, wa, ipm, ixq, ixtg, x, multi_fvm, v, w, itherm, pm, numelq, nummat, numnod, sithbuf, numeltg)
Definition thquad.F:42