OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_c_strsfg.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!|| stat_c_strsfg ../engine/source/output/sta/stat_c_strsfg.F
25!||--- called by ------------------------------------------------------
26!|| genstat ../engine/source/output/sta/genstat.F
27!||--- calls -----------------------------------------------------
28!|| get_q4lsys ../engine/source/output/sta/sta_c_get_q4lsys.F
29!|| get_t3lsys ../engine/source/output/sta/sta_c_get_t3lsys.F
30!|| layini ../engine/source/elements/shell/coque/layini.F
31!|| orth2loc ../engine/source/output/sta/stat_c_strsfg.F
32!|| shell2g ../engine/source/output/sta/stat_c_strafg.F
33!|| sheml2g ../engine/source/output/sta/stat_c_strsfg.F
34!|| spmd_rgather9_dp ../engine/source/mpi/interfaces/spmd_outp.F
35!|| spmd_stat_pgather ../engine/source/mpi/output/spmd_stat.F
36!|| strs_txt50 ../engine/source/output/sta/sta_txt.F
37!|| tab_strs_txt50 ../engine/source/output/sta/sta_txt.F
38!||--- uses -----------------------------------------------------
39!|| drape_mod ../engine/share/modules/drape_mod.F
40!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
41!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
42!|| stack_mod ../engine/share/modules/stack_mod.F
43!||====================================================================
44 SUBROUTINE stat_c_strsfg(ELBUF_TAB,
45 1 X ,IPARG ,IPM ,IGEO ,IXC ,
46 2 IXTG ,WA,WAP0 ,IPARTC, IPARTTG,
47 3 IPART_STATE,STAT_INDXC,STAT_INDXTG,THKE,SIZP0,
48 4 GEO ,STACK,DRAPE_SH4N,DRAPE_SH3N,DRAPEG)
49C-----------------------------------------------
50C M o d u l e s
51C-----------------------------------------------
52 USE elbufdef_mod
53 USE stack_mod
54 USE drape_mod
55 USE my_alloc_mod
56C-----------------------------------------------
57C I m p l i c i t T y p e s
58C-----------------------------------------------
59#include "implicit_f.inc"
60C-----------------------------------------------
61C C o m m o n B l o c k s
62C-----------------------------------------------
63#include "com01_c.inc"
64#include "com04_c.inc"
65#include "mvsiz_p.inc"
66#include "param_c.inc"
67#include "units_c.inc"
68#include "task_c.inc"
69#include "scr14_c.inc"
70#include "scr16_c.inc"
71C-----------------------------------------------
72C D u m m y A r g u m e n t s
73C-----------------------------------------------
74 INTEGER SIZLOC,SIZP0
75 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),
76 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
77 . IPARTC(*), IPARTTG(*), IPART_STATE(*),
78 . stat_indxc(*), stat_indxtg(*)
79 my_real
80 . thke(*),x(3,*),geo(*)
81 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
82 TYPE (STACK_PLY) :: STACK
83 TYPE (DRAPE_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
84 TYPE (DRAPEG_) :: DRAPEG
85 double precision WA(*),WAP0(*)
86C-----------------------------------------------
87C L o c a l V a r i a b l e s
88C-----------------------------------------------
89 INTEGER I,J,K,N,II,JJ,LEN,IOFF,IE,NG,NEL,NFT,LFT,NPT,
90 . LLT,ITY,MLW,IH,IHBE, ID, IPRT0, IPRT,IR,IS,IT,J1,J2,
91 . NPG,IPG,MPT,IPT,NPTR,NPTS,NPTT,NLAY,L_PLA,ITHK,NF3,
92 . IGTYP,NPT_ALL,IL,KK(12),NF1,IREL,IBID0,MAT_1,PID_1,ILAY,IDRAPE,
93 . sedrape,numel_drape
94 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
95 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
96 double precision
97 . THK, EM, EB, H1, H2, H3
98 my_real
99 . pg,mpg,qpg(2,4),thkq,
100 . sk(2),st(2),mk(2),mt(2),shk(2),sht(2),zz
101 CHARACTER*100 DELIMIT,LINE
102 TYPE(g_bufel_) ,POINTER :: GBUF
103 TYPE(L_BUFEL_) ,POINTER :: LBUF
104 TYPE(BUF_LAY_) ,POINTER :: BUFLY
105 INTEGER LAYNPT_MAX,NLAY_MAX,ISUBSTACK,IPT_ALL,JDIR,L_DIRA,L_DIRB,IREP,
106 . ilaw
107 my_real,
108 . DIMENSION(:),POINTER :: dir_a,dir_b
109 my_real
110 . qt(9,mvsiz),tens(6),zh,thkp ,thk0(mvsiz)
111
112 INTEGER, DIMENSION(:) , ALLOCATABLE :: MATLY
113 my_real, DIMENSION(:) , ALLOCATABLE :: thkly
114 my_real, DIMENSION(:,:) , ALLOCATABLE :: posly,thk_ly
115 my_real, ALLOCATABLE, DIMENSION(:) , TARGET :: dira,dirb
116C-----------------------------------------------
117 parameter(pg = .577350269189626)
118 parameter(mpg=-.577350269189626)
119 DATA qpg/mpg,mpg,pg,mpg,pg,pg,mpg,pg/
120 DATA delimit(1:60)
121 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
122 DATA delimit(61:100)
123 ./'----7----|----8----|----9----|----10---|'/
124!
125 CALL my_alloc(ptwa,max(stat_numelc ,stat_numeltg))
126 ALLOCATE(ptwa_p0(0:max(1,stat_numelc_g,stat_numeltg_g)))
127C=======================================================================
128C 4-NODE SHELLS
129C-----------------------------------------------
130 jj = 0
131 IF (stat_numelc==0) GOTO 200
132C
133 ie=0
134 DO ng=1,ngroup
135 ity = iparg(5,ng)
136 IF (ity == 3) THEN
137 gbuf => elbuf_tab(ng)%GBUF
138 mlw = iparg(1,ng)
139 nel = iparg(2,ng)
140 nft = iparg(3,ng)
141 mpt = iparg(6,ng)
142 ihbe = iparg(23,ng)
143 ithk = iparg(28,ng)
144 igtyp= iparg(38,ng)
145 irep = iparg(35,ng)
146 isubstack=iparg(71,ng)
147 idrape= iparg(92,ng)
148 nptr = elbuf_tab(ng)%NPTR
149 npts = elbuf_tab(ng)%NPTS
150 nptt = elbuf_tab(ng)%NPTT
151 nlay = elbuf_tab(ng)%NLAY
152 npg = nptr*npts
153 npt = nlay*nptt
154 IF (ihbe == 23) npg=4
155 lft=1
156 llt=nel
157 nf1 = nft+1
158 IF (ihbe>10.OR.igtyp==16.OR.ishfram ==0) THEN
159 irel=0
160 ELSEIF (ishfram ==1) THEN
161 irel=2
162 ELSE
163 irel=1
164 END IF
165!
166 DO i=1,12 ! length max of GBUF%G_HOURG = 12
167 kk(i) = nel*(i-1)
168 ENDDO
169!
170 ibid0 = 0
171 mat_1 = ixc(1,nf1)
172 pid_1 = ixc(6,nf1)
173 IF (ithk >0 ) THEN
174 thk0(lft:llt) = gbuf%THK(lft:llt)
175 ELSE
176 thk0(lft:llt) = thke(lft+nft:llt+nft)
177 END IF
178 ! Npt_max
179 laynpt_max = 1
180 IF(igtyp == 51 .OR. igtyp == 52) THEN
181 DO ilay=1, elbuf_tab(ng)%NLAY
182 laynpt_max = max(laynpt_max , elbuf_tab(ng)%BUFLY(ilay)%NPTT)
183 ENDDO
184 ENDIF
185 nlay_max = max(nlay,npt, elbuf_tab(ng)%NLAY)
186 ALLOCATE(matly(mvsiz*nlay_max), thkly(mvsiz*nlay_max*laynpt_max),
187 . posly(mvsiz,nlay_max*laynpt_max),thk_ly(nel,nlay_max*laynpt_max))
188 matly = 0
189 thkly = zero
190 posly = zero
191 thk_ly = zero
192 numel_drape = numelc_drape
193 sedrape = scdrape
194 CALL layini(elbuf_tab(ng),lft ,llt ,geo ,igeo ,
195 . mat_1 ,pid_1 ,thkly ,matly ,posly ,
196 . igtyp ,ibid0 ,ibid0 ,nlay ,mpt ,
197 . isubstack,stack ,drape_sh4n ,nft ,thke ,
198 . nel ,thk_ly ,drapeg%INDX_SH4N,sedrape,numel_drape)
199 l_dira = elbuf_tab(ng)%BUFLY(1)%LY_DIRA
200 l_dirb = elbuf_tab(ng)%BUFLY(1)%LY_DIRB
201 ALLOCATE(dira(nlay*nel*l_dira))
202 ALLOCATE(dirb(nlay*nel*l_dirb))
203 dira=zero
204 dirb=zero
205 IF (l_dira == 0) THEN
206 CONTINUE
207 ELSEIF (irep == 0) THEN
208 IF(idrape > 0 .AND. (igtyp == 51 .OR. igtyp == 52)) THEN
209 DO j=1,nlay
210 j1 = 1+(j-1)*l_dira*nel
211 j2 = j*l_dira*nel
212 dira(j1:j2) = elbuf_tab(ng)%BUFLY(j)%LBUF_DIR(1)%DIRA(1:nel*l_dira)
213 ENDDO
214 ELSE
215 DO j=1,nlay
216 j1 = 1+(j-1)*l_dira*nel
217 j2 = j*l_dira*nel
218 dira(j1:j2) = elbuf_tab(ng)%BUFLY(j)%DIRA(1:nel*l_dira)
219 ENDDO
220 ENDIF
221 ENDIF
222 dir_a => dira(1:nlay*nel*l_dira)
223 dir_b => dirb(1:nlay*nel*l_dirb)
224 CALL get_q4lsys(lft ,llt ,ixc(1,nf1),x ,gbuf%OFF,
225 . irel ,qt ,nlay ,irep ,nel ,
226 . dir_a ,dir_b,elbuf_tab(ng))
227C
228C pre counting of all NPTT (especially for PID_51)
229C
230 npt_all = 0
231 DO il=1,nlay
232 npt_all = npt_all + elbuf_tab(ng)%BUFLY(il)%NPTT
233 ENDDO
234 mpt = max(1,npt_all)
235 IF (iparg(6,ng) == 0) mpt=0
236C
237c------- loop over 4 node shell elements
238C
239 DO i=lft,llt
240 n = i + nft
241 iprt=ipartc(n)
242 IF (ipart_state(iprt)==0) cycle
243 jj = jj + 1
244 IF (mlw /= 0 .AND. mlw /= 13) THEN
245 wa(jj) = gbuf%OFF(i)
246 ELSE
247 wa(jj) = zero
248 ENDIF
249 jj = jj + 1
250 wa(jj) = iprt
251 jj = jj + 1
252 wa(jj) = ixc(nixc,n)
253 jj = jj + 1
254 wa(jj) = mpt
255 jj = jj + 1
256 wa(jj) = npg
257 jj = jj + 1
258 IF (mlw /= 0 .AND. mlw /= 13) THEN
259 wa(jj) = thk0(i)
260 thkq = wa(jj)
261 ELSE
262 wa(jj) = zero
263 thkq = gbuf%THK(i)
264 ENDIF
265 jj = jj + 1
266 IF (mlw /= 0 .AND. mlw /= 13) THEN
267 wa(jj) = gbuf%EINT(i)
268 ELSE
269 wa(jj) = zero
270 ENDIF
271 jj = jj + 1
272 IF (mlw /= 0 .AND. mlw /= 13) THEN
273 wa(jj) = gbuf%EINT(i+llt)
274 ELSE
275 wa(jj) = zero
276 ENDIF
277c ---- Hourglass
278 IF (ihbe==11 .or. ihbe==23 .or. mlw == 0 .or. mlw == 13) THEN
279 jj = jj + 1
280 wa(jj) = zero
281 jj = jj + 1
282 wa(jj) = zero
283 jj = jj + 1
284 wa(jj) = zero
285 ELSE ! not Batoz & not QEPH
286 jj = jj + 1
287 wa(jj) = gbuf%HOURG(kk(1)+i)
288 jj = jj + 1
289 wa(jj) = gbuf%HOURG(kk(2)+i)
290 jj = jj + 1
291 wa(jj) = gbuf%HOURG(kk(3)+i)
292 ENDIF
293c---------6 x2 +1(eps) for MPT=0
294 IF (ihbe /= 23) THEN
295 IF (mpt == 0) THEN ! global integration
296 IF (mlw == 0 .or. mlw == 13) THEN
297 DO ipg=1,npg
298 DO j=1,13 ! forces and moments
299 jj = jj + 1
300 wa(jj) = zero
301 ENDDO
302 ENDDO
303 ELSEIF (npg == 1) THEN
304 tens(1:5) = gbuf%FOR(kk(1:5)+i)
305 CALL shell2g(tens,qt(1,i))
306 DO j =1,6
307 jj = jj + 1
308 wa(jj) = tens(j)
309 END DO
310c
311 tens(1:3) = gbuf%MOM(kk(1:3)+i)
312 CALL sheml2g(tens,qt(1,i))
313 DO j =1,6
314 jj = jj + 1
315 wa(jj) = tens(j)
316 END DO
317c
318 jj = jj + 1
319 IF (gbuf%G_PLA > 0) THEN
320 wa(jj) = gbuf%PLA(i)
321 ELSE
322 wa(jj) = zero
323 ENDIF
324 ELSE ! NPG > 1
325 DO ir=1,nptr
326 DO is=1,npts
327 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(ir,is,1)
328 ipg = nptr*(is-1) + ir
329 k = (ipg-1)*nel*5
330C
331 tens(1:5) = gbuf%FORPG(k+kk(1:5)+i)
332 CALL shell2g(tens,qt(1,i))
333 DO j =1,6
334 jj = jj + 1
335 wa(jj) = tens(j)
336 END DO
337c
338 jj = jj + 1
339 IF (gbuf%G_PLA > 0) THEN
340 wa(jj) = lbuf%PLA(i)
341 ELSE
342 wa(jj) = zero
343 ENDIF
344c
345 k = (ipg-1)*nel*3
346 tens(1:3) = gbuf%MOMPG(k+kk(1:3)+i)
347 CALL sheml2g(tens,qt(1,i))
348 DO j =1,6
349 jj = jj + 1
350 wa(jj) = tens(j)
351 END DO
352 ENDDO
353 ENDDO
354 ENDIF ! IF (MLW == 0 .or. MLW == 13)
355C (MPT >0 ):
356 ELSEIF (mlw == 0 .or. mlw == 13) THEN
357 DO k=1,mpt
358 DO ipg=1,npg
359 DO j=1,8 ! Stress + plastic strain + T
360 jj = jj + 1
361 wa(jj) = zero
362 ENDDO
363 ENDDO
364 ENDDO
365 ELSE ! NLAY >= 1,
366 ipt_all = 0
367 DO il = 1,nlay
368 bufly => elbuf_tab(ng)%BUFLY(il)
369 ilaw = bufly%ILAW
370 nptt = bufly%NPTT
371 jdir = 1 + (il-1)*nel*2
372 ii = jdir + i-1
373 DO it=1,nptt
374 ipt = ipt_all + it
375 DO is=1,npts
376 DO ir=1,nptr
377 lbuf => bufly%LBUF(ir,is,it)
378 tens(1:5) = lbuf%SIG(kk(1:5)+i)
379 CALL orth2loc(tens,dir_a,dir_b,ii,ilaw,igtyp,nel)
380 CALL shell2g(tens,qt(1,i))
381 DO j =1,6
382 jj = jj + 1
383 wa(jj) = tens(j)
384 END DO
385 jj = jj + 1
386 IF (bufly%L_PLA > 0) THEN
387 wa(jj) = lbuf%PLA(i)
388 ELSE
389 wa(jj) = zero
390 ENDIF
391 jj = jj + 1
392 wa(jj) = posly(i,ipt)*two
393 ENDDO
394 ENDDO
395 ENDDO
396 ipt_all = ipt_all + nptt
397 ENDDO
398 ENDIF ! MPT, NLAY
399c---------
400 ELSE ! IHBE = 23 (QEPH)
401c---------
402 IF (mlw==0 .or. mlw==13) THEN
403 st(1) = zero
404 st(2) = zero
405 mt(1) = zero
406 mt(2) = zero
407 sk(1) = zero
408 sk(2) = zero
409 mk(1) = zero
410 mk(2) = zero
411 sht(1)= zero
412 sht(2)= zero
413 shk(1)= zero
414 shk(2)= zero
415 IF (mpt == 0) THEN
416 DO ipg=1,npg
417 DO j=1,13
418 jj = jj + 1
419 wa(jj) = zero
420 ENDDO
421 ENDDO
422 ELSE
423 DO ipg=1,npg
424 DO j=1,8
425 jj = jj + 1
426 wa(jj) = zero
427 ENDDO
428 ENDDO
429 ENDIF
430 ELSE ! MLW /= 0
431 st(1) = gbuf%HOURG(kk(1)+i)
432 st(2) =-gbuf%HOURG(kk(2)+i)
433 mt(1) = gbuf%HOURG(kk(3)+i)
434 mt(2) =-gbuf%HOURG(kk(4)+i)
435 sk(1) =-gbuf%HOURG(kk(7)+i)
436 sk(2) = gbuf%HOURG(kk(8)+i)
437 mk(1) =-gbuf%HOURG(kk(9)+i)
438 mk(2) = gbuf%HOURG(kk(10)+i)
439 sht(1)= gbuf%HOURG(kk(5)+i)
440 sht(2)=-gbuf%HOURG(kk(6)+i)
441 shk(1)=-gbuf%HOURG(kk(11)+i)
442 shk(2)= gbuf%HOURG(kk(12)+i)
443 ENDIF
444c
445 IF (mpt == 0 .and. mlw /= 0 .and. mlw /= 13) THEN
446 DO ipg=1,npg
447 tens(1:2) = gbuf%FOR(kk(1:2)+i)
448 . + st(1:2)*qpg(2,ipg)+sk(1:2)*qpg(1,ipg)
449 tens(3) = gbuf%FOR(kk(3)+i)
450 tens(4) = gbuf%FOR(kk(4)+i)
451 . + sht(2)*qpg(2,ipg)+shk(2)*qpg(1,ipg)
452 tens(5) = gbuf%FOR(kk(5)+i)
453 . + sht(1)*qpg(2,ipg)+shk(1)*qpg(1,ipg)
454 CALL shell2g(tens,qt(1,i))
455 DO j =1,6
456 jj = jj + 1
457 wa(jj) = tens(j)
458 END DO
459 tens(1:2) = gbuf%MOM(kk(1:2)+i)
460 . + mt(1:2)*qpg(2,ipg)+mk(1:2)*qpg(1,ipg)
461 tens(3) = gbuf%MOM(kk(3)+i)
462 CALL sheml2g(tens,qt(1,i))
463 DO j =1,6
464 jj = jj + 1
465 wa(jj) = tens(j)
466 END DO
467c
468 jj = jj + 1
469 IF (gbuf%G_PLA > 0) THEN
470 wa(jj) = gbuf%PLA(i)
471 ELSE
472 wa(jj) = zero
473 ENDIF
474 ENDDO
475 ELSEIF (mlw /= 0 .and. mlw /= 13) THEN ! NPT > 0
476 ipt_all = 0
477 DO il = 1,nlay
478 bufly => elbuf_tab(ng)%BUFLY(il)
479 ilaw = bufly%ILAW
480 nptt = bufly%NPTT
481 jdir = 1 + (il-1)*nel*2
482 ii = jdir + i-1
483 DO it=1,nptt
484 ipt = ipt_all + it
485 lbuf => bufly%LBUF(1,1,it)
486 l_pla = bufly%L_PLA
487 zz = posly(i,ipt)*thkq
488 DO ipg=1,npg
489 tens(1:2) = lbuf%SIG(kk(1:2)+i)
490 . + (st(1:2)+zz*mt(1:2))*qpg(2,ipg)
491 . + (sk(1:2)+zz*mk(1:2))*qpg(1,ipg)
492 tens(3) = lbuf%SIG(kk(3)+i)
493 tens(4) = lbuf%SIG(kk(4)+i)
494 . + sht(2)*qpg(2,ipg)+shk(2)*qpg(1,ipg)
495 tens(5) = lbuf%SIG(kk(5)+i)
496 . + sht(1)*qpg(2,ipg)+shk(1)*qpg(1,ipg)
497 CALL orth2loc(tens,dir_a,dir_b,ii,ilaw,igtyp,nel)
498 CALL shell2g(tens,qt(1,i))
499 DO j =1,6
500 jj = jj + 1
501 wa(jj) = tens(j)
502 END DO
503 jj = jj + 1
504 IF (l_pla > 0) THEN
505 wa(jj) = lbuf%PLA(i)
506 ELSE
507 wa(jj) = zero
508 ENDIF
509 jj = jj + 1
510 wa(jj) = posly(i,ipt)*two
511 ENDDO ! DO IPG=1,NPG
512 ENDDO ! DO IT=1,NPTT
513 ipt_all = ipt_all + nptt
514 ENDDO ! DO IL=1,NLAY
515 ENDIF ! IF (MPT == 0 .and. MLW /= 0 .and. MLW /= 13)
516 ENDIF
517C
518 ie=ie+1
519C pointeur de fin de zone dans WA
520 ptwa(ie)=jj
521 ENDDO ! DO I=LFT,LLT
522c------- end loop over 4 node shell elements
523 IF(ALLOCATED(dirb)) DEALLOCATE(dirb)
524 IF(ALLOCATED(dira)) DEALLOCATE(dira)
525 DEALLOCATE(matly, thkly, posly, thk_ly)
526 ENDIF ! ITY == 3
527 ENDDO ! NG = 1, NGROUP
528C
529 200 CONTINUE
530c-----------------------------------------------------------------------
531c 4N SHELLS - WRITE
532c-----------------------------------------------------------------------
533 IF (nspmd == 1) THEN
534 ptwa_p0(0)=0
535 DO n=1,stat_numelc
536 ptwa_p0(n)=ptwa(n)
537 ENDDO
538 len=jj
539 DO j=1,len
540 wap0(j)=wa(j)
541 ENDDO
542 ELSE
543C construit les pointeurs dans le tableau global WAP0
544 CALL spmd_stat_pgather(ptwa,stat_numelc,ptwa_p0,stat_numelc_g)
545 len = 0
546 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
547 ENDIF
548c-------------------------------------
549 IF (ispmd == 0.AND.len > 0) THEN
550 iprt0=0
551 DO n=1,stat_numelc_g
552C retrouve le nieme elt dans l'ordre d'id croissant
553 k=stat_indxc(n)
554C retrouve l'adresse dans WAP0
555 j=ptwa_p0(k-1)
556
557 ioff = nint(wap0(j + 1))
558 IF (ioff >= 1) THEN
559 iprt = nint(wap0(j + 2))
560 IF (iprt /= iprt0) THEN
561 IF (izipstrs == 0) THEN
562 WRITE(iugeo,'(A)') delimit
563 WRITE(iugeo,'(A)')'/INISHE/STRS_F/GLOB'
564 WRITE(iugeo,'(A)')
565 . '#------------------------ REPEAT --------------------------'
566 WRITE(iugeo,'(A)')
567 . '# SHELLID NPT NPG THK'
568 WRITE(iugeo,'(A)') '# EM, EB, H1, H2, H3'
569 WRITE(iugeo,'(A/A/A/A/A)')
570 . '# IF(NPT == 0), REPEAT I=1,NPG :',
571 . '# N1, N2, N3 ',
572 . '# N12, N23, N31',
573 . '# M1, M2, M3 ',
574 . '# M12,M23,M31,EPSP '
575 WRITE(iugeo,'(A/A/A)')
576 . '# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :',
577 . '# S1, S2, S3 ',
578 . '# S12, S23, S31, EPSP, T '
579 WRITE(iugeo,'(A)')
580 . '#---------------------- END REPEAT ------------------------'
581 WRITE(iugeo,'(A)') delimit
582 ELSE
583 WRITE(line,'(A)') delimit
584 CALL strs_txt50(line,100)
585 WRITE(line,'(A)')'/INISHE/STRS_F/GLOB'
586 CALL strs_txt50(line,100)
587 WRITE(line,'(A)')
588 . '#------------------------ REPEAT --------------------------'
589 CALL strs_txt50(line,100)
590 WRITE(line,'(A)')
591 . '# SHELLID NPT NPG THK'
592 CALL strs_txt50(line,100)
593 WRITE(line,'(A)') '# EM, EB, H1, H2, H3'
594 CALL strs_txt50(line,100)
595 WRITE(line,'(A)') '# IF(NPT == 0), REPEAT I=1,NPG :'
596 CALL strs_txt50(line,100)
597 WRITE(line,'(A)')'# N1, N2, N3 '
598 CALL strs_txt50(line,100)
599 WRITE(line,'(A)')'# N12, N23, N31'
600 CALL strs_txt50(line,100)
601 WRITE(line,'(A)')'# M1, M2, M3 '
602 CALL strs_txt50(line,100)
603 WRITE(line,'(A)')'# M12, M23, M31, EPSP'
604 CALL strs_txt50(line,100)
605 WRITE(line,'(A)')
606 . '# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :'
607 CALL strs_txt50(line,100)
608 WRITE(line,'(A)')'# S1, S2, S3'
609 CALL strs_txt50(line,100)
610 WRITE(line,'(A)')'# S12,S23,S31, EPSP, T '
611 CALL strs_txt50(line,100)
612 WRITE(line,'(A)')
613 . '#---------------------- END REPEAT ------------------------'
614 CALL strs_txt50(line,100)
615 WRITE(line,'(A)') delimit
616 CALL strs_txt50(line,100)
617 ENDIF
618 iprt0=iprt
619 ENDIF
620c
621 id = nint(wap0(j + 3))
622 npt = nint(wap0(j + 4))
623 npg = nint(wap0(j + 5))
624 thk = wap0(j + 6)
625 em = wap0(j + 7)
626 eb = wap0(j + 8)
627 h1 = wap0(j + 9)
628 h2 = wap0(j + 10)
629 h3 = wap0(j + 11)
630 j = j + 11
631 IF (izipstrs == 0) THEN
632 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
633 WRITE(iugeo,'(1P5E20.13)')em,eb,h1,h2,h3
634 ELSE
635 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
636 CALL strs_txt50(line,100)
637 WRITE(line,'(1P5E20.13)')em,eb,h1,h2,h3
638 CALL strs_txt50(line,100)
639 ENDIF
640 IF (npt == 0) THEN
641 DO ipg=1,npg
642 IF (izipstrs == 0) THEN
643 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,9)
644 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=10,13)
645 ELSE
646 CALL tab_strs_txt50(wap0(1),9,j,sizp0,3)
647 CALL tab_strs_txt50(wap0(10),4,j,sizp0,4)
648 ENDIF
649 ENDDO
650 ELSE
651 DO it=1,npt
652 DO ipg=1,npg
653 IF (izipstrs == 0) THEN
654 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
655 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=4,8)
656 ELSE
657 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
658 CALL tab_strs_txt50(wap0(4),5,j,sizp0,5)
659 ENDIF
660 j = j + 8
661 END DO
662 END DO
663 ENDIF ! IF (NPT == 0)
664 ENDIF ! IF (IOFF >= 1)
665 ENDDO ! DO N=1,STAT_NUMELC_G
666 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
667C-----------------------------------------------
668C 3-NODE SHELLS
669C-----------------------------------------------
670 jj = 0
671 IF (stat_numeltg==0) GOTO 300
672 ie=0
673C
674 DO ng=1,ngroup
675 ity = iparg(5,ng)
676 IF (ity == 7) THEN
677 gbuf => elbuf_tab(ng)%GBUF
678 mlw = iparg(1,ng)
679 nel = iparg(2,ng)
680 nft = iparg(3,ng)
681 mpt = iparg(6,ng)
682 ihbe = iparg(23,ng)
683 ithk = iparg(28,ng)
684 igtyp= iparg(38,ng)
685 irep = iparg(35,ng)
686 isubstack=iparg(71,ng)
687 nptr = elbuf_tab(ng)%NPTR
688 npts = elbuf_tab(ng)%NPTS
689 nptt = elbuf_tab(ng)%NPTT
690 nlay = elbuf_tab(ng)%NLAY
691 npg = nptr*npts
692 npt = nlay*nptt
693 lft=1
694 llt=nel
695 nf1 = nft+1
696 IF (ihbe>=30) THEN
697 irel=0
698 ELSE
699 irel=2
700 END IF
701!
702 DO i=1,5
703 kk(i) = nel*(i-1)
704 ENDDO
705 ibid0 = 0
706 mat_1 = ixtg(1,nf1)
707 pid_1 = ixtg(nixtg-1,nf1)
708 IF (ithk >0 ) THEN
709 thk0(lft:llt) = gbuf%THK(lft:llt)
710 ELSE
711 nf3 = nft+numelc
712 thk0(lft:llt) = thke(lft+nf3:llt+nf3)
713 END IF
714 ! Npt_max
715 laynpt_max = 1
716 IF(igtyp == 51 .OR. igtyp == 52) THEN
717 DO ilay=1, elbuf_tab(ng)%NLAY
718 laynpt_max = max(laynpt_max , elbuf_tab(ng)%BUFLY(ilay)%NPTT)
719 ENDDO
720 ENDIF
721 nlay_max = max(nlay,npt, elbuf_tab(ng)%NLAY)
722 ALLOCATE(matly(mvsiz*nlay_max), thkly(mvsiz*nlay_max*laynpt_max),
723 . posly(mvsiz,nlay_max*laynpt_max),thk_ly(nel,nlay_max*laynpt_max))
724 matly = 0
725 thkly = zero
726 posly = zero
727 thk_ly = zero
728 numel_drape = numeltg_drape
729 sedrape = stdrape
730 CALL layini(elbuf_tab(ng),lft ,llt ,geo ,igeo ,
731 . mat_1 ,pid_1 ,thkly ,matly ,posly ,
732 . igtyp ,ibid0 ,ibid0 ,nlay ,mpt ,
733 . isubstack,stack ,drape_sh3n ,nft ,thke ,
734 . nel ,thk_ly ,drapeg%INDX_SH3N, sedrape,numel_drape)
735!
736 l_dira = elbuf_tab(ng)%BUFLY(1)%LY_DIRA
737 l_dirb = elbuf_tab(ng)%BUFLY(1)%LY_DIRB
738 ALLOCATE(dira(nlay*nel*l_dira))
739 ALLOCATE(dirb(nlay*nel*l_dirb))
740 dira=zero
741 dirb=zero
742 IF (l_dira == 0) THEN
743 CONTINUE
744 ELSEIF (irep == 0) THEN
745 DO j=1,nlay
746 j1 = 1+(j-1)*l_dira*nel
747 j2 = j*l_dira*nel
748 dira(j1:j2) = elbuf_tab(ng)%BUFLY(j)%DIRA(1:nel*l_dira)
749 ENDDO
750 ENDIF
751 dir_a => dira(1:nlay*nel*l_dira)
752 dir_b => dirb(1:nlay*nel*l_dirb)
753 CALL get_t3lsys(lft ,llt ,ixtg(1,nf1),x ,gbuf%OFF,
754 . irel ,qt ,nlay ,irep ,nel ,
755 . dir_a ,dir_b,elbuf_tab(ng))
756C
757C pre counting of all NPTT (especially for PID_51)
758C
759 npt_all = 0
760 DO il=1,nlay
761 npt_all = npt_all + elbuf_tab(ng)%BUFLY(il)%NPTT
762 ENDDO
763 mpt = max(1,npt_all)
764 IF (iparg(6,ng) == 0) mpt=0
765C
766c------- loop over 3 node shell elements
767C
768 DO i=lft,llt
769 n = i + nft
770 iprt=iparttg(n)
771 IF (ipart_state(iprt) == 0) cycle
772 jj = jj + 1
773 IF (mlw /= 0 .AND. mlw /= 13) THEN
774 wa(jj) = gbuf%OFF(i)
775 ELSE
776 wa(jj) = zero
777 ENDIF
778 jj = jj + 1
779 wa(jj) = iprt
780 jj = jj + 1
781 wa(jj) = ixtg(nixtg,n)
782 jj = jj + 1
783 wa(jj) = mpt
784 jj = jj + 1
785 wa(jj) = npg
786 jj = jj + 1
787 IF (mlw /= 0 .AND. mlw /= 13) THEN
788 wa(jj) = thk0(i)
789 thkq = wa(jj)
790 ELSE
791 wa(jj) = zero
792 thkq = gbuf%THK(i)
793 ENDIF
794 jj = jj + 1
795 IF (mlw /= 0 .AND. mlw /= 13) THEN
796 wa(jj) = gbuf%EINT(i)
797 ELSE
798 wa(jj) = zero
799 ENDIF
800 jj = jj + 1
801 IF (mlw /= 0 .AND. mlw /= 13) THEN
802 wa(jj) = gbuf%EINT(i+llt)
803 ELSE
804 wa(jj) = zero
805 ENDIF
806 jj = jj + 1
807 wa(jj) = zero
808 jj = jj + 1
809 wa(jj) = zero
810 jj = jj + 1
811 wa(jj) = zero
812c----
813 IF (mpt == 0) THEN ! global integration
814 IF (mlw == 0 .or. mlw == 13) THEN
815 DO ipg=1,npg
816 DO j=1,13
817 jj = jj + 1
818 wa(jj) = zero
819 ENDDO
820 ENDDO
821 ELSEIF (npg == 1) THEN
822 tens(1:5) = gbuf%FOR(kk(1:5)+i)
823 CALL shell2g(tens,qt(1,i))
824 DO j =1,6
825 jj = jj + 1
826 wa(jj) = tens(j)
827 END DO
828c
829 tens(1:3) = gbuf%MOM(kk(1:3)+i)
830 CALL sheml2g(tens,qt(1,i))
831 DO j =1,6
832 jj = jj + 1
833 wa(jj) = tens(j)
834 END DO
835c
836 jj = jj + 1
837 IF (gbuf%G_PLA > 0) THEN
838 wa(jj) = gbuf%PLA(i)
839 ELSE
840 wa(jj) = zero
841 ENDIF
842 ELSE
843 DO ir=1,nptr
844 DO is=1,npts
845 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(ir,is,1)
846 ipg = nptr*(is-1) + ir
847 k = (ipg-1)*nel*5
848C
849 tens(1:5) = gbuf%FORPG(k+kk(1:5)+i)
850 CALL shell2g(tens,qt(1,i))
851 DO j =1,6
852 jj = jj + 1
853 wa(jj) = tens(j)
854 END DO
855c
856 jj = jj + 1
857 IF (gbuf%G_PLA > 0) THEN
858 wa(jj) = lbuf%PLA(i)
859 ELSE
860 wa(jj) = zero
861 ENDIF
862c
863 k = (ipg-1)*nel*3
864 tens(1:3) = gbuf%MOMPG(k+kk(1:3)+i)
865 CALL sheml2g(tens,qt(1,i))
866 DO j =1,6
867 jj = jj + 1
868 wa(jj) = tens(j)
869 END DO
870 ENDDO
871 ENDDO
872 ENDIF ! IF (MLW == 0 .or. MLW == 13)
873 ELSE ! MPT > 0
874 IF (mlw == 0 .or. mlw == 13) THEN
875 DO k=1,mpt
876 DO ipg=1,npg
877 DO j=1,8
878 jj = jj + 1
879 wa(jj) = zero
880 ENDDO
881 ENDDO
882 ENDDO
883 ELSE
884 ipt_all = 0
885 DO il = 1,nlay
886 bufly => elbuf_tab(ng)%BUFLY(il)
887 ilaw = bufly%ILAW
888 nptt = bufly%NPTT
889 jdir = 1 + (il-1)*nel*2
890 ii = jdir + i-1
891 DO it=1,nptt
892 ipt = ipt_all + it
893 DO ipg=1,npg
894 lbuf => bufly%LBUF(ipg,1,it)
895 tens(1:5) = lbuf%SIG(kk(1:5)+i)
896 CALL orth2loc(tens,dir_a,dir_b,ii,ilaw,igtyp,nel)
897 CALL shell2g(tens,qt(1,i))
898 DO j =1,6
899 jj = jj + 1
900 wa(jj) = tens(j)
901 END DO
902 jj = jj + 1
903 IF (bufly%L_PLA > 0) THEN
904 wa(jj) = lbuf%PLA(i)
905 ELSE
906 wa(jj) = zero
907 ENDIF
908 jj = jj + 1
909 wa(jj) = posly(i,ipt)*two
910 ENDDO !IPG=1,NPG
911 ENDDO
912 ipt_all = ipt_all + nptt
913 ENDDO
914 ENDIF ! IF (MLW == 0 .or. MLW == 13)
915 ENDIF ! IF (MPT == 0)
916C
917 ie=ie+1
918C pointeur de fin de zone
919 ptwa(ie)=jj
920 ENDDO ! DO I=LFT,LLT
921
922 IF(ALLOCATED(dirb)) DEALLOCATE(dirb)
923 IF(ALLOCATED(dira)) DEALLOCATE(dira)
924 DEALLOCATE(matly, thkly, posly, thk_ly)
925 ENDIF ! IF (ITY == 7)
926 ENDDO ! DO NG=1,NGROUP
927C
928 300 CONTINUE
929c-----------------------------------------------------------------------
930 IF (nspmd == 1) THEN
931 len=jj
932 DO j=1,len
933 wap0(j)=wa(j)
934 ENDDO
935 ptwa_p0(0)=0
936 DO n=1,stat_numeltg
937 ptwa_p0(n)=ptwa(n)
938 ENDDO
939 ELSE
940C construit les pointeurs dans le tableau global WAP0
941 CALL spmd_stat_pgather(ptwa,stat_numeltg,ptwa_p0,stat_numeltg_g)
942 len = 0
943 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
944 ENDIF
945
946 IF (ispmd == 0.AND.len > 0) THEN
947 iprt0=0
948 DO n=1,stat_numeltg_g
949C retrouve le nieme elt dans l'ordre d'id croissant
950 k=stat_indxtg(n)
951C retrouve l'adresse dans WAP0
952 j=ptwa_p0(k-1)
953C
954 ioff = nint(wap0(j + 1))
955 IF (ioff >= 1) THEN
956 iprt = nint(wap0(j + 2))
957 IF (iprt /= iprt0) THEN
958 IF (izipstrs == 0) THEN
959 WRITE(iugeo,'(A)') delimit
960 WRITE(iugeo,'(A)')'/INISH3/STRS_F/GLOB'
961 WRITE(iugeo,'(A)')
962 .'#------------------------ REPEAT --------------------------'
963 WRITE(iugeo,'(A)')
964 . '# SH3NID NPT NPG THK'
965 WRITE(iugeo,'(A)')
966 .'# EM, EB, H1, H2, H3'
967 WRITE(iugeo,'(A/A/A/A/A)')
968 .'# IF(NPT == 0), REPEAT I=1,NPG :',
969 .'# N1, N2, N3',
970 .'# N12,N23,N31',
971 .'# M1, M2, M3 ',
972 .'# M12,M23,M31,EPSP '
973 WRITE(iugeo,'(A/A/A)')
974 .'# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :',
975 .'# S1, S2, S3 ',
976 .'# S12,S23,S31, EPSP, T '
977 WRITE(iugeo,'(A)')
978 .'#---------------------- END REPEAT ------------------------'
979 WRITE(iugeo,'(A)') delimit
980 ELSE
981 WRITE(line,'(A)') delimit
982 CALL strs_txt50(line,100)
983 WRITE(line,'(A)')'/INISH3/STRS_F/GLOB'
984 CALL strs_txt50(line,100)
985 WRITE(line,'(A)')
986 .'#------------------------ REPEAT --------------------------'
987 CALL strs_txt50(line,100)
988 WRITE(line,'(A)')
989 . '# SH3NID NPT NPG THK'
990 CALL strs_txt50(line,100)
991 WRITE(line,'(a)')
992 .'# EM, EB, H1, H2, H3'
993 CALL strs_txt50(line,100)
994 WRITE(line,'(A)')
995 .'# IF(NPT == 0), REPEAT I=1,NPG :'
996 CALL strs_txt50(line,100)
997 WRITE(line,'(A)')'# N1, N2, N3'
998 CALL strs_txt50(line,100)
999 WRITE(line,'(A)')'# N12, N23, N31'
1000 CALL strs_txt50(line,100)
1001 WRITE(line,'(A)')'# M1, M2, M3 '
1002 CALL strs_txt50(line,100)
1003 WRITE(line,'(A)')'# M12, M23, M31,EPSP '
1004 CALL strs_txt50(line,100)
1005 WRITE(line,'(A)')
1006 .'# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :'
1007 CALL strs_txt50(line,100)
1008 WRITE(line,'(A)')'# S1, S2, S3 '
1009 CALL strs_txt50(line,100)
1010 WRITE(line,'(A)')'# S12, S23, S31, EPSP, T '
1011 CALL strs_txt50(line,100)
1012 WRITE(line,'(A)')
1013 .'#---------------------- END REPEAT ------------------------'
1014 CALL strs_txt50(line,100)
1015 WRITE(line,'(A)') delimit
1016 CALL strs_txt50(line,100)
1017 ENDIF ! IF (IZIPSTRS == 0)
1018 iprt0=iprt
1019 ENDIF ! IF (IPRT /= IPRT0)
1020 id = nint(wap0(j + 3))
1021 npt = nint(wap0(j + 4))
1022 npg = nint(wap0(j + 5))
1023 thk = wap0(j + 6)
1024 em = wap0(j + 7)
1025 eb = wap0(j + 8)
1026 h1 = wap0(j + 9)
1027 h2 = wap0(j + 10)
1028 h3 = wap0(j + 11)
1029 j = j + 11
1030 IF (izipstrs == 0) THEN
1031 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
1032 WRITE(iugeo,'(1P5E20.13)')em,eb,h1,h2,h3
1033 ELSE
1034 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
1035 CALL strs_txt50(line,100)
1036 WRITE(line,'(1P5E20.13)')em,eb,h1,h2,h3
1037 CALL strs_txt50(line,100)
1038 ENDIF
1039 IF (npt == 0) THEN
1040 DO ipg=1,npg
1041 IF (izipstrs == 0) THEN
1042 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,9)
1043 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=10,13)
1044 ELSE
1045 CALL tab_strs_txt50(wap0(1),9,j,sizp0,3)
1046 CALL tab_strs_txt50(wap0(10),4,j,sizp0,4)
1047 ENDIF
1048 ENDDO
1049 ELSE
1050 DO it=1,npt
1051 DO ipg=1,npg
1052 IF (izipstrs == 0) THEN
1053 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
1054 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=4,8)
1055 ELSE
1056 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
1057 CALL tab_strs_txt50(wap0(4),5,j,sizp0,5)
1058 ENDIF
1059 j = j + 8
1060 END DO
1061 END DO
1062 ENDIF ! IF (NPT == 0)
1063 ENDIF ! IF (IOFF >= 1)
1064 ENDDO ! DO N=1,STAT_NUMELTG_G
1065 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
1066
1067C
1068c----------
1069 DEALLOCATE(ptwa)
1070 DEALLOCATE(ptwa_p0)
1071c-----------
1072 RETURN
1073 END
1074c TENS(JFT:JLT,1) = SIGNXX(JFT:JLT)
1075c TENS(JFT:JLT,2) = SIGNYY(JFT:JLT)
1076c TENS(JFT:JLT,3) = SIGNXY(JFT:JLT)
1077c TENS(JFT:JLT,4) = SIGNYZ(JFT:JLT)
1078c TENS(JFT:JLT,5) = SIGNZX(JFT:JLT)
1079!||====================================================================
1080!|| orth2loc ../engine/source/output/sta/stat_c_strsfg.F
1081!||--- called by ------------------------------------------------------
1082!|| stat_c_strsfg ../engine/source/output/sta/stat_c_strsfg.F
1083!||--- calls -----------------------------------------------------
1084!|| urotovs ../engine/source/output/sta/stat_c_strsfg.F
1085!||====================================================================
1086 SUBROUTINE orth2loc(TENS,DIR_A,DIR_B,II,ILAW,IGTYP,NEL)
1087C-----------------------------------------------
1088C I m p l i c i t T y p e s
1089C-----------------------------------------------
1090#include "implicit_f.inc"
1091C-----------------------------------------------
1092C D u m m y A r g u m e n t s
1093C-----------------------------------------------
1094 INTEGER II,ILAW,IGTYP,NEL
1095 my_real
1096 . TENS(5), DIR_A(*),DIR_B(*)
1097C-----------------------------------------------
1098C L o c a l V a r i a b l e s
1099C-----------------------------------------------
1100 INTEGER J
1101 my_real
1102 . R1,R2,R3,S1,S2,S3,R12A,R22A,S12B,S22B,RS1,RS2,RS3,
1103 . T1,T2,T3,PHI,SUM1,SUM2,FACT,R3R3,S3S3
1104c------------------------------------------------
1105 IF (igtyp /= 1) THEN
1106c------------------------------------------------
1107 IF (igtyp == 16) THEN
1108c II = JDIR + I-1
1109 r1 = dir_a(ii)
1110 s1 = dir_a(ii+nel)
1111 r2 = dir_b(ii)
1112 s2 = dir_b(ii+nel)
1113
1114 rs1= r1*s1
1115 rs2= r2*s2
1116 r12a = r1*r1
1117 r22a = r2*r2
1118 s12b = s1*s1
1119 s22b = s2*s2
1120
1121 rs3 = s1*s2-r1*r2
1122 r3r3= one+s1*r2+r1*s2
1123 r3r3= half*r3r3
1124 s3s3= one-s1*r2-r1*s2
1125 s3s3= half*s3s3
1126 t1 = tens(1)
1127 t2 = tens(2)
1128 t3 = tens(3)
1129 tens(1) = r12a*t1 + r22a*t2 - rs3*t3
1130 tens(2) = s12b*t1 + s22b*t2 + rs3*t3
1131 tens(3) = rs1*t1 + rs2*t2 + (r3r3 - s3s3)*t3
1132c
1133 ELSEIF ((igtyp == 51 .OR. igtyp == 52) .AND. ilaw == 58) THEN
1134c II = JDIR + I-1
1135 r1 = dir_a(ii)
1136 s1 = dir_a(ii+nel)
1137 r2 = dir_b(ii)
1138 s2 = dir_b(ii+nel)
1139c
1140 rs1= r1*s1
1141 rs2= r2*s2
1142 r12a = r1*r1
1143 r22a = r2*r2
1144 s12b = s1*s1
1145 s22b = s2*s2
1146 rs3 = s1*s2-r1*r2
1147 r3r3= one+s1*r2+r1*s2
1148 r3r3= half*r3r3
1149 s3s3= one-s1*r2-r1*s2
1150 s3s3= half*s3s3
1151 t1 = tens(1)
1152 t2 = tens(2)
1153 t3 = tens(3)
1154c
1155 tens(1) = r12a*t1 + r22a*t2 - rs3*t3
1156 tens(2) = s12b*t1 + s22b*t2 + rs3*t3
1157 tens(3) = rs1*t1 + rs2*t2 + (r3r3 - s3s3)*t3
1158 ELSE
1159 IF (ilaw /= 1 .and. ilaw /= 2 .and. ilaw /= 19 .and. ilaw /= 27 .and. ilaw /= 32)
1160 . CALL urotovs(tens,dir_a(ii),dir_a(ii+nel))
1161 ENDIF
1162 ENDIF ! IGTYP
1163C
1164 RETURN
1165 END
1166!||====================================================================
1167!|| urotovs ../engine/source/output/sta/stat_c_strsfg.F
1168!||--- called by ------------------------------------------------------
1169!|| orth2loc ../engine/source/output/sta/stat_c_strsfg.F
1170!||====================================================================
1171 SUBROUTINE urotovs(SIG,DIR1,DIR2)
1172C-----------------------------------------------
1173C I m p l i c i t T y p e s
1174C-----------------------------------------------
1175#include "implicit_f.inc"
1176C-----------------------------------------------
1177C D u m m y A r g u m e n t s
1178C-----------------------------------------------
1179 my_real
1180 . sig(5), dir1,dir2
1181C-----------------------------------------------
1182C L o c a l V a r i a b l e s
1183C-----------------------------------------------
1184 INTEGER I
1185 my_real
1186 . S1, S2, S3, S4, S5
1187C-----------------------------------------------
1188 s1 = dir1*dir1*sig(1)
1189 . + dir2*dir2*sig(2)-two*dir1*dir2*sig(3)
1190 s2 = dir2*dir2*sig(1)
1191 . + dir1*dir1*sig(2)+two*dir2*dir1*sig(3)
1192 s3 = dir1*dir2*sig(1)
1193 . - dir2*dir1*sig(2)
1194 . +(dir1*dir1-dir2*dir2)*sig(3)
1195 s4 = dir2*sig(5)+dir1*sig(4)
1196 s5 = dir1*sig(5)-dir2*sig(4)
1197 sig(1)=s1
1198 sig(2)=s2
1199 sig(3)=s3
1200 sig(4)=s4
1201 sig(5)=s5
1202C
1203 RETURN
1204 END
1205!||====================================================================
1206!|| sheml2g ../engine/source/output/sta/stat_c_strsfg.F
1207!||--- called by ------------------------------------------------------
1208!|| stat_c_strsfg ../engine/source/output/sta/stat_c_strsfg.F
1209!||====================================================================
1210 SUBROUTINE sheml2g(MOM,QT)
1211C-----------------------------------------------
1212C I m p l i c i t T y p e s
1213C-----------------------------------------------
1214#include "implicit_f.inc"
1215C-----------------------------------------------
1216C D u m m y A r g u m e n t s
1217C-----------------------------------------------
1218 my_real
1219 . mom(6),qt(3,3)
1220C------------------------------------------------------
1221C L o c a l V a r i a b l e s
1222C-----------------------------------------------
1223 INTEGER I
1224 my_real
1225 . TXX,TYY,TZZ,TXY,TYZ,TZX,UXX,UYY,UZZ,UXY,UYZ,UZX,A,B,C
1226C--convention input MOM : mxx,myy,mxy,0,0,0; output mxx,myy,mzz,mxy,myz,mzx
1227 txx = mom(1)
1228 tyy = mom(2)
1229 tzz = zero
1230 txy = mom(3)
1231 tyz = zero
1232 tzx = zero
1233C
1234 a = qt(1,1)*txx + qt(2,1)*txy
1235 b = qt(1,1)*txy + qt(2,1)*tyy
1236c C = ZERO
1237 uxx = a*qt(1,1) + b*qt(1,2)
1238 uxy = a*qt(2,1) + b*qt(2,2)
1239 uzx = a*qt(3,1) + b*qt(3,2)
1240 a = qt(1,2)*txx + qt(2,2)*txy
1241 b = qt(1,2)*txy + qt(2,2)*tyy
1242c C = ZERO
1243 uyy = a*qt(2,1) + b*qt(2,2)
1244 uyz = a*qt(3,1) + b*qt(3,2)
1245 a = qt(1,3)*txx + qt(2,3)*txy
1246 b = qt(1,3)*txy + qt(2,3)*tyy
1247c C = ZERO
1248 uzz = a*qt(3,1) + b*qt(3,2)
1249C
1250 mom(1) = uxx
1251 mom(2) = uyy
1252 mom(3) = uzz
1253 mom(4) = uxy
1254 mom(5) = uyz
1255 mom(6) = uzx
1256C
1257 RETURN
1258 END
my_real
#define my_real
Definition cppsort.cpp:32
layini
subroutine layini(elbuf_str, jft, jlt, geo, igeo, mat, pid, thkly, matly, posly, igtyp, ixfem, ixlay, nlay, npt, isubstack, stack, drape, nft, thk, nel, ratio_thkly, indx_drape, sedrape, numel_drape)
Definition layini.F:47
max
#define max(a, b)
Definition macros.h:21
drape_mod
Definition drape_mod.F:54
drape_mod::scdrape
integer scdrape
Definition drape_mod.F:92
drape_mod::stdrape
integer stdrape
Definition drape_mod.F:92
stack_mod
Definition stack_mod.F:72
spmd_rgather9_dp
subroutine spmd_rgather9_dp(v, len, vp0, lenp0, iad)
Definition spmd_outp.F:1015
spmd_stat_pgather
subroutine spmd_stat_pgather(ptv, ptlen, ptv_p0, ptlen_p0)
Definition spmd_stat.F:53
get_q4lsys
subroutine get_q4lsys(jft, jlt, ixc, x, offg, irel, vq, nlay, irep, nel, dir_a, dir_b, elbuf_str)
Definition sta_c_get_q4lsys.F:36
get_t3lsys
subroutine get_t3lsys(jft, jlt, ixtg, x, offg, irel, vq, nlay, irep, nel, dir_a, dir_b, elbuf_str)
Definition sta_c_get_t3lsys.F:36
strs_txt50
subroutine strs_txt50(text, length)
Definition sta_txt.F:87
tab_strs_txt50
subroutine tab_strs_txt50(wap0, cpt, j, sizp0, nbpline)
Definition sta_txt.F:127
shell2g
subroutine shell2g(eps, qt)
Definition stat_c_strafg.F:891
sheml2g
subroutine sheml2g(mom, qt)
Definition stat_c_strsfg.F:1211
urotovs
subroutine urotovs(sig, dir1, dir2)
Definition stat_c_strsfg.F:1172
stat_c_strsfg
subroutine stat_c_strsfg(elbuf_tab, x, iparg, ipm, igeo, ixc, ixtg, wa, wap0, ipartc, iparttg, ipart_state, stat_indxc, stat_indxtg, thke, sizp0, geo, stack, drape_sh4n, drape_sh3n, drapeg)
Definition stat_c_strsfg.F:49
orth2loc
subroutine orth2loc(tens, dir_a, dir_b, ii, ilaw, igtyp, nel)
Definition stat_c_strsfg.F:1087