OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dfuncf.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!|| dfuncf ../engine/source/output/anim/generate/dfuncf.F
25!||--- called by ------------------------------------------------------
26!|| genani ../engine/source/output/anim/generate/genani.F
27!||--- calls -----------------------------------------------------
28!|| spmd_r4get_partn ../engine/source/mpi/anim/spmd_r4get_partn.F
29!|| write_r_c ../common_source/tools/input_output/write_routines.c
30!||--- uses -----------------------------------------------------
31!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
32!|| element_mod ../common_source/modules/elements/element_mod.F90
33!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
34!||====================================================================
35 SUBROUTINE dfuncf(ELBUF_TAB ,FUNC ,IFUNC ,IPARG ,GEO ,
36 . IXT ,IXP ,IXR ,MASS ,PM ,
37 . EL2FA ,NBF ,IADP ,NBPART ,EHOUR,
38 . ANIM ,IADG ,XFUNC1 ,NANIM1D_L,IGEO )
39C-----------------------------------------------
40C M o d u l e s
41C-----------------------------------------------
42 USE elbufdef_mod
43 USE my_alloc_mod
44 use element_mod , only : nixt,nixr,nixp
45C-----------------------------------------------
46C I m p l i c i t T y p e s
47C-----------------------------------------------
48#include "implicit_f.inc"
49C-----------------------------------------------
50C C o m m o n B l o c k s
51C-----------------------------------------------
52#include "mvsiz_p.inc"
53#include "com01_c.inc"
54#include "com04_c.inc"
55#include "scr14_c.inc"
56#include "param_c.inc"
57#include "task_c.inc"
58#include "spmd_c.inc"
59C-----------------------------------------------
60C D u m m y A r g u m e n t s
61C-----------------------------------------------
62C REAL
63 my_real
64 . func(*), mass(*) ,pm(npropm,*), geo(npropg,*),
65 . ehour(*),anim(*), xfunc1(10,*)
66 INTEGER IPARG(NPARG,*),EL2FA(*),
67 . IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),IFUNC,NBF,
68 . IADP(*),NBPART,IADG(NSPMD,*),NANIM1D_L,NBF2,
69 . igeo(npropgi,*)
70 INTEGER BUF
71C
72 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76C REAL
77 my_real
78 . evar(mvsiz),
79 . off, p, vonm2, vonm, s1, s2, s12, s3, VALUE,
80 . a1,b1,b2,b3,yeq,f1,m1,m2,m3, xm,
81 . for, area, feq, eplas,dammx
82 INTEGER I, NG, NEL, NFT, ITY, LFT, NPT,
83 . IADD, N, J, LLT, MLW, NB1, NB2, NB3, NB4, NB5,
84 . NB6, NB7, NB8, NB9, NB10, NB11, NB12, NB13, NB14, NB15,
85 . nb16, lll,nuvar,igtyp,ifail,
86 . istrain,nn, k1, k2,jturb,mt,jale, imid, ialel,ipid,
87 . nn1,nn2,nn3,nn4,nn5,nn6,nn7,nn8,nn9,nn10,nf,
88 . offset,k,inc,kk,ihbe,isrot,ilayer,ir,is,jj(6),ipt
89 INTEGER LPLA ! Used for size of PL Buffer
90 REAL R4
91 REAL,DIMENSION(:),ALLOCATABLE:: WAL
92C
93 TYPE(g_bufel_) ,POINTER :: GBUF
94 TYPE(l_bufel_),POINTER :: LBUF
95C-----------------------------------------------
96 CALL my_alloc(wal,nbf+nanim1d_l)
97C
98 nn1 = 1
99 nn3 = 1
100 nn4 = nn3
101 nn5 = nn4
102 nn6 = nn5
103 nn7 = nn6 + numelt
104 nn8 = nn7 + numelp
105 nn9 = nn8 + numelr
106 nn10= nn9
107C
108 DO ng=1,ngroup
109 mlw =iparg(1,ng)
110 nel =iparg(2,ng)
111 ity =iparg(5,ng)
112 igtyp =iparg(38,ng)
113 ifail =iparg(43,ng)
114C---
115 gbuf => elbuf_tab(ng)%GBUF
116C---
117 DO offset = 0,nel-1,nvsiz
118 nft =iparg(3,ng) + offset
119 lft=1
120 llt=min(nvsiz,nel-offset)
121!
122 DO i=1,6
123 jj(i) = nel*(i-1)
124 ENDDO
125!
126C-----------------------------------------------
127C TRUSS
128C-----------------------------------------------
129 IF(ity==4)THEN
130 IF(ifunc==1)THEN
131 IF(mlw/=1)THEN
132 DO i=lft,llt
133 n = i + nft
134 off = gbuf%OFF(i)
135 IF(gbuf%G_PLA > 0) THEN
136 func(el2fa(nn6+n)) = gbuf%PLA(i)
137 ELSE
138 func(el2fa(nn6+n)) = 0
139 ENDIF
140 ENDDO
141 ELSE
142 DO i=lft,llt
143 n = i + nft
144 func(el2fa(nn6+n)) = zero
145 ENDDO
146 ENDIF
147 ELSEIF(ifunc==3)THEN
148 DO i=lft,llt
149 n = i + nft
150 func(el2fa(nn6+n))=gbuf%EINT(i)/
151 . max(em30,mass(el2fa(nn6+n)))
152 ENDDO
153 ELSEIF(ifunc==7)THEN
154 DO i=lft,llt
155 n = i + nft
156 for = gbuf%FOR(i)
157 area = gbuf%AREA(i)
158 feq = for*for
159 func(el2fa(nn6+n)) = sqrt(feq)/area
160 ENDDO
161 ELSEIF(ifunc==14)THEN
162 DO i=lft,llt
163 n = i + nft
164 func(el2fa(nn6+n)) = gbuf%FOR(i) / gbuf%AREA(i)
165 ENDDO
166 ELSEIF(ifunc==20)THEN
167 IF(gbuf%G_DT>0)THEN
168 DO i=lft,llt
169 n = i + nft
170 func(el2fa(nn6+n)) = gbuf%DT(i)
171 ENDDO
172 ENDIF
173 ELSEIF ((ifunc==21).AND.(gbuf%G_ISMS>0)) THEN
174 DO i=lft,llt
175 n = i + nft
176 func(el2fa(nn6+n)) = gbuf%ISMS(i)
177 ENDDO
178 ELSEIF (ifunc == 22) THEN
179 DO i=lft,llt
180 n = i + nft
181 IF (gbuf%G_OFF > 0) THEN
182 IF(gbuf%OFF(i) > one) THEN
183 func(el2fa(nn6+n)) = gbuf%OFF(i) - one
184 ELSEIF((gbuf%OFF(i) >= zero .AND. gbuf%OFF(i) <= one)) THEN
185 func(el2fa(nn6+n)) = gbuf%OFF(i)
186 ELSE
187 func(el2fa(nn6+n)) = -one
188 ENDIF
189 ENDIF
190 ENDDO
191 ELSEIF (ifunc == 123) THEN
192 DO i=lft,llt
193 n = i + nft
194 func(el2fa(nn6+n)) = gbuf%STRA(i)
195 ENDDO
196 ELSE
197 DO i=lft,llt
198 n = i + nft
199 func(el2fa(nn6+n)) = zero
200 ENDDO
201 ENDIF
202C-----------------------------------------------
203C BEAM
204C-----------------------------------------------
205 ELSEIF(ity==5)THEN
206 IF (ifunc == 1) THEN
207 IF (mlw /= 1) THEN
208 IF (igtyp == 18) THEN
209 npt = iparg(6,ng)
210 DO i=lft,llt
211 n = i + nft
212 eplas = zero
213 IF (mlw /= 0)THEN
214 DO k = 1,npt
215 ilayer=1
216 ir = 1
217 is = 1
218 lpla = elbuf_tab(ng)%BUFLY(ilayer)%L_PLA
219 IF ( lpla /= 0)THEN
220 lbuf => elbuf_tab(ng)%BUFLY(ilayer)%LBUF(ir,is,k)
221 eplas = eplas + lbuf%PLA(i)
222 ENDIF
223 ENDDO
224 ENDIF
225 func(el2fa(nn7+n)) = eplas/npt
226 ENDDO
227 ELSE ! IF (IGTYP == 18) THEN
228 DO i=lft,llt
229 n = i + nft
230 off = gbuf%OFF(i)
231 IF(gbuf%G_PLA > 0) THEN
232 func(el2fa(nn7+n)) = gbuf%PLA(i)
233 ELSE
234 func(el2fa(nn7+n)) = 0
235 ENDIF
236 ENDDO
237 ENDIF
238 ELSE ! IF (MLW /= 1) THEN
239 DO i=lft,llt
240 n = i + nft
241 func(el2fa(nn7+n)) = zero
242 ENDDO
243 ENDIF
244 ELSEIF(ifunc==3)THEN
245 DO i=lft,llt
246 n = i + nft
247 func(el2fa(nn7+n)) = (gbuf%EINT(i) + gbuf%EINT(i+llt)) / max(em30,mass(el2fa(nn7+n)))
248 ENDDO
249 ELSEIF(ifunc==7)THEN
250 DO i=lft,llt
251 n = i + nft
252 a1 = geo(1,ixp(5,n))
253 b1 = geo(2,ixp(5,n))
254 b2 = geo(18,ixp(5,n))
255 b3 = geo(4,ixp(5,n))
256 f1 = gbuf%FOR(jj(1)+i)
257 m1 = gbuf%MOM(jj(1) + i)
258 m2 = gbuf%MOM(jj(2) + i)
259 m3 = gbuf%MOM(jj(3) + i)
260 yeq= f1*f1 + three* a1 *
261 + ( m1*m1 / max(b3,em30)
262 + + m2*m2 / max(b1,em30)
263 + + m3*m3 / max(b2,em30) )
264 func(el2fa(nn7+n)) = sqrt(yeq)/a1
265 ENDDO
266 ELSEIF(ifunc==14)THEN
267 DO i=lft,llt
268 n = i + nft
269 func(el2fa(nn7+n)) = gbuf%FOR(jj(1)+i) / geo(1,ixp(5,n))
270 ENDDO
271 ELSEIF(ifunc==17)THEN
272 DO i=lft,llt
273 n = i + nft
274 func(el2fa(nn7+n)) = gbuf%FOR(jj(2)+i) / geo(1,ixp(5,n))
275 ENDDO
276 ELSEIF(ifunc==19)THEN
277 DO i=lft,llt
278 n = i + nft
279 func(el2fa(nn7+n)) = gbuf%FOR(jj(3)+i) / geo(1,ixp(5,n))
280 ENDDO
281 ELSEIF(ifunc==20)THEN
282 DO i=lft,llt
283 n = i + nft
284 func(el2fa(nn7+n)) = gbuf%DT(i)
285 ENDDO
286 ELSEIF ((ifunc==21).AND.(gbuf%G_ISMS>0)) THEN
287 DO i=lft,llt
288 n = i + nft
289 func(el2fa(nn7+n)) = gbuf%ISMS(i)
290 ENDDO
291 ELSEIF (ifunc == 22) THEN
292 DO i=lft,llt
293 n = i + nft
294 IF (gbuf%G_OFF > 0) THEN
295 IF(gbuf%OFF(i) > one) THEN
296 func(el2fa(nn7+n)) = gbuf%OFF(i) - one
297 ELSEIF((gbuf%OFF(i) >= zero .AND. gbuf%OFF(i) <= one)) THEN
298 func(el2fa(nn7+n)) = gbuf%OFF(i)
299 ELSE
300 func(el2fa(nn7+n)) = -one
301 ENDIF
302 ENDIF
303 ENDDO
304 ELSEIF (ifunc >= 23 .AND. ifunc <= 122) THEN
305 ipt = mod((ifunc - 22), 100)
306 IF (ipt == 0) ipt = 100
307 IF (mlw /= 1) THEN
308 IF (igtyp == 18) THEN
309 npt = iparg(6,ng)
310 ilayer=1
311 ir = 1
312 is = 1
313 IF (ipt <= npt) THEN
314 lbuf => elbuf_tab(ng)%BUFLY(ilayer)%LBUF(ir,is,ipt)
315 DO i=lft,llt
316 n = i + nft
317 func(el2fa(nn7+n)) = lbuf%PLA(i)
318 ENDDO
319 ELSE
320 DO i=lft,llt
321 n = i + nft
322 func(el2fa(nn7+n)) = zero
323 ENDDO
324 ENDIF ! IF (IPT <= NPT)
325 ENDIF ! IF (IGTYP == 18)
326 ENDIF ! IF (MLW /= 1)
327 ELSEIF(ifunc == 124 .AND. (gbuf%G_EPSD>0))THEN
328 DO i=lft,llt
329 n = i + nft
330 func(el2fa(nn7+n)) = gbuf%EPSD(i)
331 ENDDO
332 ELSEIF(ifunc == 125 .and. ifail > 0) THEN
333 IF (igtyp == 18) THEN
334 DO i=lft,llt
335 n = i + nft
336 dammx = zero
337 DO j = 1,elbuf_tab(ng)%BUFLY(1)%NPTT
338 dammx = max(dammx,elbuf_tab(ng)%BUFLY(1)%FAIL(1,1,j)%FLOC(1)%DAMMX(i))
339 ENDDO
340 func(el2fa(nn7+n)) = dammx
341 ENDDO
342 ELSE IF (igtyp == 3) THEN
343 DO i=lft,llt
344 n = i + nft
345 func(el2fa(nn7+n)) = gbuf%FAIL(1)%DAMMX(i)
346 ENDDO
347 END IF
348 ELSE
349 DO i=lft,llt
350 n = i + nft
351 func(el2fa(nn7+n)) = zero
352 ENDDO
353 ENDIF
354C-----------------------------------------------
355C RESSORTS
356C-----------------------------------------------
357 ELSEIF(ity==6)THEN
358 IF(ifunc==3)THEN
359 IF (mlw==1) THEN
360 xm = one/geo(1,ixr(1,1+nft))
361 DO i=lft,llt
362 n = i + nft
363C XM cannot be zero (was checked in starter).
364 func(el2fa(nn8+n)) = gbuf%EINT(i)*xm
365 ENDDO
366 ELSEIF (mlw==2) THEN
367 xm = one/geo(1,ixr(1,1+nft))
368 DO i=lft,llt
369 n = i + nft
370C XM cannot be zero (was checked in starter).
371 func(el2fa(nn8+n)) = gbuf%EINT(i)*xm
372 ENDDO
373 ELSEIF (mlw==3) THEN
374 xm = one/geo(1,ixr(1,1+nft))
375 DO i=lft,llt
376 n = i + nft
377C XM cannot be zero (was checked in starter).
378 func(el2fa(nn8+n)) = gbuf%EINT(i)*xm
379 ENDDO
380 ELSEIF (mlw==4) THEN
381 xm = one/geo(1,ixr(1,1+nft))
382 DO i=lft,llt
383 n = i + nft
384C XM cannot be zero (was checked in starter).
385 func(el2fa(nn8+n)) = gbuf%EINT(i)*xm
386 ENDDO
387 ELSEIF (mlw==5) THEN
388C user springs.
389 DO i=lft,llt
390 n = i + nft
391 func(el2fa(nn8+n)) = gbuf%EINT(i)/max(em30,gbuf%MASS(i))
392 ENDDO
393 ELSEIF (mlw==6) THEN
394 xm = one/geo(1,ixr(1,1+nft))
395 DO i=lft,llt
396 n = i + nft
397C XM cannot be zero (was checked in starter).
398 func(el2fa(nn8+n)) = gbuf%EINT(i)*xm
399 ENDDO
400 ELSEIF (mlw==7) THEN
401 xm = one/geo(1,ixr(1,1+nft))
402 DO i=lft,llt
403 n = i + nft
404 func(el2fa(nn8+n)) = gbuf%EINT(i)*xm
405 ENDDO
406 ENDIF
407 ELSEIF(ifunc==11)THEN
408 DO i=lft,llt
409 n = i + nft
410 func(el2fa(nn8+n)) = anim(n)
411 ENDDO
412 ELSEIF(ifunc==12)THEN
413 kk = numelr * anim_fe(11)
414 DO i=lft,llt
415 n = i + nft
416 func(el2fa(nn8+n)) = anim(n+kk)
417 ENDDO
418 ELSEIF(ifunc==13)THEN
419 kk = numelr * (anim_fe(11)+anim_fe(12))
420 DO i=lft,llt
421 n = i + nft
422 func(el2fa(nn8+n)) = anim(n+kk)
423 ENDDO
424 ELSEIF(ifunc==20 .AND. gbuf%G_DT/=0)THEN
425 DO i=lft,llt
426 n = i + nft
427 func(el2fa(nn8+n)) = gbuf%DT(i)
428 ENDDO
429 ELSEIF ((ifunc==21).AND.(gbuf%G_ISMS>0)) THEN
430 DO i=lft,llt
431 n = i + nft
432 func(el2fa(nn8+n)) = gbuf%ISMS(i)
433 ENDDO
434 ELSEIF (ifunc == 22) THEN
435 DO i=lft,llt
436 n = i + nft
437 IF (gbuf%G_OFF > 0) THEN
438 IF(gbuf%OFF(i) > one) THEN
439 func(el2fa(nn8+n)) = gbuf%OFF(i) - one
440 ELSEIF((gbuf%OFF(i) >= zero .AND. gbuf%OFF(i) <= one)) THEN
441 func(el2fa(nn8+n)) = gbuf%OFF(i)
442 ELSE
443 func(el2fa(nn8+n)) = -one
444 ENDIF
445 ENDIF
446 ENDDO
447 ELSE
448 DO i=lft,llt
449 n = i + nft
450 func(el2fa(nn8+n)) = 0.
451 ENDDO
452 ENDIF
453 IF(mlw==3)THEN
454 DO i=lft,llt
455 n = i + nft
456 func(el2fa(nn8+n)+1) = func(el2fa(nn8+n))
457 ENDDO
458 ENDIF
459C
460 ENDIF
461C-----------------------------------------------
462C end of loop over offsets
463C-----------------------------------------------
464 END DO
465 ENDDO ! DO NG=1,NGROUP
466C-----------------------------------------------
467 IF (nspmd == 1) THEN
468 DO n=1,nbf
469 r4 = func(n)
470 CALL write_r_c(r4,1)
471 ENDDO
472C + X-ELEMENTS
473 IF (ifunc==3) THEN
474 DO n=1,nanim1d
475 VALUE = xfunc1(1,n)
476 r4 = VALUE
477 CALL write_r_c(r4,1)
478 ENDDO
479 ELSE
480 DO n=1,nanim1d
481 r4 = zero
482 CALL write_r_c(r4,1)
483 ENDDO
484 ENDIF
485 ELSE
486 DO n = 1, nbf
487 wal(n) = func(n)
488 ENDDO
489 IF (ifunc==3) THEN
490 DO n=1,nanim1d_l
491 VALUE = xfunc1(1,n)
492 wal(nbf+n)=VALUE
493 ENDDO
494 ELSE
495 DO n=1,nanim1d_l
496 wal(nbf+n)=0.
497 ENDDO
498 ENDIF
499 nbf2=nbf+nanim1d_l
500 IF (ispmd==0) THEN
501 buf = nb1dg+nanim1d
502 ELSE
503 buf=1
504 ENDIF
505 CALL spmd_r4get_partn(1,nbf2,nbpart,iadg,wal,buf)
506 ENDIF
507
508 DEALLOCATE(wal)
509 RETURN
510 END
511!||====================================================================
512!|| dfungps1 ../engine/source/output/anim/generate/dfuncf.f
513!||--- called by ------------------------------------------------------
514!|| genani ../engine/source/output/anim/generate/genani.F
515!||--- calls -----------------------------------------------------
516!|| initbuf ../engine/share/resol/initbuf.F
517!||--- uses -----------------------------------------------------
518!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
519!|| element_mod ../common_source/modules/elements/element_mod.F90
520!|| initbuf_mod ../engine/share/resol/initbuf.F
521!||====================================================================
522 SUBROUTINE dfungps1(ELBUF_TAB ,FUNC ,IFUNC ,IPARG ,GEO ,
523 . IXS ,IXS10 ,IXS16 ,IXS20 ,IXQ ,
524 . IXC ,IXTG ,IXT ,IXP ,IXR ,
525 . ITAGPS )
526C-----------------------------------------------
527C M o d u l e s
528C-----------------------------------------------
529 USE initbuf_mod
530 USE elbufdef_mod
531 use element_mod , only : nixs,nixq,nixc,nixtg,nixr,nixt,nixp
532C-----------------------------------------------
533C I m p l i c i t T y p e s
534C-----------------------------------------------
535#include "implicit_f.inc"
536C-----------------------------------------------
537C C o m m o n B l o c k s
538C-----------------------------------------------
539#include "vect01_c.inc"
540#include "mvsiz_p.inc"
541#include "com01_c.inc"
542#include "com04_c.inc"
543#include "param_c.inc"
544C-----------------------------------------------
545C D u m m y A r g u m e n t s
546C-----------------------------------------------
547C REAL
548 my_real
549 . func(*),geo(npropg,*)
550 INTEGER IPARG(NPARG,*),IFUNC,
551 . IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*),IXTG(NIXTG,*),
552 . IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),
553 . IXS10(6,*) ,IXS16(8,*) ,IXS20(12,*) ,ITAGPS(*)
554 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
555C-----------------------------------------------
556C L o c a l V a r i a b l e s
557C-----------------------------------------------
558C REAL
559 my_real
560 . evar(mvsiz),
561 . off, p, vonm2, vonm, s1, s2, s12, s3, VALUE,
562 . a1,b1,b2,b3,yeq,f1,m1,m2,m3,for,area
563 INTEGER I, J, N, NG, NEL, MLW, NN1,
564 . INOD, ISOLNOD, IPRT, LIAD, NPTR, NPTS, NPTT, IPT,
565 . is, ir, it, nptg,nc(20,mvsiz),nnod,ihbe,mpt,jj(6)
566 TYPE(g_bufel_) ,POINTER :: GBUF
567C=======================================================================
568 DO 900 NG=1,ngroup
569 CALL initbuf(iparg ,ng ,
570 2 mlw ,nel ,nft ,iad ,ity ,
571 3 npt ,jale ,ismstr ,jeul ,jtur ,
572 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
573 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
574 6 irep ,iint ,igtyp ,israt ,isrot ,
575 7 icsen ,isorth ,isorthg ,ifailure,jsms )
576 isolnod = iparg(28,ng)
577 lft=1
578 llt=nel
579 nnod = 0
580!
581 DO i=1,6
582 jj(i) = nel*(i-1)
583 ENDDO
584!
585C-----------------------------------------------
586C SOLID 8N
587C-----------------------------------------------
588 IF (ity==1) THEN
589 nnod = isolnod
590 gbuf => elbuf_tab(ng)%GBUF
591 DO i=lft,llt
592 n = i + nft
593 p = - (gbuf%SIG(jj(1) + i)
594 . + gbuf%SIG(jj(2) + i)
595 . + gbuf%SIG(jj(3) + i)) * third
596 VALUE = p
597 IF (ifunc==2) THEN
598 s1 = gbuf%SIG(jj(1) + i)+p
599 s2 = gbuf%SIG(jj(2) + i)+p
600 s3 = gbuf%SIG(jj(3) + i)+p
601 vonm2= three*(gbuf%SIG(jj(4) + i)**2 +
602 . gbuf%SIG(jj(5) + i)**2 +
603 . gbuf%SIG(jj(6) + i)**2 +
604 . half*(s1*s1+s2*s2+s3*s3))
605 vonm= sqrt(vonm2)
606 VALUE = vonm
607 ENDIF
608 evar(i) = VALUE
609 IF(isolnod==8)THEN
610 DO j = 1,isolnod
611 nc(j,i) = ixs(j+1,n)
612 ENDDO
613 ELSEIF(isolnod==4)THEN
614 nc(1,i)=ixs(2,n)
615 nc(2,i)=ixs(4,n)
616 nc(3,i)=ixs(7,n)
617 nc(4,i)=ixs(6,n)
618 ELSEIF(isolnod==6)THEN
619 nc(1,i)=ixs(2,n)
620 nc(2,i)=ixs(3,n)
621 nc(3,i)=ixs(4,n)
622 nc(4,i)=ixs(6,n)
623 nc(5,i)=ixs(7,n)
624 nc(6,i)=ixs(8,n)
625 ELSEIF(isolnod==10)THEN
626 nc(1,i)=ixs(2,n)
627 nc(2,i)=ixs(4,n)
628 nc(3,i)=ixs(7,n)
629 nc(4,i)=ixs(6,n)
630 nn1 = n - numels8
631 DO j=1,6
632C IF (IXS10(J,NN1)>0) THEN
633 nc(j+4,i) = ixs10(j,nn1)
634C ENDIF
635 ENDDO
636 ELSEIF(isolnod==16)THEN
637 DO j = 1,8
638 nc(j,i) = ixs(j+1,n)
639 ENDDO
640 nn1 = n - (numels8+numels10+numels20)
641 DO j=1,8
642 nc(j+8,i) = ixs16(j,nn1)
643 ENDDO
644 ELSEIF(isolnod==20)THEN
645 DO j = 1,8
646 nc(j,i) = ixs(j+1,n)
647 ENDDO
648 nn1 = n - (numels8+numels10)
649 DO j=1,12
650 nc(j+8,i) = ixs20(j,nn1)
651 ENDDO
652 ENDIF
653 ENDDO
654C
655C-----------------------------------------------
656C QUAD
657C-----------------------------------------------
658 ELSEIF(ity==2)THEN
659 gbuf => elbuf_tab(ng)%GBUF
660 nnod = 4
661 DO i=lft,llt
662 n = i + nft
663 p = - (gbuf%SIG(jj(1) + i)
664 . + gbuf%SIG(jj(2) + i)
665 . + gbuf%SIG(jj(3) + i) ) * third
666 VALUE = p
667 IF (ifunc==2) THEN
668 s1 = gbuf%SIG(jj(1) + i) + p
669 s2 = gbuf%SIG(jj(2) + i) + p
670 s3 = gbuf%SIG(jj(3) + i) + p
671 vonm2= three*(gbuf%SIG(jj(4) + i)**2 +
672 . gbuf%SIG(jj(5) + i)**2 +
673 . gbuf%SIG(jj(6) + i)**2 +
674 . half*(s1*s1+s2*s2+s3*s3))
675 vonm= sqrt(vonm2)
676 VALUE = vonm
677 ENDIF
678 evar(i) = VALUE
679 DO j = 1,nnod
680 nc(j,i) = ixq(j+1,n)
681 ENDDO
682 ENDDO
683C-----------------------------------------------
684C COQUES 3 N 4 N
685C-----------------------------------------------
686 ELSEIF(ity==3.OR.ity==7)THEN
687 gbuf => elbuf_tab(ng)%GBUF
688c
689 DO i=lft,llt
690 p = - (gbuf%FOR(jj(1)+i) + gbuf%FOR(jj(2)+i))*third
691 VALUE = p
692 IF (ifunc==2) THEN
693 s1 = gbuf%FOR(jj(1)+i)
694 s2 = gbuf%FOR(jj(2)+i)
695 s12= gbuf%FOR(jj(3)+i)
696 vonm2= s1*s1 + s2*s2 - s1*s2 + three*s12*s12
697 VALUE = sqrt(vonm2)
698 ENDIF
699 evar(i) = VALUE
700 ENDDO
701c
702 IF (ity==7) THEN
703 nnod=3
704 DO i=lft,llt
705 n = i + nft
706 DO j = 1,nnod
707 nc(j,i) = ixtg(j+1,n)
708 ENDDO
709 ENDDO
710 ELSEIF(ity==3)THEN
711 nnod=4
712 DO i=lft,llt
713 n = i + nft
714 DO j = 1,nnod
715 nc(j,i) = ixc(j+1,n)
716 ENDDO
717 ENDDO
718 ENDIF
719C-----------------------------------------------
720C TRUSS
721C-----------------------------------------------
722 ELSEIF (ity == 4) THEN
723 nnod=2
724 DO i=lft,llt
725 n = i + nft
726 VALUE = zero
727 nc(1,i) = 0
728 nc(2,i) = 0
729 IF (ifunc == 2) THEN
730 for = gbuf%FOR(i)
731 area = gbuf%AREA(i)
732 VALUE = sqrt(for*for)/area
733 nc(1,i) = ixt(2,n)
734 nc(2,i) = ixt(3,n)
735 ENDIF
736 evar(i) = VALUE
737 ENDDO
738C-----------------------
739C 5. ELEMENTS POUTRES
740C-----------------------
741 ELSEIF (ity == 5) THEN
742 nnod=2
743 DO i=lft,llt
744 n = i + nft
745 VALUE = zero
746 nc(1,i) = 0
747 nc(2,i) = 0
748 IF (ifunc == 2) THEN
749 a1 = geo(1,ixp(5,n))
750 b1 = geo(2,ixp(5,n))
751 b2 = geo(18,ixp(5,n))
752 b3 = geo(4,ixp(5,n))
753 f1 = gbuf%FOR(jj(1) + i)
754 m1 = gbuf%MOM(jj(1) + i)
755 m2 = gbuf%MOM(jj(2) + i)
756 m3 = gbuf%MOM(jj(3) + i)
757 yeq= f1*f1 + three* a1 *
758 + ( m1*m1 / max(b3,em30)
759 + + m2*m2 / max(b1,em30)
760 + + m3*m3 / max(b2,em30) )
761 VALUE = sqrt(yeq)/a1
762 nc(1,i) = ixp(2,n)
763 nc(2,i) = ixp(3,n)
764 ENDIF
765 evar(i) = VALUE
766 ENDDO
767 ENDIF ! IF (ITY)
768C
769 DO i=lft,llt
770 DO j=1,nnod
771 n = nc(j,i)
772 IF (n > 0) THEN
773 func(n) = func(n)+evar(i)
774 itagps(n) = itagps(n)+1
775 ENDIF
776 ENDDO
777 ENDDO
778C
779 900 CONTINUE
780C-----------------------------------------------
781 RETURN
782 END
783!||====================================================================
784!|| dfungps2 ../engine/source/output/anim/generate/dfuncf.F
785!||--- called by ------------------------------------------------------
786!|| genani ../engine/source/output/anim/generate/genani.F
787!||--- calls -----------------------------------------------------
788!|| initbuf ../engine/share/resol/initbuf.F
789!||--- uses -----------------------------------------------------
790!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
791!|| element_mod ../common_source/modules/elements/element_mod.F90
792!|| initbuf_mod ../engine/share/resol/initbuf.F
793!||====================================================================
794 SUBROUTINE dfungps2(ELBUF_TAB ,FUNC ,IFUNC ,IPARG ,GEO ,
795 . IXS ,IXS10 ,IXS16 ,IXS20 ,IXQ ,
796 . IXC ,IXTG ,IXT ,IXP ,IXR ,
797 . X ,VGPS )
798C-----------------------------------------------
799C M o d u l e s
800C-----------------------------------------------
801 USE initbuf_mod
802 USE elbufdef_mod
803 use element_mod , only : nixs,nixq,nixc,nixtg,nixr,nixt,nixp
804C-----------------------------------------------
805C I m p l i c i t T y p e s
806C-----------------------------------------------
807#include "implicit_f.inc"
808C-----------------------------------------------
809C C o m m o n B l o c k s
810C-----------------------------------------------
811#include "vect01_c.inc"
812#include "mvsiz_p.inc"
813#include "com01_c.inc"
814#include "com04_c.inc"
815#include "param_c.inc"
816C-----------------------------------------------
817C D u m m y A r g u m e n t s
818C-----------------------------------------------
819C REAL
820 my_real
821 . func(*),geo(npropg,*),x(3,*),vgps(*)
822 INTEGER IPARG(NPARG,*),IFUNC,
823 . IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*),IXTG(NIXTG,*),
824 . IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),
825 . IXS10(6,*) ,IXS16(8,*) ,IXS20(12,*)
826 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
827C-----------------------------------------------
828C L o c a l V a r i a b l e s
829C-----------------------------------------------
830C REAL
831 my_real
832 . evar(mvsiz),vol(mvsiz),
833 . off, p, vonm2, vonm, s1, s2, s12, s3, VALUE,
834 . a1,b1,b2,b3,yeq,f1,m1,m2,m3,for,area,
835 . xx1,xx2,xx3,yy1,yy2,yy3,zz1,zz2,zz3,thk0,al0
836 INTEGER I, NG, NEL,
837 . IADD, N, J,K, MLW,
838 . NN, MT, IMID, IALEL,IPID,
839 . NN1,NN2,NN3,NN4,NN5,NN6,NN7,NN8,NN9,NN10,NF,
840 . offset,inc,kk, ius, nuvar,
841 . inod, isolnod, iprt, liad, nptr, npts, nptt, ipt,
842 . is, ir, it, nptg,nc(20,mvsiz),nnod,iexpan,ihbe,mpt,
843 . n1,n2,n3,n4,jj(6)
844
845 TYPE(g_bufel_) ,POINTER :: GBUF
846C=======================================================================
847 DO 900 NG=1,ngroup
848 CALL initbuf(iparg ,ng ,
849 2 mlw ,nel ,nft ,iad ,ity ,
850 3 npt ,jale ,ismstr ,jeul ,jtur ,
851 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
852 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
853 6 irep ,iint ,igtyp ,israt ,isrot ,
854 7 icsen ,isorth ,isorthg ,ifailure,jsms )
855 isolnod = iparg(28,ng)
856 lft=1
857 llt=nel
858 nnod = 0
859!
860 DO i=1,6
861 jj(i) = nel*(i-1)
862 ENDDO
863!
864C-----------------------------------------------
865C SOLID 8N
866C-----------------------------------------------
867 IF(ity==1)THEN
868 nnod = isolnod
869 gbuf => elbuf_tab(ng)%GBUF
870 DO i=lft,llt
871 n = i + nft
872 p = - (gbuf%SIG(jj(1) + i)
873 . + gbuf%SIG(jj(2) + i)
874 . + gbuf%SIG(jj(3) + i)) * third
875 VALUE = p
876 IF (ifunc==2) THEN
877 s1 = gbuf%SIG(jj(1) + i)+p
878 s2 = gbuf%SIG(jj(2) + i)+p
879 s3 = gbuf%SIG(jj(3) + i)+p
880 vonm2= three*(gbuf%SIG(jj(4) + i)**2 +
881 . gbuf%SIG(jj(5) + i)**2 +
882 . gbuf%SIG(jj(6) + i)**2 +
883 . half*(s1*s1+s2*s2+s3*s3))
884 vonm= sqrt(vonm2)
885 VALUE = vonm
886 ENDIF
887 evar(i) = VALUE
888 off = min(gbuf%OFF(i),one)
889 vol(i) = gbuf%VOL(i)*off
890 IF(isolnod==8)THEN
891 DO j = 1,isolnod
892 nc(j,i) = ixs(j+1,n)
893 ENDDO
894 ELSEIF(isolnod==4)THEN
895 nc(1,i)=ixs(2,n)
896 nc(2,i)=ixs(4,n)
897 nc(3,i)=ixs(7,n)
898 nc(4,i)=ixs(6,n)
899 ELSEIF(isolnod==6)THEN
900 nc(1,i)=ixs(2,n)
901 nc(2,i)=ixs(3,n)
902 nc(3,i)=ixs(4,n)
903 nc(4,i)=ixs(6,n)
904 nc(5,i)=ixs(7,n)
905 nc(6,i)=ixs(8,n)
906 ELSEIF(isolnod==10)THEN
907 nc(1,i)=ixs(2,n)
908 nc(2,i)=ixs(4,n)
909 nc(3,i)=ixs(7,n)
910 nc(4,i)=ixs(6,n)
911 nn1 = n - numels8
912 DO j=1,6
913C IF (IXS10(J,NN1)>0) THEN
914 nc(j+4,i) = ixs10(j,nn1)
915C ENDIF
916 ENDDO
917 ELSEIF(isolnod==16)THEN
918 DO j = 1,8
919 nc(j,i) = ixs(j+1,n)
920 ENDDO
921 nn1 = n - (numels8+numels10+numels20)
922 DO j=1,8
923 nc(j+8,i) = ixs16(j,nn1)
924 ENDDO
925 ELSEIF(isolnod==20)THEN
926 DO j = 1,8
927 nc(j,i) = ixs(j+1,n)
928 ENDDO
929 nn1 = n - (numels8+numels10)
930 DO j=1,12
931 nc(j+8,i) = ixs20(j,nn1)
932 ENDDO
933 ENDIF
934 ENDDO
935C
936C-----------------------------------------------
937C QUAD
938C-----------------------------------------------
939 ELSEIF(ity==2)THEN
940 nnod = 4
941 gbuf => elbuf_tab(ng)%GBUF
942 DO i=lft,llt
943 n = i + nft
944 p = - (gbuf%SIG(jj(1) + i)
945 . + gbuf%SIG(jj(2) + i)
946 . + gbuf%SIG(jj(3) + i)) * third
947 VALUE = p
948 IF (ifunc==2) THEN
949 s1 = gbuf%SIG(jj(1) + i) + p
950 s2 = gbuf%SIG(jj(2) + i) + p
951 s3 = gbuf%SIG(jj(3) + i) + p
952 vonm2= three*(gbuf%SIG(jj(4) + i)**2 +
953 . gbuf%SIG(jj(5) + i)**2 +
954 . gbuf%SIG(jj(6) + i)**2 +
955 . half*(s1*s1+s2*s2+s3*s3))
956 vonm= sqrt(vonm2)
957 VALUE = vonm
958 ENDIF
959 evar(i) = VALUE
960 off = min(gbuf%OFF(i),one)
961 vol(i) = gbuf%VOL(i)*off
962 DO j = 1,nnod
963 nc(j,i) = ixq(j+1,n)
964 ENDDO
965 ENDDO
966C-----------------------------------------------
967C COQUES 3 N 4 N
968C-----------------------------------------------
969 ELSEIF(ity==3.OR.ity==7)THEN
970 gbuf => elbuf_tab(ng)%GBUF
971 DO i=lft,llt
972 p = -(gbuf%FOR(jj(1)+i)+ gbuf%FOR(jj(2)+i)) * third
973 VALUE = p
974 IF(ifunc==2) THEN
975 s1 = gbuf%FOR(jj(1)+i)
976 s2 = gbuf%FOR(jj(2)+i)
977 s12= gbuf%FOR(jj(3)+i)
978 vonm2= s1*s1 + s2*s2 - s1*s2 + three*s12*s12
979 VALUE = sqrt(vonm2)
980 ENDIF
981 evar(i) = VALUE
982 ENDDO
983c
984 IF(ity==7)THEN
985 nnod=3
986 DO i=lft,llt
987 n = i + nft
988 DO j = 1,nnod
989 nc(j,i) = ixtg(j+1,n)
990 ENDDO
991 thk0 = geo(1,ixtg(5,n))
992 n1 = ixtg(2,n)
993 n2 = ixtg(3,n)
994 n3 = ixtg(4,n)
995 xx1 = x(1,n2)-x(1,n1)
996 yy1 = x(2,n2)-x(2,n1)
997 zz1 = x(3,n2)-x(3,n1)
998 xx2 = x(1,n3)-x(1,n1)
999 yy2 = x(2,n3)-x(2,n1)
1000 zz2 = x(3,n3)-x(3,n1)
1001 xx3 = yy1*zz2 - zz1*yy2
1002 yy3 = zz1*xx2 - xx1*zz2
1003 zz3 = xx1*yy2 - yy1*xx2
1004 area = half*sqrt(xx3*xx3 + yy3*yy3 + zz3*zz3)
1005 off = min(gbuf%OFF(i),one)
1006 vol(i) = thk0*area*off
1007 ENDDO
1008 ELSEIF(ity==3)THEN
1009 nnod=4
1010 DO i=lft,llt
1011 n = i + nft
1012 DO j = 1,nnod
1013 nc(j,i) = ixc(j+1,n)
1014 ENDDO
1015 thk0 = geo(1,ixc(6,n))
1016 n1 = ixc(2,n)
1017 n2 = ixc(3,n)
1018 n3 = ixc(4,n)
1019 n4 = ixc(5,n)
1020 xx1 = x(1,n3)-x(1,n1)
1021 yy1 = x(2,n3)-x(2,n1)
1022 zz1 = x(3,n3)-x(3,n1)
1023 xx2 = x(1,n4)-x(1,n2)
1024 yy2 = x(2,n4)-x(2,n2)
1025 zz2 = x(3,n4)-x(3,n2)
1026 xx3 = yy1*zz2 - zz1*yy2
1027 yy3 = zz1*xx2 - xx1*zz2
1028 zz3 = xx1*yy2 - yy1*xx2
1029 area = half*sqrt(xx3*xx3 + yy3*yy3 + zz3*zz3)
1030 off = min(gbuf%OFF(i),one)
1031 vol(i) = thk0*area*off
1032 ENDDO
1033 ENDIF
1034C-----------------------------------------------
1035C TRUSS
1036C-----------------------------------------------
1037 ELSEIF (ity == 4) THEN
1038 nnod=2
1039 DO i=lft,llt
1040 n = i + nft
1041 VALUE = zero
1042 nc(1,i) = 0
1043 nc(2,i) = 0
1044 vol(i) = zero
1045 IF (ifunc == 2) THEN
1046 for = gbuf%FOR(i)
1047 area = gbuf%AREA(i)
1048 VALUE = sqrt(for*for)/area
1049 nc(1,i) = ixt(2,n)
1050 nc(2,i) = ixt(3,n)
1051 n1 = ixt(2,n)
1052 n2 = ixt(3,n)
1053 xx1 = x(1,n2)-x(1,n1)
1054 yy1 = x(2,n2)-x(2,n1)
1055 zz1 = x(3,n2)-x(3,n1)
1056 al0 = half*sqrt(xx1*xx1 + yy1*yy1 + zz1*zz1)
1057 off = min(gbuf%OFF(i),one)
1058 vol(i) = al0*area*off
1059 ENDIF
1060 evar(i) = VALUE
1061 ENDDO
1062C-----------------------
1063C 5. ELEMENTS POUTRES
1064C-----------------------
1065 ELSEIF (ity == 5) THEN
1066 nnod=2
1067 DO i=lft,llt
1068 n = i + nft
1069 VALUE = zero
1070 nc(1,i) = 0
1071 nc(2,i) = 0
1072 IF (ifunc == 2) THEN
1073 a1 = geo(1,ixp(5,n))
1074 b1 = geo(2,ixp(5,n))
1075 b2 = geo(18,ixp(5,n))
1076 b3 = geo(4,ixp(5,n))
1077 f1 = gbuf%FOR(jj(1) + i)
1078 m1 = gbuf%MOM(jj(1) + i)
1079 m2 = gbuf%MOM(jj(2) + i)
1080 m3 = gbuf%MOM(jj(3) + i)
1081 yeq= f1*f1 + three* a1 *
1082 + ( m1*m1 / max(b3,em30)
1083 + + m2*m2 / max(b1,em30)
1084 + + m3*m3 / max(b2,em30) )
1085 VALUE = sqrt(yeq)/a1
1086 nc(1,i) = ixp(2,n)
1087 nc(2,i) = ixp(3,n)
1088 n1 = ixp(2,n)
1089 n2 = ixp(3,n)
1090 xx1 = x(1,n2)-x(1,n1)
1091 yy1 = x(2,n2)-x(2,n1)
1092 zz1 = x(3,n2)-x(3,n1)
1093 al0 = half*sqrt(xx1*xx1 + yy1*yy1 + zz1*zz1)
1094 off = min(gbuf%OFF(i),one)
1095 vol(i) = al0*a1*off
1096 ENDIF
1097 evar(i) = VALUE
1098 ENDDO
1099 ENDIF ! IF (ITY)
1100C
1101 DO i=lft,llt
1102 DO j=1,nnod
1103 n = nc(j,i)
1104 IF (n > 0 .AND. vol(i) > zero) THEN
1105 func(n) = func(n)+evar(i)*vol(i)
1106 vgps(n) = vgps(n)+vol(i)
1107 ENDIF
1108 ENDDO
1109 ENDDO
1110C
1111 900 CONTINUE
1112C-----------------------------------------------
1113 RETURN
1114 END
my_real
#define my_real
Definition cppsort.cpp:32
dfuncf
subroutine dfuncf(elbuf_tab, func, ifunc, iparg, geo, ixt, ixp, ixr, mass, pm, el2fa, nbf, iadp, nbpart, ehour, anim, iadg, xfunc1, nanim1d_l, igeo)
Definition dfuncf.F:39
dfungps2
subroutine dfungps2(elbuf_tab, func, ifunc, iparg, geo, ixs, ixs10, ixs16, ixs20, ixq, ixc, ixtg, ixt, ixp, ixr, x, vgps)
Definition dfuncf.F:798
dfungps1
subroutine dfungps1(elbuf_tab, func, ifunc, iparg, geo, ixs, ixs10, ixs16, ixs20, ixq, ixc, ixtg, ixt, ixp, ixr, itagps)
Definition dfuncf.F:526
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
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
spmd_r4get_partn
subroutine spmd_r4get_partn(size, nbf_l, nbpart, iadg, wal, buf)
Definition spmd_r4get_partn.F:47
write_r_c
void write_r_c(float *w, int *len)
Definition write_routines.c:519