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