OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
soltosph.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "parit_c.inc"
#include "sphcom.inc"
#include "task_c.inc"
#include "vect01_c.inc"
#include "lockon.inc"
#include "lockoff.inc"
#include "mvsiz_p.inc"
#include "com08_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine soltosphf (a, spbuf, ixs, kxsp, ipartsp, nod2sp, irst, ngrounc, igrounc, iparg, stifn, sol2sph, sph2sol, elbuf_tab, itask, nodft, nodlt, isky, fskyi, igeo, sol2sph_typ)
subroutine soltosphp (x, spbuf, ixs, kxsp, ipartsp, irst, elbuf_tab, iparg, ngrounc, igrounc, sol2sph, wa, pm)

Function/Subroutine Documentation

◆ soltosphf()

subroutine soltosphf ( a,
spbuf,
integer, dimension(nixs,*) ixs,
integer, dimension(nisp,*) kxsp,
integer, dimension(*) ipartsp,
integer, dimension(*) nod2sp,
integer, dimension(3,*) irst,
integer ngrounc,
integer, dimension(*) igrounc,
integer, dimension(nparg,*) iparg,
stifn,
integer, dimension(2,*) sol2sph,
integer, dimension(*) sph2sol,
type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer itask,
integer nodft,
integer nodlt,
integer, dimension(*) isky,
fskyi,
integer, dimension(npropgi,*) igeo,
integer, dimension(*) sol2sph_typ )

Definition at line 38 of file soltosph.F.

44C-----------------------------------------------
45 USE elbufdef_mod
46 USE soltosph_mod
47 USE message_mod
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52#include "comlock.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com01_c.inc"
57#include "com04_c.inc"
58#include "param_c.inc"
59#include "parit_c.inc"
60#include "sphcom.inc"
61#include "task_c.inc"
62#include "vect01_c.inc"
63C-----------------------------------------------
64C D u m m y A r g u m e n t s
65C-----------------------------------------------
66 INTEGER IXS(NIXS,*), KXSP(NISP,*), IPARTSP(*), NOD2SP(*),
67 . IRST(3,*), NGROUNC, IGROUNC(*), IPARG(NPARG,*),
68 . SOL2SPH(2,*), SPH2SOL(*), ITASK, NODFT, NODLT, ISKY(*),
69 . IGEO(NPROPGI,*),SOL2SPH_TYP(*)
70 my_real
71 . a(3,*), spbuf(nspbuf,*), stifn(*), fskyi(lskyi,nfskyi)
72 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76 INTEGER I, J, IR, IS, IT, KP, NP, N, INOD, MG, NG, NEL,
77 . KFT, N1, N2, N3, N4, N5, N6, N7, N8,
78 . LENR, IG , NELEM, OFFSET, NSPHDIR, IPRTSPH, IAW,
79 . MY_IAW, IERROR, NISK, NIFTSK, NILTSK, NISKYL, NSOL
80C
81 my_real
82 . phi1,phi2,phi3,phi4,phi5,phi6,phi7,phi8,
83 . ksi, eta, zeta
84C-----
85 TYPE(G_BUFEL_) ,POINTER :: GBUF, GBUFSP
86 TYPE(L_BUFEL_) ,POINTER :: LBUF
87 TYPE(BUF_MAT_) ,POINTER :: MBUF
88C-----------------------------------------------
89 my_real
90 . a_gauss(9,9),a_gauss_tetra(9,9)
91 DATA a_gauss /
92 1 0. ,0. ,0. ,
93 1 0. ,0. ,0. ,
94 1 0. ,0. ,0. ,
95 2 -.5 ,0.5 ,0. ,
96 2 0. ,0. ,0. ,
97 2 0. ,0. ,0. ,
98 3 -.666666666666666,0. ,0.666666666666666,
99 3 0. ,0. ,0. ,
100 3 0. ,0. ,0. ,
101 4 -.75 ,-.25 ,0.25 ,
102 4 0.75 ,0. ,0. ,
103 4 0. ,0. ,0. ,
104 5 -.8 ,-.4 ,0. ,
105 5 0.4 ,0.8 ,0. ,
106 5 0. ,0. ,0. ,
107 6 -.833333333333333,-.5 ,-.166666666666666,
108 6 0.166666666666666,0.5 ,0.833333333333333,
109 6 0. ,0. ,0. ,
110 7 -.857142857142857,-.571428571428571,-.285714285714285,
111 7 0. ,0.285714285714285,0.571428571428571,
112 7 0.857142857142857,0. ,0. ,
113 8 -.875 ,-.625 ,-.375 ,
114 8 -.125 ,0.125 ,0.375,
115 8 0.625 ,0.875 ,0. ,
116 9 -.888888888888888,-.666666666666666,-.444444444444444,
117 9 -.222222222222222,0. ,0.222222222222222,
118 9 0.444444444444444,0.666666666666666,0.888888888888888/
119C-----------------------------------------------
120 DATA a_gauss_tetra /
121 1 0.250000000000000,0.000000000000000,0.000000000000000,
122 1 0.000000000000000,0.000000000000000,0.000000000000000,
123 1 0.000000000000000,0.000000000000000,0.000000000000000,
124 2 0.166666666666667,0.500000000000000,0.000000000000000,
125 2 0.000000000000000,0.000000000000000,0.000000000000000,
126 2 0.000000000000000,0.000000000000000,0.000000000000000,
127 3 0.125000000000000,0.375000000000000,0.625000000000000,
128 3 0.000000000000000,0.000000000000000,0.000000000000000,
129 3 0.000000000000000,0.000000000000000,0.000000000000000,
130 4 0.100000000000000,0.300000000000000,0.500000000000000,
131 4 0.700000000000000,0.000000000000000,0.000000000000000,
132 4 0.000000000000000,0.000000000000000,0.000000000000000,
133 5 0.083333333333333,0.250000000000000,0.416666666666667,
134 5 0.583333333333333,0.750000000000000,0.000000000000000,
135 5 0.000000000000000,0.000000000000000,0.000000000000000,
136 6 0.071428571428571,0.214285714285714,0.357142857142857,
137 6 0.500000000000000,0.642857142857143,0.785714285714286,
138 6 0.000000000000000,0.000000000000000,0.000000000000000,
139 7 0.062500000000000,0.187500000000000,0.312500000000000,
140 7 0.437500000000000,0.562500000000000,0.687500000000000,
141 7 0.812500000000000,0.000000000000000,0.000000000000000,
142 8 0.055555555555556,0.166666666666667,0.277777777777778,
143 8 0.388888888888889,0.500000000000000,0.611111111111111,
144 8 0.722222222222222,0.833333333333333,0.000000000000000,
145 9 0.050000000000000,0.150000000000000,0.250000000000000,
146 9 0.350000000000000,0.450000000000000,0.550000000000000,
147 9 0.650000000000000,0.750000000000000,0.850000000000000/
148C-----------------------------------------------
149C MAPPING OF CONTACT FORCES APPLYING TO SLEEPING PARTICLES
150C-----------------------------------------------
151 IF(iparit==0)THEN
152 IF(itask==0)THEN
153 ALLOCATE(awork(4,nthread*numnod),stat=ierror)
154 IF(ierror/=0) THEN
155 CALL ancmsg(msgid=19,anmode=aninfo,
156 . c1='(SOLIDS to SPH)')
157 CALL arret(2)
158 ENDIF
159 END IF
160C
161 CALL my_barrier
162C
163 DO iaw=itask*numnod+1,(itask+1)*numnod
164 awork(1,iaw)=zero
165 awork(2,iaw)=zero
166 awork(3,iaw)=zero
167 awork(4,iaw)=zero
168 END DO
169C
170 CALL my_barrier
171C
172 my_iaw=itask*numnod
173!$OMP DO SCHEDULE(DYNAMIC,1)
174 DO ig = 1, ngrounc
175 ng = igrounc(ig)
176 IF(iparg(8,ng)==1)GOTO 350
177 IF (iddw>0) CALL startimeg(ng)
178 DO nelem = 1,iparg(2,ng),nvsiz
179 offset = nelem - 1
180 nel =iparg(2,ng)
181 nft =iparg(3,ng) + offset
182 iad =iparg(4,ng)
183 ity =iparg(5,ng)
184 iprtsph=iparg(69,ng)
185 lft=1
186 llt=min(nvsiz,nel-nelem+1)
187 IF(ity==1.AND.iprtsph/=0) THEN
188C-----------
189 gbuf => elbuf_tab(ng)%GBUF
190 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
191 mbuf => elbuf_tab(ng)%BUFLY(1)%MAT(1,1,1)
192C-----
193C----TETRA---
194C-----
195 IF (iparg(28,ng)==4) THEN
196C-----
197 DO i=lft,llt
198 n=nft+i
199 IF(gbuf%OFF(i)/=zero) THEN
200C
201 n1=ixs(2,n)
202 n2=ixs(3,n)
203 n3=ixs(4,n)
204 n4=ixs(5,n)
205C
206 nsphdir=igeo(37,ixs(10,n))
207C
208C-----------------------------------------------
209C SOL2SPH(1,N)+1<=I<=SOLSPH(2,N) <=> N==SPH2SOL(I)
210 DO kp=1,sol2sph(2,n)-sol2sph(1,n)
211 np =sol2sph(1,n)+kp
212 ir=irst(1,np-first_sphsol+1)
213 is=irst(2,np-first_sphsol+1)
214 it=irst(3,np-first_sphsol+1)
215 ksi = a_gauss_tetra(ir,nsphdir)
216 eta = a_gauss_tetra(is,nsphdir)
217 zeta = a_gauss_tetra(it,nsphdir)
218C
219 phi1=ksi
220 phi2=eta
221 phi3=zeta
222 phi4=1-ksi-eta-zeta
223C
224 inod=kxsp(3,np)
225 awork(1,my_iaw+n1)=awork(1,my_iaw+n1)+phi1*a(1,inod)
226 awork(2,my_iaw+n1)=awork(2,my_iaw+n1)+phi1*a(2,inod)
227 awork(3,my_iaw+n1)=awork(3,my_iaw+n1)+phi1*a(3,inod)
228 awork(4,my_iaw+n1)=awork(4,my_iaw+n1)+phi1*stifn(inod)
229 awork(1,my_iaw+n2)=awork(1,my_iaw+n2)+phi2*a(1,inod)
230 awork(2,my_iaw+n2)=awork(2,my_iaw+n2)+phi2*a(2,inod)
231 awork(3,my_iaw+n2)=awork(3,my_iaw+n2)+phi2*a(3,inod)
232 awork(4,my_iaw+n2)=awork(4,my_iaw+n2)+phi2*stifn(inod)
233 awork(1,my_iaw+n3)=awork(1,my_iaw+n3)+phi3*a(1,inod)
234 awork(2,my_iaw+n3)=awork(2,my_iaw+n3)+phi3*a(2,inod)
235 awork(3,my_iaw+n3)=awork(3,my_iaw+n3)+phi3*a(3,inod)
236 awork(4,my_iaw+n3)=awork(4,my_iaw+n3)+phi3*stifn(inod)
237 awork(1,my_iaw+n4)=awork(1,my_iaw+n4)+phi4*a(1,inod)
238 awork(2,my_iaw+n4)=awork(2,my_iaw+n4)+phi4*a(2,inod)
239 awork(3,my_iaw+n4)=awork(3,my_iaw+n4)+phi4*a(3,inod)
240 awork(4,my_iaw+n4)=awork(4,my_iaw+n4)+phi4*stifn(inod)
241C
242 a(1,inod)=zero
243 a(2,inod)=zero
244 a(3,inod)=zero
245 stifn(inod)=em20
246 ENDDO
247 END IF
248 ENDDO
249C-----
250 ELSE
251C-----
252C----HEXA---
253C-----
254 DO i=lft,llt
255 n=nft+i
256 IF(gbuf%OFF(i)/=zero) THEN
257C
258 n1=ixs(2,n)
259 n2=ixs(3,n)
260 n3=ixs(4,n)
261 n4=ixs(5,n)
262 n5=ixs(6,n)
263 n6=ixs(7,n)
264 n7=ixs(8,n)
265 n8=ixs(9,n)
266C
267 nsphdir=nint((sol2sph(2,n)-sol2sph(1,n))**third)
268C
269C-----------------------------------------------
270C SOL2SPH(1,N)+1<=I<=SOLSPH(2,N) <=> N==SPH2SOL(I)
271 DO kp=1,sol2sph(2,n)-sol2sph(1,n)
272 np =sol2sph(1,n)+kp
273 ir=irst(1,np-first_sphsol+1)
274 is=irst(2,np-first_sphsol+1)
275 it=irst(3,np-first_sphsol+1)
276 ksi = a_gauss(ir,nsphdir)
277 eta = a_gauss(is,nsphdir)
278 zeta = a_gauss(it,nsphdir)
279C
280 phi1=one_over_8*(one-ksi)*(one-eta)*(one-zeta)
281 phi2=one_over_8*(one-ksi)*(one-eta)*(one+zeta)
282 phi3=one_over_8*(one+ksi)*(one-eta)*(one+zeta)
283 phi4=one_over_8*(one+ksi)*(one-eta)*(one-zeta)
284 phi5=one_over_8*(one-ksi)*(one+eta)*(one-zeta)
285 phi6=one_over_8*(one-ksi)*(one+eta)*(one+zeta)
286 phi7=one_over_8*(one+ksi)*(one+eta)*(one+zeta)
287 phi8=one_over_8*(one+ksi)*(one+eta)*(one-zeta)
288C
289 inod=kxsp(3,np)
290 awork(1,my_iaw+n1)=awork(1,my_iaw+n1)+phi1*a(1,inod)
291 awork(2,my_iaw+n1)=awork(2,my_iaw+n1)+phi1*a(2,inod)
292 awork(3,my_iaw+n1)=awork(3,my_iaw+n1)+phi1*a(3,inod)
293 awork(4,my_iaw+n1)=awork(4,my_iaw+n1)+phi1*stifn(inod)
294 awork(1,my_iaw+n2)=awork(1,my_iaw+n2)+phi2*a(1,inod)
295 awork(2,my_iaw+n2)=awork(2,my_iaw+n2)+phi2*a(2,inod)
296 awork(3,my_iaw+n2)=awork(3,my_iaw+n2)+phi2*a(3,inod)
297 awork(4,my_iaw+n2)=awork(4,my_iaw+n2)+phi2*stifn(inod)
298 awork(1,my_iaw+n3)=awork(1,my_iaw+n3)+phi3*a(1,inod)
299 awork(2,my_iaw+n3)=awork(2,my_iaw+n3)+phi3*a(2,inod)
300 awork(3,my_iaw+n3)=awork(3,my_iaw+n3)+phi3*a(3,inod)
301 awork(4,my_iaw+n3)=awork(4,my_iaw+n3)+phi3*stifn(inod)
302 awork(1,my_iaw+n4)=awork(1,my_iaw+n4)+phi4*a(1,inod)
303 awork(2,my_iaw+n4)=awork(2,my_iaw+n4)+phi4*a(2,inod)
304 awork(3,my_iaw+n4)=awork(3,my_iaw+n4)+phi4*a(3,inod)
305 awork(4,my_iaw+n4)=awork(4,my_iaw+n4)+phi4*stifn(inod)
306 awork(1,my_iaw+n5)=awork(1,my_iaw+n5)+phi5*a(1,inod)
307 awork(2,my_iaw+n5)=awork(2,my_iaw+n5)+phi5*a(2,inod)
308 awork(3,my_iaw+n5)=awork(3,my_iaw+n5)+phi5*a(3,inod)
309 awork(4,my_iaw+n5)=awork(4,my_iaw+n5)+phi5*stifn(inod)
310 awork(1,my_iaw+n6)=awork(1,my_iaw+n6)+phi6*a(1,inod)
311 awork(2,my_iaw+n6)=awork(2,my_iaw+n6)+phi6*a(2,inod)
312 awork(3,my_iaw+n6)=awork(3,my_iaw+n6)+phi6*a(3,inod)
313 awork(4,my_iaw+n6)=awork(4,my_iaw+n6)+phi6*stifn(inod)
314 awork(1,my_iaw+n7)=awork(1,my_iaw+n7)+phi7*a(1,inod)
315 awork(2,my_iaw+n7)=awork(2,my_iaw+n7)+phi7*a(2,inod)
316 awork(3,my_iaw+n7)=awork(3,my_iaw+n7)+phi7*a(3,inod)
317 awork(4,my_iaw+n7)=awork(4,my_iaw+n7)+phi7*stifn(inod)
318 awork(1,my_iaw+n8)=awork(1,my_iaw+n8)+phi8*a(1,inod)
319 awork(2,my_iaw+n8)=awork(2,my_iaw+n8)+phi8*a(2,inod)
320 awork(3,my_iaw+n8)=awork(3,my_iaw+n8)+phi8*a(3,inod)
321 awork(4,my_iaw+n8)=awork(4,my_iaw+n8)+phi8*stifn(inod)
322C
323 a(1,inod)=zero
324 a(2,inod)=zero
325 a(3,inod)=zero
326 stifn(inod)=em20
327 ENDDO
328 END IF
329 ENDDO
330C--------
331 ENDIF
332 ENDIF
333 IF (iddw>0) CALL stoptimeg(ng)
334 END DO
335C--------
336 350 CONTINUE
337 END DO
338!$OMP END DO
339C
340 CALL my_barrier
341C
342 DO it=0,nthread-1
343 DO n=nodft,nodlt
344 iaw=n+it*numnod
345 a(1,n)=a(1,n)+awork(1,iaw)
346 a(2,n)=a(2,n)+awork(2,iaw)
347 a(3,n)=a(3,n)+awork(3,iaw)
348 stifn(n)=stifn(n)+awork(4,iaw)
349 END DO
350 END DO
351C
352 CALL my_barrier
353C
354 IF(itask==0) DEALLOCATE(awork)
355 ELSE ! IPARIT==0
356C-----------------------------------------------
357 niftsk = 1+itask*nisky/ nthread
358 niltsk = (itask+1)*nisky/nthread
359C
360 CALL my_barrier
361C
362 DO nisk=niftsk,niltsk
363 inod=isky(nisk)
364 np =nod2sp(inod)
365 IF(np/=0)THEN
366 n=sph2sol(np)
367 IF(n/=0)THEN
368#include "lockon.inc"
369 niskyl = nisky
370 nisky = nisky + 8
371#include "lockoff.inc"
372 IF (niskyl+8 > lskyi) THEN
373 CALL ancmsg(msgid=243,anmode=aninfo_blind)
374 CALL arret(2)
375 ENDIF
376C
377 IF (sol2sph_typ(sph2sol(np))==4) THEN
378C---------------
379C------ Tetra --
380C---------------
381 nsol=sph2sol(n)
382C
383 n1=ixs(2,nsol)
384 n2=ixs(4,nsol)
385 n3=ixs(7,nsol)
386 n4=ixs(6,nsol)
387C
388 ir=irst(1,n-first_sphsol+1)
389 is=irst(2,n-first_sphsol+1)
390 it=irst(3,n-first_sphsol+1)
391 nsphdir=igeo(37,ixs(10,nsol))
392C
393 ksi = a_gauss_tetra(ir,nsphdir)
394 eta = a_gauss_tetra(is,nsphdir)
395 zeta = a_gauss_tetra(it,nsphdir)
396C
397 phi1=ksi
398 phi2=eta
399 phi3=zeta
400 phi4=1-ksi-eta-zeta
401C
402 niskyl=niskyl+1
403 isky(niskyl)=n1
404 DO j=1,nfskyi
405 fskyi(niskyl,j)=phi1*fskyi(nisk,j)
406 END DO
407 niskyl=niskyl+1
408 isky(niskyl)=n2
409 DO j=1,nfskyi
410 fskyi(niskyl,j)=phi2*fskyi(nisk,j)
411 END DO
412 niskyl=niskyl+1
413 isky(niskyl)=n3
414 DO j=1,nfskyi
415 fskyi(niskyl,j)=phi3*fskyi(nisk,j)
416 END DO
417 niskyl=niskyl+1
418 isky(niskyl)=n4
419 DO j=1,nfskyi
420 fskyi(niskyl,j)=phi4*fskyi(nisk,j)
421 END DO
422C
423 ELSE
424C---------------
425C------ Hexa --
426C---------------
427 n1=ixs(2,n)
428 n2=ixs(3,n)
429 n3=ixs(4,n)
430 n4=ixs(5,n)
431 n5=ixs(6,n)
432 n6=ixs(7,n)
433 n7=ixs(8,n)
434 n8=ixs(9,n)
435C
436 nsphdir=nint((sol2sph(2,n)-sol2sph(1,n))**third)
437C
438C-----------------------------------------------
439 ir=irst(1,np-first_sphsol+1)
440 is=irst(2,np-first_sphsol+1)
441 it=irst(3,np-first_sphsol+1)
442 ksi = a_gauss(ir,nsphdir)
443 eta = a_gauss(is,nsphdir)
444 zeta = a_gauss(it,nsphdir)
445C
446 phi1=one_over_8*(one-ksi)*(one-eta)*(one-zeta)
447 phi2=one_over_8*(one-ksi)*(one-eta)*(one+zeta)
448 phi3=one_over_8*(one+ksi)*(one-eta)*(one+zeta)
449 phi4=one_over_8*(one+ksi)*(one-eta)*(one-zeta)
450 phi5=one_over_8*(one-ksi)*(one+eta)*(one-zeta)
451 phi6=one_over_8*(one-ksi)*(one+eta)*(one+zeta)
452 phi7=one_over_8*(one+ksi)*(one+eta)*(one+zeta)
453 phi8=one_over_8*(one+ksi)*(one+eta)*(one-zeta)
454C
455 niskyl=niskyl+1
456 isky(niskyl)=n1
457 DO j=1,nfskyi
458 fskyi(niskyl,j)=phi1*fskyi(nisk,j)
459 END DO
460 niskyl=niskyl+1
461 isky(niskyl)=n2
462 DO j=1,nfskyi
463 fskyi(niskyl,j)=phi2*fskyi(nisk,j)
464 END DO
465 niskyl=niskyl+1
466 isky(niskyl)=n3
467 DO j=1,nfskyi
468 fskyi(niskyl,j)=phi3*fskyi(nisk,j)
469 END DO
470 niskyl=niskyl+1
471 isky(niskyl)=n4
472 DO j=1,nfskyi
473 fskyi(niskyl,j)=phi4*fskyi(nisk,j)
474 END DO
475 niskyl=niskyl+1
476 isky(niskyl)=n5
477 DO j=1,nfskyi
478 fskyi(niskyl,j)=phi5*fskyi(nisk,j)
479 END DO
480 niskyl=niskyl+1
481 isky(niskyl)=n6
482 DO j=1,nfskyi
483 fskyi(niskyl,j)=phi6*fskyi(nisk,j)
484 END DO
485 niskyl=niskyl+1
486 isky(niskyl)=n7
487 DO j=1,nfskyi
488 fskyi(niskyl,j)=phi7*fskyi(nisk,j)
489 END DO
490 niskyl=niskyl+1
491 isky(niskyl)=n8
492 DO j=1,nfskyi
493 fskyi(niskyl,j)=phi8*fskyi(nisk,j)
494 END DO
495 DO j=1,nfskyi
496 fskyi(nisk,j)=zero
497 END DO
498C
499 ENDIF
500 END IF
501 END IF
502 END DO
503 END IF
504 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
startimeg
subroutine startimeg(ng)
Definition timer.F:1487
stoptimeg
subroutine stoptimeg(ng)
Definition timer.F:1535
min
#define min(a, b)
Definition macros.h:20
message_mod
Definition message_mod.F:1249
soltosph_mod
Definition soltosph_mod.F:32
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
arret
subroutine arret(nn)
Definition arret.F:87
my_barrier
subroutine my_barrier
Definition machine.F:31

◆ soltosphp()

subroutine soltosphp ( x,
spbuf,
integer, dimension(nixs,*) ixs,
integer, dimension(nisp,*) kxsp,
integer, dimension(*) ipartsp,
integer, dimension(3,*) irst,
type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer ngrounc,
integer, dimension(*) igrounc,
integer, dimension(2,*) sol2sph,
wa,
pm )

Definition at line 520 of file soltosph.F.

524C-----------------------------------------------
525 USE initbuf_mod
526 USE elbufdef_mod
527C-----------------------------------------------
528C I m p l i c i t T y p e s
529C-----------------------------------------------
530#include "implicit_f.inc"
531C-----------------------------------------------
532C G l o b a l P a r a m e t e r s
533C-----------------------------------------------
534#include "mvsiz_p.inc"
535C-----------------------------------------------
536C C o m m o n B l o c k s
537C-----------------------------------------------
538#include "com01_c.inc"
539#include "com08_c.inc"
540#include "param_c.inc"
541#include "sphcom.inc"
542#include "task_c.inc"
543#include "vect01_c.inc"
544C-----------------------------------------------
545C D u m m y A r g u m e n t s
546C-----------------------------------------------
547 INTEGER IXS(NIXS,*), KXSP(NISP,*),
548 . IPARTSP(*), IRST(3,*), IPARG(NPARG,*), NGROUNC,
549 . IGROUNC(*), SOL2SPH(2,*)
550 my_real
551 . x(3,*), spbuf(nspbuf,*), wa(kwasph,*),pm(npropm,*)
552 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
553C-----------------------------------------------
554C L o c a l V a r i a b l e s
555C-----------------------------------------------
556 INTEGER I, N, IP, KP, NG, MG, J, NP, KFT, IG, NELEM,
557 . NEL, OFFSET, MLW, IPLA,NELSP,K,IR,IS,IT,NSPHDIR,
558 . NPTR,NPTS,NPTT,II(6),JJ(6)
559 my_real
560 . rhon, rhoo, divv, sm,
561 . r11(mvsiz),r12(mvsiz),r13(mvsiz),
562 . r21(mvsiz),r22(mvsiz),r23(mvsiz),
563 . r31(mvsiz),r32(mvsiz),r33(mvsiz),
564 . t11(mvsiz),t12(mvsiz),t13(mvsiz),
565 . t21(mvsiz),t22(mvsiz),t23(mvsiz),
566 . t31(mvsiz),t32(mvsiz),t33(mvsiz),
567 . rx(mvsiz),sx(mvsiz),tx(mvsiz),
568 . ry(mvsiz),sy(mvsiz),ty(mvsiz),
569 . rz(mvsiz),sz(mvsiz),tz(mvsiz),
570 . g11,g22,g33,g12,g21,g23,g32,g13,g31,
571 . s11,s22,s33,s12,s21,s23,s32,s13,s31,
572 . l11,l22,l33,l12,l21,l23,l32,l13,l31,
573 . siglo(mvsiz,6), straglo(mvsiz,6), angl(mvsiz,6),
574 . dglo24(mvsiz,6),sig_heph(mvsiz,6,7),
575 . jr0(mvsiz),js0(mvsiz),jt0(mvsiz),nu(mvsiz),sig_heph_glo(mvsiz,6,7),
576 . rbid(6,mvsiz),zeta,eta,ksi,sig_ha8(mvsiz,3,3,3,6)
577C
578C-----
579 TYPE(G_BUFEL_) ,POINTER :: GBUF, GBUFSP
580 TYPE(L_BUFEL_) ,POINTER :: LBUF, LBUFSP, LBUF2
581 TYPE(BUF_MAT_) ,POINTER :: MBUF, MBUFSP
582C-----------------------------------------------
583 my_real a_gauss(9,9)
584 DATA a_gauss /
585 1 0. ,0. ,0. ,
586 1 0. ,0. ,0. ,
587 1 0. ,0. ,0. ,
588 2 -.577350269189626,0.577350269189626,0. ,
589 2 0. ,0. ,0. ,
590 2 0. ,0. ,0. ,
591 3 -.774596669241483,0. ,0.774596669241483,
592 3 0. ,0. ,0. ,
593 3 0. ,0. ,0. ,
594 4 -.861136311594053,-.339981043584856,0.339981043584856,
595 4 0.861136311594053,0. ,0. ,
596 4 0. ,0. ,0. ,
597 5 -.906179845938664,-.538469310105683,0. ,
598 5 0.538469310105683,0.906179845938664,0. ,
599 5 0. ,0. ,0. ,
600 6 -.932469514203152,-.661209386466265,-.238619186083197,
601 6 0.238619186083197,0.661209386466265,0.932469514203152,
602 6 0. ,0. ,0. ,
603 7 -.949107912342759,-.741531185599394,-.405845151377397,
604 7 0. ,0.405845151377397,0.741531185599394,
605 7 0.949107912342759,0. ,0. ,
606 8 -.960289856497536,-.796666477413627,-.525532409916329,
607 8 -.183434642495650,0.183434642495650,0.525532409916329,
608 8 0.796666477413627,0.960289856497536,0. ,
609 9 -.968160239507626,-.836031107326636,-.613371432700590,
610 9 -.324253423403809,0. ,0.324253423403809,
611 9 0.613371432700590,0.836031107326636,0.968160239507626/
612C-----------------------------------------------
613!$OMP DO SCHEDULE(DYNAMIC,1)
614 DO ig = 1, ngrounc
615 ng = igrounc(ig)
616 IF(iparg(8,ng)==1)GOTO 300
617 IF (iddw>0) CALL startimeg(ng)
618 offset = 0
619 ity = iparg(5,ng)
620 ipartsph= iparg(69,ng)
621 IF(ity==1.AND.ipartsph/=0) THEN
622C
623C---
624 CALL initbuf(iparg ,ng ,
625 2 mlw ,nel ,nft ,iad ,ity ,
626 3 npt ,jale ,ismstr ,jeul ,jtur ,
627 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
628 5 nvaux ,jpor ,jcvt ,jclose ,ipla ,
629 6 irep ,iint ,igtyp ,israt ,isrot ,
630 7 icsen ,isorth ,isorthg ,ifailure,jsms )
631 lft = 1
632 llt = min(nvsiz,nel)
633!
634 DO i=1,6
635 ii(i) = nel*(i-1)
636 ENDDO
637!
638C-----------
639 gbuf => elbuf_tab(ng)%GBUF
640 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
641 mbuf => elbuf_tab(ng)%BUFLY(1)%MAT(1,1,1)
642C-----------
643 CALL srep2glo(
644 1 x, ixs(1,nft+1),gbuf%GAMA, rx,
645 2 ry, rz, sx, sy,
646 3 sz, tx, ty, tz,
647 4 r11, r12, r13, r21,
648 5 r22, r23, r31, r32,
649 6 r33, t11, t12, t13,
650 7 t21, t22, t23, t31,
651 8 t32, t33, jr0, js0,
652 9 jt0, nel, lft, llt,
653 a jhbe, jcvt, isorth)
654C
655C----------- HEPH -------
656 IF (jhbe==24) THEN
657C------------------------
658 sig_heph(1:mvsiz,1:6,1:7) = zero
659 CALL sig_heph1(
660 1 jr0, js0, jt0, gbuf%SIG,
661 2 gbuf%HOURG,sig_heph, pm, ixs,
662 3 ii, nel, lft, llt)
663C
664 IF(isorth==0)THEN
665 DO j=1,7
666 DO i=lft,llt
667C hourglass stress in corotational system
668 l11 =sig_heph(i,1,j)
669 l22 =sig_heph(i,2,j)
670 l33 =sig_heph(i,3,j)
671 l12 =sig_heph(i,4,j)
672 l23 =sig_heph(i,5,j)
673 l13 =sig_heph(i,6,j)
674 s11 =l11*r11(i)+l12*r12(i)+l13*r13(i)
675 s12 =l11*r21(i)+l12*r22(i)+l13*r23(i)
676 s13 =l11*r31(i)+l12*r32(i)+l13*r33(i)
677 s21 =l12*r11(i)+l22*r12(i)+l23*r13(i)
678 s22 =l12*r21(i)+l22*r22(i)+l23*r23(i)
679 s23 =l12*r31(i)+l22*r32(i)+l23*r33(i)
680 s31 =l13*r11(i)+l23*r12(i)+l33*r13(i)
681 s32 =l13*r21(i)+l23*r22(i)+l33*r23(i)
682 s33 =l13*r31(i)+l23*r32(i)+l33*r33(i)
683 sig_heph_glo(i,1,j)=r11(i)*s11+r12(i)*s21+r13(i)*s31
684 sig_heph_glo(i,2,j)=r21(i)*s12+r22(i)*s22+r23(i)*s32
685 sig_heph_glo(i,3,j)=r31(i)*s13+r32(i)*s23+r33(i)*s33
686 sig_heph_glo(i,4,j)=r11(i)*s12+r12(i)*s22+r13(i)*s32
687 sig_heph_glo(i,5,j)=r21(i)*s13+r22(i)*s23+r23(i)*s33
688 sig_heph_glo(i,6,j)=r11(i)*s13+r12(i)*s23+r13(i)*s33
689 END DO
690 END DO
691 ELSE
692 DO j=1,7
693 DO i=lft,llt
694C hourglass stress in orthotropic system
695 l11 =sig_heph(i,1,j)
696 l22 =sig_heph(i,2,j)
697 l33 =sig_heph(i,3,j)
698 l12 =sig_heph(i,4,j)
699 l23 =sig_heph(i,5,j)
700 l13 =sig_heph(i,6,j)
701 s11 =l11*t11(i)+l12*t12(i)+l13*t13(i)
702 s12 =l11*t21(i)+l12*t22(i)+l13*t23(i)
703 s13 =l11*t31(i)+l12*t32(i)+l13*t33(i)
704 s21 =l12*t11(i)+l22*t12(i)+l23*t13(i)
705 s22 =l12*t21(i)+l22*t22(i)+l23*t23(i)
706 s23 =l12*t31(i)+l22*t32(i)+l23*t33(i)
707 s31 =l13*t11(i)+l23*t12(i)+l33*t13(i)
708 s32 =l13*t21(i)+l23*t22(i)+l33*t23(i)
709 s33 =l13*t31(i)+l23*t32(i)+l33*t33(i)
710 sig_heph_glo(i,1,j)=t11(i)*s11+t12(i)*s21+t13(i)*s31
711 sig_heph_glo(i,2,j)=t21(i)*s12+t22(i)*s22+t23(i)*s32
712 sig_heph_glo(i,3,j)=t31(i)*s13+t32(i)*s23+t33(i)*s33
713 sig_heph_glo(i,4,j)=t11(i)*s12+t12(i)*s22+t13(i)*s32
714 sig_heph_glo(i,5,j)=t21(i)*s13+t22(i)*s23+t23(i)*s33
715 sig_heph_glo(i,6,j)=t11(i)*s13+t12(i)*s23+t13(i)*s33
716 END DO
717 END DO
718 ENDIF
719C----------- HA8 -------
720 ELSEIF (jhbe==14) THEN
721C------------------------
722 nptr = elbuf_tab(ng)%NPTR
723 npts = elbuf_tab(ng)%NPTS
724 nptt = elbuf_tab(ng)%NPTT
725 IF(isorth==0)THEN
726 DO ir=1,nptr
727 DO is=1,npts
728 DO it=1,nptt
729C--------- convention HA8 : ETA-> r / ZETA -> s / KSI -> t
730C--------- convention SOL2SPH : KSI-> r / ETA -> s / ZETA -> t
731C--------- on permute KSI,ETA,ZETA
732 lbuf2 => elbuf_tab(ng)%BUFLY(1)%LBUF(it,ir,is)
733C---------
734 DO i=lft,llt
735C hourglass stress in corotational system
736 l11 =lbuf2%SIG(ii(1)+i)
737 l22 =lbuf2%SIG(ii(2)+i)
738 l33 =lbuf2%SIG(ii(3)+i)
739 l12 =lbuf2%SIG(ii(4)+i)
740 l23 =lbuf2%SIG(ii(5)+i)
741 l13 =lbuf2%SIG(ii(6)+i)
742 s11 =l11*r11(i)+l12*r12(i)+l13*r13(i)
743 s12 =l11*r21(i)+l12*r22(i)+l13*r23(i)
744 s13 =l11*r31(i)+l12*r32(i)+l13*r33(i)
745 s21 =l12*r11(i)+l22*r12(i)+l23*r13(i)
746 s22 =l12*r21(i)+l22*r22(i)+l23*r23(i)
747 s23 =l12*r31(i)+l22*r32(i)+l23*r33(i)
748 s31 =l13*r11(i)+l23*r12(i)+l33*r13(i)
749 s32 =l13*r21(i)+l23*r22(i)+l33*r23(i)
750 s33 =l13*r31(i)+l23*r32(i)+l33*r33(i)
751 sig_ha8(i,ir,is,it,1)=r11(i)*s11+r12(i)*s21+r13(i)*s31
752 sig_ha8(i,ir,is,it,2)=r21(i)*s12+r22(i)*s22+r23(i)*s32
753 sig_ha8(i,ir,is,it,3)=r31(i)*s13+r32(i)*s23+r33(i)*s33
754 sig_ha8(i,ir,is,it,4)=r11(i)*s12+r12(i)*s22+r13(i)*s32
755 sig_ha8(i,ir,is,it,5)=r21(i)*s13+r22(i)*s23+r23(i)*s33
756 sig_ha8(i,ir,is,it,6)=r11(i)*s13+r12(i)*s23+r13(i)*s33
757 END DO
758 END DO
759 END DO
760 END DO
761 ELSE
762 DO ir=1,nptr
763 DO is=1,npts
764 DO it=1,nptt
765 lbuf2 => elbuf_tab(ng)%BUFLY(1)%LBUF(ir,is,it)
766 DO i=lft,llt
767C hourglass stress in orthotropic system
768 l11 =lbuf2%SIG(ii(1)+i)
769 l22 =lbuf2%SIG(ii(2)+i)
770 l33 =lbuf2%SIG(ii(3)+i)
771 l12 =lbuf2%SIG(ii(4)+i)
772 l23 =lbuf2%SIG(ii(5)+i)
773 l13 =lbuf2%SIG(ii(6)+i)
774 s11 =l11*t11(i)+l12*t12(i)+l13*t13(i)
775 s12 =l11*t21(i)+l12*t22(i)+l13*t23(i)
776 s13 =l11*t31(i)+l12*t32(i)+l13*t33(i)
777 s21 =l12*t11(i)+l22*t12(i)+l23*t13(i)
778 s22 =l12*t21(i)+l22*t22(i)+l23*t23(i)
779 s23 =l12*t31(i)+l22*t32(i)+l23*t33(i)
780 s31 =l13*t11(i)+l23*t12(i)+l33*t13(i)
781 s32 =l13*t21(i)+l23*t22(i)+l33*t23(i)
782 s33 =l13*t31(i)+l23*t32(i)+l33*t33(i)
783 sig_ha8(i,ir,is,it,1)=t11(i)*s11+t12(i)*s21+t13(i)*s31
784 sig_ha8(i,ir,is,it,2)=t21(i)*s12+t22(i)*s22+t23(i)*s32
785 sig_ha8(i,ir,is,it,3)=t31(i)*s13+t32(i)*s23+t33(i)*s33
786 sig_ha8(i,ir,is,it,4)=t11(i)*s12+t12(i)*s22+t13(i)*s32
787 sig_ha8(i,ir,is,it,5)=t21(i)*s13+t22(i)*s23+t23(i)*s33
788 sig_ha8(i,ir,is,it,6)=t11(i)*s13+t12(i)*s23+t13(i)*s33
789 END DO
790 END DO
791 END DO
792 END DO
793 ENDIF
794C----------- Standard formulation -------
795 ELSEIF (jcvt == 0)THEN
796C------------------------------------------
797 DO i=lft,llt
798C mean stress in global system
799 siglo(i,1) =gbuf%SIG(ii(1)+i)
800 siglo(i,2) =gbuf%SIG(ii(2)+i)
801 siglo(i,3) =gbuf%SIG(ii(3)+i)
802 siglo(i,4) =gbuf%SIG(ii(4)+i)
803 siglo(i,5) =gbuf%SIG(ii(5)+i)
804 siglo(i,6) =gbuf%SIG(ii(6)+i)
805 END DO
806C----------- Corotational formulation -------
807 ELSE
808C--------------------------------------------
809C
810 IF (isorth== 0) THEN
811 DO i=lft,llt
812C mean stress in corotational system
813 l11 =gbuf%SIG(ii(1)+i)
814 l22 =gbuf%SIG(ii(2)+i)
815 l33 =gbuf%SIG(ii(3)+i)
816 l12 =gbuf%SIG(ii(4)+i)
817 l23 =gbuf%SIG(ii(5)+i)
818 l13 =gbuf%SIG(ii(6)+i)
819 s11 =l11*r11(i)+l12*r12(i)+l13*r13(i)
820 s12 =l11*r21(i)+l12*r22(i)+l13*r23(i)
821 s13 =l11*r31(i)+l12*r32(i)+l13*r33(i)
822 s21 =l12*r11(i)+l22*r12(i)+l23*r13(i)
823 s22 =l12*r21(i)+l22*r22(i)+l23*r23(i)
824 s23 =l12*r31(i)+l22*r32(i)+l23*r33(i)
825 s31 =l13*r11(i)+l23*r12(i)+l33*r13(i)
826 s32 =l13*r21(i)+l23*r22(i)+l33*r23(i)
827 s33 =l13*r31(i)+l23*r32(i)+l33*r33(i)
828 siglo(i,1)=r11(i)*s11+r12(i)*s21+r13(i)*s31
829 siglo(i,2)=r21(i)*s12+r22(i)*s22+r23(i)*s32
830 siglo(i,3)=r31(i)*s13+r32(i)*s23+r33(i)*s33
831 siglo(i,4)=r11(i)*s12+r12(i)*s22+r13(i)*s32
832 siglo(i,5)=r21(i)*s13+r22(i)*s23+r23(i)*s33
833 siglo(i,6)=r11(i)*s13+r12(i)*s23+r13(i)*s33
834 END DO
835 ELSE
836 DO i=lft,llt
837C mean stress in orthotropic system
838 l11 =gbuf%SIG(ii(1)+i)
839 l22 =gbuf%SIG(ii(2)+i)
840 l33 =gbuf%SIG(ii(3)+i)
841 l12 =gbuf%SIG(ii(4)+i)
842 l23 =gbuf%SIG(ii(5)+i)
843 l13 =gbuf%SIG(ii(6)+i)
844 s11 =l11*t11(i)+l12*t12(i)+l13*t13(i)
845 s12 =l11*t21(i)+l12*t22(i)+l13*t23(i)
846 s13 =l11*t31(i)+l12*t32(i)+l13*t33(i)
847 s21 =l12*t11(i)+l22*t12(i)+l23*t13(i)
848 s22 =l12*t21(i)+l22*t22(i)+l23*t23(i)
849 s23 =l12*t31(i)+l22*t32(i)+l23*t33(i)
850 s31 =l13*t11(i)+l23*t12(i)+l33*t13(i)
851 s32 =l13*t21(i)+l23*t22(i)+l33*t23(i)
852 s33 =l13*t31(i)+l23*t32(i)+l33*t33(i)
853 siglo(i,1)=t11(i)*s11+t12(i)*s21+t13(i)*s31
854 siglo(i,2)=t21(i)*s12+t22(i)*s22+t23(i)*s32
855 siglo(i,3)=t31(i)*s13+t32(i)*s23+t33(i)*s33
856 siglo(i,4)=t11(i)*s12+t12(i)*s22+t13(i)*s32
857 siglo(i,5)=t21(i)*s13+t22(i)*s23+t23(i)*s33
858 siglo(i,6)=t11(i)*s13+t12(i)*s23+t13(i)*s33
859 END DO
860 END IF
861C------------------------
862 ENDIF
863C-----------------------
864 IF(elbuf_tab(ng)%BUFLY(1)%L_STRA > 0)THEN
865 IF(jcvt == 0)THEN
866 DO i=lft,llt
867 straglo(i,1)=lbuf%STRA(ii(1)+i)
868 straglo(i,2)=lbuf%STRA(ii(2)+i)
869 straglo(i,3)=lbuf%STRA(ii(3)+i)
870 straglo(i,4)=lbuf%STRA(ii(4)+i)
871 straglo(i,5)=lbuf%STRA(ii(5)+i)
872 straglo(i,6)=lbuf%STRA(ii(6)+i)
873 END DO
874 ELSEIF(isorth==0)THEN
875 DO i=lft,llt
876C
877C strain in corotational system
878 l11 =lbuf%STRA(ii(1)+i)
879 l22 =lbuf%STRA(ii(2)+i)
880 l33 =lbuf%STRA(ii(3)+i)
881 l12 =half*lbuf%STRA(ii(4)+i)
882 l23 =half*lbuf%STRA(ii(5)+i)
883 l13 =half*lbuf%STRA(ii(6)+i)
884 s11 =l11*r11(i)+l12*r12(i)+l13*r13(i)
885 s12 =l11*r21(i)+l12*r22(i)+l13*r23(i)
886 s13 =l11*r31(i)+l12*r32(i)+l13*r33(i)
887 s21 =l12*r11(i)+l22*r12(i)+l23*r13(i)
888 s22 =l12*r21(i)+l22*r22(i)+l23*r23(i)
889 s23 =l12*r31(i)+l22*r32(i)+l23*r33(i)
890 s31 =l13*r11(i)+l23*r12(i)+l33*r13(i)
891 s32 =l13*r21(i)+l23*r22(i)+l33*r23(i)
892 s33 =l13*r31(i)+l23*r32(i)+l33*r33(i)
893 straglo(i,1)=r11(i)*s11+r12(i)*s21+r13(i)*s31
894 straglo(i,2)=r21(i)*s12+r22(i)*s22+r23(i)*s32
895 straglo(i,3)=r31(i)*s13+r32(i)*s23+r33(i)*s33
896 straglo(i,4)=two*(r11(i)*s12+r12(i)*s22+r13(i)*s32)
897 straglo(i,5)=two*(r21(i)*s13+r22(i)*s23+r23(i)*s33)
898 straglo(i,6)=two*(r11(i)*s13+r12(i)*s23+r13(i)*s33)
899 END DO
900 ELSE
901 DO i=lft,llt
902C
903C strain in orthotropic system
904 l11 =lbuf%STRA(ii(1)+i)
905 l22 =lbuf%STRA(ii(2)+i)
906 l33 =lbuf%STRA(ii(3)+i)
907 l12 =half*lbuf%STRA(ii(4)+i)
908 l23 =half*lbuf%STRA(ii(5)+i)
909 l13 =half*lbuf%STRA(ii(6)+i)
910 s11 =l11*t11(i)+l12*t12(i)+l13*t13(i)
911 s12 =l11*t21(i)+l12*t22(i)+l13*t23(i)
912 s13 =l11*t31(i)+l12*t32(i)+l13*t33(i)
913 s21 =l12*t11(i)+l22*t12(i)+l23*t13(i)
914 s22 =l12*t21(i)+l22*t22(i)+l23*t23(i)
915 s23 =l12*t31(i)+l22*t32(i)+l23*t33(i)
916 s31 =l13*t11(i)+l23*t12(i)+l33*t13(i)
917 s32 =l13*t21(i)+l23*t22(i)+l33*t23(i)
918 s33 =l13*t31(i)+l23*t32(i)+l33*t33(i)
919 straglo(i,1)=t11(i)*s11+t12(i)*s21+t13(i)*s31
920 straglo(i,2)=t21(i)*s12+t22(i)*s22+t23(i)*s32
921 straglo(i,3)=t31(i)*s13+t32(i)*s23+t33(i)*s33
922 straglo(i,4)=two*(t11(i)*s12+t12(i)*s22+t13(i)*s32)
923 straglo(i,5)=two*(t21(i)*s13+t22(i)*s23+t23(i)*s33)
924 straglo(i,6)=two*(t11(i)*s13+t12(i)*s23+t13(i)*s33)
925 END DO
926 END IF
927 END IF
928C-----------
929
930 IF(elbuf_tab(ng)%BUFLY(1)%L_ANG > 0)THEN
931 IF(jcvt == 0 .AND. isorth == 0)THEN
932 DO i=lft,llt
933 g11=lbuf%ANG(ii(1)+i)
934 g21=lbuf%ANG(ii(2)+i)
935 g31=lbuf%ANG(ii(3)+i)
936 g12=lbuf%ANG(ii(4)+i)
937 g22=lbuf%ANG(ii(5)+i)
938 g32=lbuf%ANG(ii(6)+i)
939 g13=g21*g32-g31*g22
940 g23=g31*g12-g11*g32
941 g33=g11*g22-g21*g12
942C MATRICE DE PASSAGE GLOBAL -> ANG
943 s11=rx(i)*g11+sx(i)*g21+tx(i)*g31
944 s12=rx(i)*g12+sx(i)*g22+tx(i)*g32
945 s13=rx(i)*g13+sx(i)*g23+tx(i)*g33
946 s21=ry(i)*g11+sy(i)*g21+ty(i)*g31
947 s22=ry(i)*g12+sy(i)*g22+ty(i)*g32
948 s23=ry(i)*g13+sy(i)*g23+ty(i)*g33
949 s31=rz(i)*g11+sz(i)*g21+tz(i)*g31
950 s32=rz(i)*g12+sz(i)*g22+tz(i)*g32
951 s33=rz(i)*g13+sz(i)*g23+tz(i)*g33
952 angl(i,1)=s11
953 angl(i,2)=s21
954 angl(i,3)=s31
955 angl(i,4)=s12
956 angl(i,5)=s22
957 angl(i,6)=s32
958 END DO
959 ELSEIF(jcvt /=0 .AND. isorth == 0)THEN
960 DO i=lft,llt
961 g11=lbuf%ANG(ii(1)+i)
962 g21=lbuf%ANG(ii(2)+i)
963 g31=lbuf%ANG(ii(3)+i)
964 g12=lbuf%ANG(ii(4)+i)
965 g22=lbuf%ANG(ii(5)+i)
966 g32=lbuf%ANG(ii(6)+i)
967 g13=g21*g32-g31*g22
968 g23=g31*g12-g11*g32
969 g33=g11*g22-g21*g12
970C MATRICE DE PASSAGE GLOBAL -> ANG
971 s11=r11(i)*g11+r12(i)*g21+r13(i)*g31
972 s12=r11(i)*g12+r12(i)*g22+r13(i)*g32
973 s13=r11(i)*g13+r12(i)*g23+r13(i)*g33
974 s21=r21(i)*g11+r22(i)*g21+r23(i)*g31
975 s22=r21(i)*g12+r22(i)*g22+r23(i)*g32
976 s23=r21(i)*g13+r22(i)*g23+r23(i)*g33
977 s31=r31(i)*g11+r32(i)*g21+r33(i)*g31
978 s32=r31(i)*g12+r32(i)*g22+r33(i)*g32
979 s33=r31(i)*g13+r32(i)*g23+r33(i)*g33
980 angl(i,1)=s11
981 angl(i,2)=s21
982 angl(i,3)=s31
983 angl(i,4)=s12
984 angl(i,5)=s22
985 angl(i,6)=s32
986 END DO
987 ELSE
988 DO i=lft,llt
989C
990C ISorth /=0 (ANG is given both for solid & sph wrt orthotropic system)
991C MATRICE DE PASSAGE ORTHOTROPE -> ANG
992 angl(i,1)=lbuf%ANG(ii(1)+i)
993 angl(i,2)=lbuf%ANG(ii(2)+i)
994 angl(i,3)=lbuf%ANG(ii(3)+i)
995 angl(i,4)=lbuf%ANG(ii(4)+i)
996 angl(i,5)=lbuf%ANG(ii(5)+i)
997 angl(i,6)=lbuf%ANG(ii(6)+i)
998 END DO
999 END IF
1000 END IF
1001C-----------
1002 IF(elbuf_tab(ng)%BUFLY(1)%L_DGLO > 0)THEN
1003
1004 IF(jcvt == 0 .AND. isorth == 0)THEN
1005 DO i=lft,llt
1006C TENSOR wrt ISOPARAMETRIC SYSTEM
1007 g11=lbuf%DGLO(ii(1)+i)
1008 g22=lbuf%DGLO(ii(2)+i)
1009 g33=lbuf%DGLO(ii(3)+i)
1010 g12=lbuf%DGLO(ii(4)+i)
1011 g23=lbuf%DGLO(ii(5)+i)
1012 g13=lbuf%DGLO(ii(6)+i)
1013 s11=g11*rx(i)+g12*sx(i)+g13*tx(i)
1014 s12=g11*ry(i)+g12*sy(i)+g13*ty(i)
1015 s13=g11*rz(i)+g12*sz(i)+g13*tz(i)
1016 s21=g12*rx(i)+g22*sx(i)+g23*tx(i)
1017 s22=g12*ry(i)+g22*sy(i)+g23*ty(i)
1018 s23=g12*rz(i)+g22*sz(i)+g23*tz(i)
1019 s31=g13*rx(i)+g23*sx(i)+g33*tx(i)
1020 s32=g13*ry(i)+g23*sy(i)+g33*ty(i)
1021 s33=g13*rz(i)+g23*sz(i)+g33*tz(i)
1022C TENSOR wrt GLOBAL SYSTEM
1023 dglo24(i,1)=rx(i)*s11+sx(i)*s21+tx(i)*s31
1024 dglo24(i,2)=ry(i)*s12+sy(i)*s22+ty(i)*s32
1025 dglo24(i,3)=rz(i)*s13+sz(i)*s23+tz(i)*s33
1026 dglo24(i,4)=rx(i)*s12+sx(i)*s22+tx(i)*s32
1027 dglo24(i,5)=ry(i)*s13+sy(i)*s23+ty(i)*s33
1028 dglo24(i,6)=rx(i)*s13+sx(i)*s23+tx(i)*s33
1029 END DO
1030 ELSEIF(jcvt /=0 .AND. isorth == 0)THEN
1031 DO i=lft,llt
1032C TENSOR wrt COROTATIONAL SYSTEM
1033 g11=lbuf%DGLO(ii(1)+i)
1034 g22=lbuf%DGLO(ii(2)+i)
1035 g33=lbuf%DGLO(ii(3)+i)
1036 g12=lbuf%DGLO(ii(4)+i)
1037 g23=lbuf%DGLO(ii(5)+i)
1038 g13=lbuf%DGLO(ii(6)+i)
1039 s11=g11*r11(i)+g12*r12(i)+g13*r13(i)
1040 s12=g11*r21(i)+g12*r22(i)+g13*r23(i)
1041 s13=g11*r31(i)+g12*r32(i)+g13*r33(i)
1042 s21=g12*r11(i)+g22*r12(i)+g23*r13(i)
1043 s22=g12*r21(i)+g22*r22(i)+g23*r23(i)
1044 s23=g12*r31(i)+g22*r32(i)+g23*r33(i)
1045 s31=g13*r11(i)+g23*r12(i)+g33*r13(i)
1046 s32=g13*r21(i)+g23*r22(i)+g33*r23(i)
1047 s33=g13*r31(i)+g23*r32(i)+g33*r33(i)
1048C TENSOR wrt GLOBAL SYSTEM
1049 dglo24(i,1)=r11(i)*s11+r12(i)*s21+r13(i)*s31
1050 dglo24(i,2)=r21(i)*s12+r22(i)*s22+r23(i)*s32
1051 dglo24(i,3)=r31(i)*s13+r32(i)*s23+r33(i)*s33
1052 dglo24(i,4)=r11(i)*s12+r12(i)*s22+r13(i)*s32
1053 dglo24(i,5)=r21(i)*s13+r22(i)*s23+r23(i)*s33
1054 dglo24(i,6)=r11(i)*s13+r12(i)*s23+r13(i)*s33
1055 END DO
1056 ELSE
1057C
1058C ISorth /=0 (orthotropic system is the same for solid & sph)
1059C TENSOR wrt ORTHOTROPIC SYSTEM
1060 DO i=lft,llt
1061 dglo24(i,1)=lbuf%DGLO(ii(1)+i)
1062 dglo24(i,2)=lbuf%DGLO(ii(2)+i)
1063 dglo24(i,3)=lbuf%DGLO(ii(3)+i)
1064 dglo24(i,4)=lbuf%DGLO(ii(4)+i)
1065 dglo24(i,5)=lbuf%DGLO(ii(5)+i)
1066 dglo24(i,6)=lbuf%DGLO(ii(6)+i)
1067 END DO
1068 END IF
1069 END IF
1070C-----------
1071 DO i=lft,llt
1072 IF(gbuf%OFF(i)==zero) cycle
1073 n=nft+i
1074C
1075C SOL2SPH(1,N)+1<=I<=SOLSPH(2,N) <=> N==SPH2SOL(I)
1076 nsphdir=nint((sol2sph(2,n)-sol2sph(1,n))**third)
1077 DO kp=1,sol2sph(2,n)-sol2sph(1,n)
1078C
1079 np=sol2sph(1,n)+kp
1080 mg =mod(-kxsp(2,np),ngroup+1)
1081 nelsp=iparg(2,mg)
1082 kft=iparg(3,mg)
1083 gbufsp => elbuf_tab(mg)%GBUF
1084 lbufsp => elbuf_tab(mg)%BUFLY(1)%LBUF(1,1,1)
1085 mbufsp => elbuf_tab(mg)%BUFLY(1)%MAT(1,1,1)
1086 j=np-kft
1087 rhon = gbuf%RHO(i)
1088 rhoo = wa(10,np)
1089 divv = (rhoo-rhon)/max(em30,rhoo*dt1)
1090 wa(13,np) = divv
1091 wa(14,np) = zero
1092 spbuf(2,np) = rhon
1093 gbufsp%RHO(j) = rhon
1094C
1095C group was not computed
1096C (there is no cloud active particle within the group)
1097C IF(IPARG(8,MG)==1)CYCLE
1098C
1099 gbufsp%EINT(j) =gbuf%EINT(i)
1100C
1101!
1102 DO k=1,6
1103 jj(k) = nelsp*(k-1)
1104 ENDDO
1105!
1106C-----------
1107 IF (jhbe==14) THEN
1108C HA8 stress
1109 ir=irst(1,np-first_sphsol+1)
1110 is=irst(2,np-first_sphsol+1)
1111 it=irst(3,np-first_sphsol+1)
1112 DO k=1,6
1113 gbufsp%SIG(jj(k)+j)=sig_ha8(i,ir,is,it,k)
1114 ENDDO
1115 ELSEIF (jhbe==24) THEN
1116C Hourglass stress contribution for HEPH
1117 ir=irst(1,np-first_sphsol+1)
1118 is=irst(2,np-first_sphsol+1)
1119 it=irst(3,np-first_sphsol+1)
1120C--- Permutation (KSI-> ETA;ETA->ZETA;ZETA->KSI) for consistencvy with HEPH convention
1121 eta = a_gauss(ir,nsphdir)
1122 zeta = a_gauss(is,nsphdir)
1123 ksi = a_gauss(it,nsphdir)
1124C-----------
1125 DO k=1,6
1126 gbufsp%SIG(jj(k)+j) = sig_heph_glo(i,k,1)
1127 . +zeta*sig_heph_glo(i,k,2)
1128 . +eta*sig_heph_glo(i,k,3)
1129 . +ksi*sig_heph_glo(i,k,4)
1130 . +zeta*eta*sig_heph_glo(i,k,5)
1131 . +zeta*ksi*sig_heph_glo(i,k,6)
1132 . +eta*ksi*sig_heph_glo(i,k,7)
1133 END DO
1134 ELSE
1135 gbufsp%SIG(jj(1)+j) = siglo(i,1)
1136 gbufsp%SIG(jj(2)+j) = siglo(i,2)
1137 gbufsp%SIG(jj(3)+j) = siglo(i,3)
1138 gbufsp%SIG(jj(4)+j) = siglo(i,4)
1139 gbufsp%SIG(jj(5)+j) = siglo(i,5)
1140 gbufsp%SIG(jj(6)+j) = siglo(i,6)
1141 ENDIF
1142C-----------
1143 wa(1,np)=gbufsp%SIG(jj(1)+j)
1144 wa(2,np)=gbufsp%SIG(jj(2)+j)
1145 wa(3,np)=gbufsp%SIG(jj(3)+j)
1146 wa(4,np)=gbufsp%SIG(jj(4)+j)
1147 wa(5,np)=gbufsp%SIG(jj(5)+j)
1148 wa(6,np)=gbufsp%SIG(jj(6)+j)
1149C
1150C (particles ARE computed with rho_old, Eold...)
1151C-----------
1152 IF(gbuf%G_PLA > 0) gbufsp%PLA(j) = gbuf%PLA(i)
1153 IF(gbuf%G_EPSD> 0) gbufsp%EPSD(j)= gbuf%EPSD(i)
1154 IF(gbuf%G_EPSQ> 0) gbufsp%EPSQ(j)= gbuf%EPSQ(i)
1155C-----------
1156 IF(gbuf%G_GAMA > 0)THEN
1157C
1158C TIJ stores global to orthotropic system
1159 gbufsp%GAMA(jj(1)+j)=t11(i)
1160 gbufsp%GAMA(jj(2)+j)=t21(i)
1161 gbufsp%GAMA(jj(3)+j)=t31(i)
1162 gbufsp%GAMA(jj(4)+j)=t12(i)
1163 gbufsp%GAMA(jj(5)+j)=t22(i)
1164 gbufsp%GAMA(jj(6)+j)=t32(i)
1165 END IF
1166C-----------
1167 IF(elbuf_tab(ng)%BUFLY(1)%L_STRA > 0.AND.
1168 . elbuf_tab(mg)%BUFLY(1)%L_STRA > 0)THEN
1169 lbufsp%STRA(jj(1)+j)=straglo(i,1)
1170 lbufsp%STRA(jj(2)+j)=straglo(i,2)
1171 lbufsp%STRA(jj(3)+j)=straglo(i,3)
1172 lbufsp%STRA(jj(4)+j)=straglo(i,4)
1173 lbufsp%STRA(jj(5)+j)=straglo(i,5)
1174 lbufsp%STRA(jj(6)+j)=straglo(i,6)
1175 END IF
1176C-----------
1177 IF(elbuf_tab(ng)%BUFLY(1)%L_ANG > 0)THEN
1178 lbufsp%ANG(jj(1)+j)=angl(i,1)
1179 lbufsp%ANG(jj(2)+j)=angl(i,2)
1180 lbufsp%ANG(jj(3)+j)=angl(i,3)
1181 lbufsp%ANG(jj(4)+j)=angl(i,4)
1182 lbufsp%ANG(jj(5)+j)=angl(i,5)
1183 lbufsp%ANG(jj(6)+j)=angl(i,6)
1184 END IF
1185C-----------
1186 IF(elbuf_tab(ng)%BUFLY(1)%L_SF > 0)THEN
1187 lbufsp%SF(jj(1)+j)=lbuf%SF(ii(1)+i)
1188 lbufsp%SF(jj(2)+j)=lbuf%SF(ii(2)+i)
1189 lbufsp%SF(jj(3)+j)=lbuf%SF(ii(3)+i)
1190 END IF
1191C-----------
1192 IF(elbuf_tab(ng)%BUFLY(1)%L_DAM > 0)THEN
1193 DO k=1,elbuf_tab(ng)%BUFLY(1)%L_DAM
1194 lbufsp%DAM(jj(k)+j)=lbuf%DAM(ii(k)+i)
1195 ENDDO
1196 END IF
1197C-----------
1198 IF(elbuf_tab(ng)%BUFLY(1)%L_DSUM > 0)
1199 . lbufsp%DSUM(j)=lbuf%DSUM(i)
1200C-----------
1201 IF(elbuf_tab(ng)%BUFLY(1)%L_DGLO > 0)THEN
1202 lbufsp%DGLO(jj(1)+j)=dglo24(i,1)
1203 lbufsp%DGLO(jj(2)+j)=dglo24(i,2)
1204 lbufsp%DGLO(jj(3)+j)=dglo24(i,3)
1205 lbufsp%DGLO(jj(4)+j)=dglo24(i,4)
1206 lbufsp%DGLO(jj(5)+j)=dglo24(i,5)
1207 lbufsp%DGLO(jj(6)+j)=dglo24(i,6)
1208 END IF
1209C-----------
1210 IF(elbuf_tab(ng)%BUFLY(1)%L_ROB > 0)
1211 . lbufsp%ROB(j)=lbuf%ROB(i)
1212C-----------
1213 IF(elbuf_tab(ng)%BUFLY(1)%L_SIGC > 0)THEN
1214C
1215C Law24 / Stress in crack frame (same for SPH and solids)
1216 lbufsp%SIGC(jj(1)+j)=lbuf%SIGC(ii(1)+i)
1217 lbufsp%SIGC(jj(2)+j)=lbuf%SIGC(ii(2)+i)
1218 lbufsp%SIGC(jj(3)+j)=lbuf%SIGC(ii(3)+i)
1219 lbufsp%SIGC(jj(4)+j)=lbuf%SIGC(ii(4)+i)
1220 lbufsp%SIGC(jj(5)+j)=lbuf%SIGC(ii(5)+i)
1221 lbufsp%SIGC(jj(6)+j)=lbuf%SIGC(ii(6)+i)
1222 END IF
1223C-----------
1224 IF(elbuf_tab(ng)%BUFLY(1)%L_CRAK > 0)THEN
1225 lbufsp%CRAK(jj(1)+j)=lbuf%CRAK(ii(1)+i)
1226 lbufsp%CRAK(jj(2)+j)=lbuf%CRAK(ii(2)+i)
1227 lbufsp%CRAK(jj(3)+j)=lbuf%CRAK(ii(3)+i)
1228 END IF
1229C-----------
1230 IF(elbuf_tab(ng)%BUFLY(1)%L_EPSA > 0)THEN
1231 lbufsp%EPSA(jj(1)+j)=lbuf%EPSA(ii(1)+i)
1232 lbufsp%EPSA(jj(2)+j)=lbuf%EPSA(ii(2)+i)
1233 lbufsp%EPSA(jj(3)+j)=lbuf%EPSA(ii(3)+i)
1234 END IF
1235C-----------
1236 IF(elbuf_tab(ng)%BUFLY(1)%L_SIGA > 0)THEN
1237 lbufsp%SIGA(jj(1)+j)=lbuf%SIGA(ii(1)+i)
1238 lbufsp%SIGA(jj(2)+j)=lbuf%SIGA(ii(2)+i)
1239 lbufsp%SIGA(jj(3)+j)=lbuf%SIGA(ii(3)+i)
1240 END IF
1241C-----------
1242C Stress in orthotropic skew for mulaw
1243 IF(elbuf_tab(ng)%BUFLY(1)%L_SIGL > 0)THEN
1244 lbufsp%SIGL(jj(1)+j)=lbuf%SIGL(ii(1)+i)
1245 lbufsp%SIGL(jj(2)+j)=lbuf%SIGL(ii(2)+i)
1246 lbufsp%SIGL(jj(3)+j)=lbuf%SIGL(ii(3)+i)
1247 lbufsp%SIGL(jj(4)+j)=lbuf%SIGL(ii(4)+i)
1248 lbufsp%SIGL(jj(5)+j)=lbuf%SIGL(ii(5)+i)
1249 lbufsp%SIGL(jj(6)+j)=lbuf%SIGL(ii(6)+i)
1250 END IF
1251C-----------
1252C User variables (same for SPH and solids)
1253 IF(elbuf_tab(ng)%BUFLY(1)%NVAR_MAT > 0)THEN
1254 DO k=1,elbuf_tab(ng)%BUFLY(1)%NVAR_MAT
1255 mbufsp%VAR(nelsp*(k-1)+j) = mbuf%VAR(nel*(k-1)+i)
1256 END DO
1257 ENDIF
1258C-----------
1259 ENDDO
1260 ENDDO
1261 END IF
1262 IF (iddw>0) CALL stoptimeg(ng)
1263C--------
1264 300 CONTINUE
1265 END DO
1266!$OMP END DO
1267C-----------------------------------------------
1268 RETURN
max
#define max(a, b)
Definition macros.h:21
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
sig_heph1
subroutine sig_heph1(jr0, js0, jt0, gsig, fhour, sig_heph, pm, ixs, ii, nel, lft, llt)
Definition soltosph_hour.F:38
srep2glo
subroutine srep2glo(x, ixs, gama, rx, ry, rz, sx, sy, sz, tx, ty, tz, r11, r12, r13, r21, r22, r23, r31, r32, r33, t11, t12, t13, t21, t22, t23, t31, t32, t33, jr0, js0, jt0, nel, lft, llt, jhbe, jcvt, isorth)
Definition srep2glo.F:43