OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dfuncc.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 dfuncc (elbuf_tab, bufel, func, ifunc, iparg, ixq, ixc, ixtg, pm, el2fa, nbf)

Function/Subroutine Documentation

◆ dfuncc()

subroutine dfuncc ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
bufel,
func,
integer ifunc,
integer, dimension(nparg,*) iparg,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
pm,
integer, dimension(*) el2fa,
integer nbf )

Definition at line 30 of file dfuncc.F.

33C-----------------------------------------------
34C M o d u l e s
35C-----------------------------------------------
36 USE elbufdef_mod
37 use element_mod , only : nixq,nixc,nixtg
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 . bufel(*),func(*),pm(npropm,*)
56 INTEGER IPARG(NPARG,*),IXC(NIXC,*),IXTG(NIXTG,*),EL2FA(*),
57 . IXQ(NIXQ,*),IFUNC,NBF
58 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
59C-----------------------------------------------
60C L o c a l V a r i a b l e s
61C-----------------------------------------------
62C REAL
63 my_real
64 . evar(mvsiz),
65 . p, vonm2, s1, s2, s12, s3, VALUE
66 INTEGER I,II(6), NG, NEL, N, MLW, IUS,MT,IALEL,
67 . NN1,NN3,NN4,NN5,NN6,NN7,NN8,NN9,
68 . OFFSET
69 TYPE(G_BUFEL_) ,POINTER :: GBUF
70 REAL R4
71C-----------------------------------------------
72C La routine ne fonctionne que pour les IFUNC 3,6,7,14-19 (stress)
73 nn1 = 1
74 nn3 = 1
75 nn4 = nn3 + numelq
76 nn5 = nn4 + numelc
77 nn6 = nn5 + numeltg
78 nn7 = nn6
79 nn8 = nn7
80 nn9 = nn8
81C
82 DO 900 ng=1,ngroup
83 mlw = iparg(1,ng)
84 nel = iparg(2,ng)
85 nft = iparg(3,ng)
86 ity = iparg(5,ng)
87 DO offset = 0,nel-1,nvsiz
88 lft=1
89 llt=min(nvsiz,nel-offset)
90!
91 DO i=1,6
92 ii(i) = (i-1)*nel
93 ENDDO
94!
95C-----------------------------------------------
96C QUAD
97C-----------------------------------------------
98 IF (ity == 2) THEN
99 gbuf => elbuf_tab(ng)%GBUF
100C-----
101 IF(ifunc == 3)THEN
102 DO i=lft,llt
103 n = i + nft
104 ialel=iparg(7,ng)+iparg(11,ng)
105 IF(ialel == 0)THEN
106 mt=ixq(1,n)
107 VALUE = gbuf%EINT(i)/max(em30,pm(1,mt))
108 ELSE
109 VALUE = gbuf%EINT(i)/max(em30,gbuf%RHO(i))
110 ENDIF
111 func(el2fa(nn3+n)) = VALUE
112 ENDDO
113C-----
114 ELSEIF (ifunc == 6 .or. ifunc == 7) THEN
115 DO i=lft,llt
116 n = i + nft
117 p = -(gbuf%SIG(ii(1) + i)
118 . + gbuf%SIG(ii(2) + i)
119 . + gbuf%SIG(ii(3) + i))*third
120 func(el2fa(nn3+nft+i)) = p
121 VALUE = p
122 IF(ifunc == 7) THEN
123 s1 = gbuf%SIG(ii(1) + i) + p
124 s2 = gbuf%SIG(ii(2) + i) + p
125 s3 = gbuf%SIG(ii(3) + i) + p
126 vonm2 = three*(gbuf%SIG(ii(4) + i)**2
127 . + half*(s1**2+s2**2+s3**2))
128 VALUE = sqrt(vonm2)
129 ENDIF
130 func(el2fa(nn3+n)) = VALUE
131 ENDDO
132C-----
133 ELSEIF(ifunc == 14)THEN
134 DO i=lft,llt
135 n = i + nft
136 func(el2fa(nn3+n)) = gbuf%SIG(ii(3) + i)
137 ENDDO
138C-----
139 ELSEIF(ifunc == 15)THEN
140 DO i=lft,llt
141 n = i + nft
142 func(el2fa(nn3+n)) = gbuf%SIG(ii(1) + i)
143 ENDDO
144C-----
145 ELSEIF(ifunc == 16)THEN
146 DO i=lft,llt
147 n = i + nft
148 func(el2fa(nn3+n)) = gbuf%SIG(ii(2) + i)
149 ENDDO
150C-----
151 ELSEIF(ifunc == 17.OR.ifunc == 18)THEN
152 DO i=lft,llt
153 n = i + nft
154 func(el2fa(nn3+n)) = gbuf%SIG(ii(4) + i)
155 ENDDO
156C-----
157 ELSE
158 DO i=lft,llt
159 n = i + nft
160 func(el2fa(nn3+n)) = zero
161 ENDDO
162 ENDIF
163C-----------------------------------------------
164 ELSEIF (ity == 3 .OR. ity == 7)THEN
165C COQUES 3 N 4 N
166C-----------------------------------------------
167 gbuf => elbuf_tab(ng)%GBUF
168 DO i=lft,llt
169 evar(i) = zero
170 ENDDO
171c-----
172 IF (mlw == 0) THEN
173 CONTINUE
174 ELSEIF (ifunc == 3)THEN
175 DO i=lft,llt
176 evar(i) = gbuf%EINT(i) + gbuf%EINT(i+llt)
177 ENDDO
178c-----
179 ELSEIF(ifunc == 7)THEN
180 DO i=lft,llt
181 s1 = gbuf%FOR(ii(1)+i)
182 s2 = gbuf%FOR(ii(2)+i)
183 s12= gbuf%FOR(ii(3)+i)
184 vonm2= s1*s1 + s2*s2 - s1*s2 + three*s12*s12
185 evar(i) = sqrt(vonm2)
186 ENDDO
187c-----
188 ELSEIF(ifunc>=14 .and. ifunc<=15)THEN
189 ius = ifunc-13
190 DO i=lft,llt
191 evar(i) = gbuf%FOR(ii(ius)+i)
192 ENDDO
193c-----
194 ELSEIF(ifunc>=17 .and. ifunc<=19)THEN
195 ius = ifunc-14
196 DO i=lft,llt
197 evar(i) = gbuf%FOR(ii(ius)+i)
198 ENDDO
199 ENDIF
200C-------------------
201 IF(ity == 3)THEN
202 DO i=lft,llt
203 n = i + nft
204 func(el2fa(nn4+n)) = evar(i)
205 ENDDO
206 ELSE
207 DO i=lft,llt
208 n = i + nft
209 func(el2fa(nn5+n)) = evar(i)
210 ENDDO
211 ENDIF
212C
213 ELSE
214 CONTINUE
215 ENDIF
216C-----------------------------------------------
217C END OF LOOP ON OFFSETS
218C-----------------------------------------------
219 END DO
220 900 CONTINUE
221C-----------------------------------------------
222 DO n=1,nbf
223 r4 = func(n)
224 CALL write_r_c(r4,1)
225 ENDDO
226C
227 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
write_r_c
void write_r_c(float *w, int *len)
Definition write_routines.c:519