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