OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dfuncs.F File Reference
#include "implicit_f.inc"
#include "vect01_c.inc"
#include "mvsiz_p.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine dfuncs (elbuf_tab, func, ifunc, iparg, ixs, pm, el2fa, nbf, isph3d)

Function/Subroutine Documentation

◆ dfuncs()

subroutine dfuncs ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
func,
integer ifunc,
integer, dimension(nparg,*) iparg,
integer, dimension(nixs,*) ixs,
pm,
integer, dimension(*) el2fa,
integer nbf,
integer isph3d )

Definition at line 31 of file dfuncs.F.

33C-----------------------------------------------
34C M o d u l e s
35C-----------------------------------------------
36 USE elbufdef_mod
37 use element_mod , only : nixs
38C-----------------------------------------------
39C I m p l i c i t T y p e s
40C-----------------------------------------------
41#include "implicit_f.inc"
42C-----------------------------------------------
43C C o m m o n B l o c k s
44C-----------------------------------------------
45#include "vect01_c.inc"
46#include "mvsiz_p.inc"
47#include "com01_c.inc"
48#include "com04_c.inc"
49#include "param_c.inc"
50C-----------------------------------------------
51C D u m m y A r g u m e n t s
52C-----------------------------------------------
53C REAL
54 my_real
55 . func(*), pm(npropm,*)
56 INTEGER IPARG(NPARG,*),EL2FA(*),
57 . IXS(NIXS,*),IFUNC,NBF,ISPH3D
58 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
59 REAL WAL(NBF)
60C-----------------------------------------------
61C L o c a l V a r i a b l e s
62C-----------------------------------------------
63C REAL
64 my_real
65 . evar(mvsiz),
66 . off, p, vonm2, vonm, s1, s2, s12, s3, VALUE
67 INTEGER I, NG, NEL,N, J, MLW,NN, JTURB,MT, IALEL,
68 . NN1,NN2,NN3,OFFSET,II(6),INOD, ISOLNOD,
69 . JHBE, JIVF, JCLOSE, JPLASOL, IREP, IGTYP,
70 . ICSEN, ISORTHG, IFAILURE, IINT
71 TYPE(G_BUFEL_) ,POINTER :: GBUF
72 REAL R4
73C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
74C La routine ne fonctionne que pour les IFUNC 3,6,7,14-19 (stress)
75C-----------------------------------------------
76 nn1 = 1
77 nn2 = 1
78 nn3 = nn2 + numels
79C
80 DO 900 ng=1,ngroup
81 CALL initbuf (iparg ,ng ,
82 2 mlw ,nel ,nft ,iad ,ity ,
83 3 npt ,jale ,ismstr ,jeul ,jtur ,
84 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
85 5 jpor ,jcvt ,jclose ,jplasol ,
86 6 irep ,iint ,igtyp ,israt ,isrot ,
87 7 icsen ,isorth ,isorthg ,ifailure)
88 DO offset = 0,nel-1,nvsiz
89 nft =iparg(3,ng) + offset
90 isolnod = iparg(28,ng)
91 lft=1
92 llt=min(nvsiz,nel-offset)
93!
94 DO i=1,6
95 ii(i) = (i-1)*llt
96 ENDDO
97!
98C-----------------------------------------------
99C SOLID 8N
100C-----------------------------------------------
101 IF (ity == 1) THEN
102C-----------
103 gbuf => elbuf_tab(ng)%GBUF
104c
105 IF (mlw == 0 .OR. mlw == 13 . or. igtyp == 0) THEN
106 DO i=lft,llt
107 evar(i) = zero
108 ENDDO
109 ELSE
110 jturb=iparg(12,ng)*(iparg(7,ng)+iparg(11,ng))
111C
112 IF (ifunc == 1) THEN
113 DO i=lft,llt
114 IF (gbuf%G_PLA > 0) THEN
115 evar(i) = gbuf%PLA(i)
116 ENDIF
117 ENDDO
118 ELSEIF(ifunc == 2)THEN
119 DO i=lft,llt
120 evar(i) = gbuf%RHO(i)
121 ENDDO
122 ELSEIF(ifunc == 3)THEN
123 DO i=lft,llt
124 n = i + nft
125 ialel=iparg(7,ng)+iparg(11,ng)
126 IF (ialel == 0) THEN
127 mt=ixs(1,n)
128 evar(i) = gbuf%EINT(i)/max(em30,pm(1,mt))
129 ELSE
130 evar(i) = gbuf%EINT(i)/max(em30,gbuf%RHO(i))
131 ENDIF
132 ENDDO
133 ELSEIF (ifunc == 4) THEN
134 DO i=lft,llt
135 IF (gbuf%G_TEMP > 0) THEN
136 evar(i) = gbuf%TEMP(i)
137 ENDIF
138 ENDDO
139 ELSEIF(ifunc == 6 .OR. ifunc == 7)THEN
140 DO i=lft,llt
141 n = i + nft
142 p = - (gbuf%SIG(ii(1) + i)
143 . + gbuf%SIG(ii(2) + i)
144 . + gbuf%SIG(ii(3) + i)) * third
145 VALUE = p
146 IF (ifunc == 7) THEN
147 s1=gbuf%SIG(ii(1) + i)+p
148 s2=gbuf%SIG(ii(2) + i)+p
149 s3=gbuf%SIG(ii(3) + i)+p
150 vonm2= three*(gbuf%SIG(ii(4) + i)**2 +
151 . gbuf%SIG(ii(5) + i)**2 +
152 . gbuf%SIG(ii(6) + i)**2 +
153 . half*(s1*s1+s2*s2+s3*s3) )
154 vonm= sqrt(vonm2)
155 VALUE = vonm
156 ENDIF
157 evar(i) = VALUE
158 ENDDO
159c-----------
160 ELSEIF(ifunc >= 14 .AND. ifunc <= 19)THEN
161 DO i=lft,llt
162 evar(i) = gbuf%SIG(ii(ifunc-13) + i)
163 ENDDO
164 ENDIF
165c-----------
166 IF (isolnod == 16) THEN
167 DO i=lft,llt
168 n = nn2 + i + nft
169 IF(el2fa(n)/=0)THEN
170 func(el2fa(n)) = evar(i)
171 func(el2fa(n)+1) = evar(i)
172 func(el2fa(n)+2) = evar(i)
173 func(el2fa(n)+3) = evar(i)
174 ENDIF
175 ENDDO
176 ELSE
177 DO i=lft,llt
178 n = nn2 + i + nft
179 IF(el2fa(n)/=0)THEN
180 func(el2fa(n)) = evar(i)
181 ENDIF
182 ENDDO
183 ENDIF
184 ENDIF
185C
186C-----------------------------------------------
187 ELSEIF (isph3d == 1.AND.ity == 51) THEN
188C TETRAS SPH.
189C-----------------------------------------------
190 gbuf => elbuf_tab(ng)%GBUF
191 IF (ifunc >= 14 .AND. ifunc <= 19) THEN
192 DO i=lft,llt
193 n = i + nft
194 IF (el2fa(nn3+n)/=0) THEN
195 func(el2fa(nn3+n)) = gbuf%SIG(ii(ifunc-13) + i)
196 ENDIF
197 ENDDO
198 ELSE
199 DO i=lft,llt
200 n = i + nft
201 IF(el2fa(nn3+n)/=0)THEN
202 func(el2fa(nn3+n)) = zero
203 ENDIF
204 ENDDO
205 ENDIF
206C
207 ENDIF
208C-----------------------------------------------
209C END OF LOOP ON OFFSETS
210C-----------------------------------------------
211 ENDDO
212 900 CONTINUE
213C-----------------------------------------------
214 DO n=1,nbf
215 r4 = func(n)
216 CALL write_r_c(r4,1)
217 ENDDO
218C-----------
219 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure)
Definition initbuf.F:38
write_r_c
void write_r_c(float *w, int *len)
Definition write_routines.c:519