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