OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_c_strsf.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_strsf ../engine/source/output/sta/stat_c_strsf.F
25!||--- called by ------------------------------------------------------
26!|| genstat ../engine/source/output/sta/genstat.F
27!||--- calls -----------------------------------------------------
28!|| spmd_rgather9_dp ../engine/source/mpi/interfaces/spmd_outp.F
29!|| spmd_stat_pgather ../engine/source/mpi/output/spmd_stat.F
30!|| strs_txt50 ../engine/source/output/sta/sta_txt.F
31!|| tab_strs_txt50 ../engine/source/output/sta/sta_txt.F
32!||--- uses -----------------------------------------------------
33!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
34!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
35!||====================================================================
36 SUBROUTINE stat_c_strsf(
37 1 ELBUF_TAB ,IPARG ,IPM ,IGEO ,IXC ,
38 2 IXTG ,WA ,WAP0 ,IPARTC,IPARTTG,
39 3 IPART_STATE,STAT_INDXC,STAT_INDXTG,THKE ,SIZP0)
40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE elbufdef_mod
44 USE my_alloc_mod
45C-----------------------------------------------
46C I m p l i c i t T y p e s
47C-----------------------------------------------
48#include "implicit_f.inc"
49C-----------------------------------------------
50C C o m m o n B l o c k s
51C-----------------------------------------------
52#include "com01_c.inc"
53#include "com04_c.inc"
54#include "param_c.inc"
55#include "units_c.inc"
56#include "task_c.inc"
57#include "scr14_c.inc"
58#include "scr16_c.inc"
59C-----------------------------------------------
60C D u m m y A r g u m e n t s
61C-----------------------------------------------
62 INTEGER SIZLOC,SIZP0
63 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),
64 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
65 . ipartc(*), iparttg(*), ipart_state(*),
66 . stat_indxc(*), stat_indxtg(*)
67 my_real
68 . thke(*)
69 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
70 double precision WA(*),WAP0(*)
71C-----------------------------------------------
72C L o c a l V a r i a b l e s
73C-----------------------------------------------
74 INTEGER I,J,K,N,II,JJ,LEN,IOFF,IE,NG,NEL,NFT,LFT,NPT,
75 . LLT,ITY,MLW,IH,IHBE, ID, IPRT0, IPRT,IR,IS,IT,
76 . NPG,IPG,MPT,IPT,NPTR,NPTS,NPTT,NLAY,L_PLA,ITHK,
77 . igtyp,npt_all,il,kk(12)
78 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
79 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
80 double precision
81 . thk, em, eb, h1, h2, h3
82 my_real
83 . pg,mpg,qpg(2,4),thkq,
84 . sk(2),st(2),mk(2),mt(2),shk(2),sht(2),z01(11,11),zz
85 CHARACTER*100 DELIMIT,LINE
86 TYPE(G_BUFEL_) ,POINTER :: GBUF
87 TYPE(L_BUFEL_) ,POINTER :: LBUF
88 TYPE(buf_lay_) ,POINTER :: BUFLY
89C-----------------------------------------------
90 parameter(pg = .577350269189626)
91 parameter(mpg=-.577350269189626)
92 DATA qpg/mpg,mpg,pg,mpg,pg,pg,mpg,pg/
93 DATA z01/
94 1 0. ,0. ,0. ,0. ,0. ,
95 1 0. ,0. ,0. ,0. ,0. ,0. ,
96 2 -.5 ,0.5 ,0. ,0. ,0. ,
97 2 0. ,0. ,0. ,0. ,0. ,0. ,
98 3 -.5 ,0. ,0.5 ,0. ,0. ,
99 3 0. ,0. ,0. ,0. ,0. ,0. ,
100 4 -.5 ,-.1666667,0.1666667,0.5 ,0. ,
101 4 0. ,0. ,0. ,0. ,0. ,0. ,
102 5 -.5 ,-.25 ,0. ,0.25 ,0.5 ,
103 5 0. ,0. ,0. ,0. ,0. ,0. ,
104 6 -.5 ,-.3 ,-.1 ,0.1 ,0.3 ,
105 6 0.5 ,0. ,0. ,0. ,0. ,0. ,
106 7 -.5 ,-.3333333,-.1666667,0.0 ,0.1666667,
107 7 0.3333333,0.5 ,0. ,0. ,0. ,0. ,
108 8 -.5 ,-.3571429,-.2142857,-.0714286,0.0714286,
109 8 0.2142857,0.3571429,0.5 ,0. ,0. ,0. ,
110 9 -.5 ,-.375 ,-.25 ,-.125 ,0.0 ,
111 9 0.125 ,0.25 ,0.375 ,0.5 ,0. ,0. ,
112 a -.5 ,-.3888889,-.2777778,-.1666667,0.0555555,
113 a 0.0555555,0.1666667,0.2777778,0.3888889,0.5 ,0. ,
114 b -.5 ,-.4 ,-.3 ,-.2 ,-.1 ,
115 b 0. ,0.1 ,0.2 ,0.3 ,0.4 ,0.5 /
116 DATA delimit(1:60)
117 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
118 DATA delimit(61:100)
119 ./'----7----|----8----|----9----|----10---|'/
120C-----------------------------------------------
121 CALL my_alloc(ptwa,max(stat_numelc ,stat_numeltg))
122 ALLOCATE(ptwa_p0(0:max(1,stat_numelc_g,stat_numeltg_g)))
123C=======================================================================
124C 4-NODE SHELLS
125C-----------------------------------------------
126 jj = 0
127 IF (stat_numelc==0) GOTO 200
128C
129 ie=0
130 DO ng=1,ngroup
131 ity = iparg(5,ng)
132 IF (ity == 3) THEN
133 gbuf => elbuf_tab(ng)%GBUF
134 mlw = iparg(1,ng)
135 nel = iparg(2,ng)
136 nft = iparg(3,ng)
137 mpt = iparg(6,ng)
138 ihbe = iparg(23,ng)
139 ithk = iparg(28,ng)
140 igtyp= iparg(38,ng)
141 nptr = elbuf_tab(ng)%NPTR
142 npts = elbuf_tab(ng)%NPTS
143 nptt = elbuf_tab(ng)%NPTT
144 nlay = elbuf_tab(ng)%NLAY
145 npg = nptr*npts
146 npt = nlay*nptt
147 IF (ihbe == 23) npg=4
148 lft=1
149 llt=nel
150!
151 DO i=1,12 ! length max of GBUF%G_HOURG = 12
152 kk(i) = nel*(i-1)
153 ENDDO
154!
155C
156C pre counting of all NPTT (especially for PID_51)
157C
158 IF (igtyp == 51 .OR. igtyp == 52 ) THEN
159 npt_all = 0
160 DO il=1,nlay
161 npt_all = npt_all + elbuf_tab(ng)%BUFLY(il)%NPTT
162 ENDDO
163 mpt = max(1,npt_all)
164 ENDIF
165 IF (mlw == 1 .OR. mlw == 3 .OR. mlw == 23) mpt=0
166C
167c------- loop over 4 node shell elements
168C
169 DO i=lft,llt
170 n = i + nft
171 iprt=ipartc(n)
172 IF (ipart_state(iprt)==0) cycle
173 jj = jj + 1
174 IF (mlw /= 0 .AND. mlw /= 13) THEN
175 wa(jj) = gbuf%OFF(i)
176 ELSE
177 wa(jj) = zero
178 ENDIF
179 jj = jj + 1
180 wa(jj) = iprt
181 jj = jj + 1
182 wa(jj) = ixc(nixc,n)
183 jj = jj + 1
184 wa(jj) = mpt
185 jj = jj + 1
186 wa(jj) = npg
187 jj = jj + 1
188 IF (mlw /= 0 .AND. mlw /= 13) THEN
189 IF (ithk > 0) THEN
190 wa(jj) = gbuf%THK(i)
191 ELSE
192 wa(jj) = thke(n)
193 ENDIF
194 thkq = wa(jj)
195 ELSE
196 wa(jj) = zero
197 thkq = gbuf%THK(i)
198 ENDIF
199 jj = jj + 1
200 IF (mlw /= 0 .AND. mlw /= 13) THEN
201 wa(jj) = gbuf%EINT(i)
202 ELSE
203 wa(jj) = zero
204 ENDIF
205 jj = jj + 1
206 IF (mlw /= 0 .AND. mlw /= 13) THEN
207 wa(jj) = gbuf%EINT(i+llt)
208 ELSE
209 wa(jj) = zero
210 ENDIF
211c ---- Hourglass
212 IF (ihbe==11 .or. ihbe==23 .or. mlw == 0 .or. mlw == 13) THEN
213 jj = jj + 1
214 wa(jj) = zero
215 jj = jj + 1
216 wa(jj) = zero
217 jj = jj + 1
218 wa(jj) = zero
219 ELSE ! not Batoz & not QEPH
220 jj = jj + 1
221 wa(jj) = gbuf%HOURG(kk(1)+i)
222 jj = jj + 1
223 wa(jj) = gbuf%HOURG(kk(2)+i)
224 jj = jj + 1
225 wa(jj) = gbuf%HOURG(kk(3)+i)
226 ENDIF
227c---------
228 IF (ihbe /= 23) THEN
229 IF (mpt == 0) THEN ! global integration
230 IF (mlw == 0 .or. mlw == 13) THEN
231 DO ipg=1,npg
232 DO j=1,8 ! forces and moments
233 jj = jj + 1
234 wa(jj) = zero
235 ENDDO
236 ENDDO
237 ELSEIF (npg == 1) THEN
238 jj = jj + 1
239 wa(jj) = gbuf%FOR(kk(1)+i)
240 jj = jj + 1
241 wa(jj) = gbuf%FOR(kk(2)+i)
242 jj = jj + 1
243 wa(jj) = gbuf%FOR(kk(3)+i)
244 jj = jj + 1
245 wa(jj) = gbuf%FOR(kk(4)+i)
246 jj = jj + 1
247 wa(jj) = gbuf%FOR(kk(5)+i)
248c
249 jj = jj + 1
250 IF (gbuf%G_PLA > 0) THEN
251 wa(jj) = gbuf%PLA(i)
252 ELSE
253 wa(jj) = zero
254 ENDIF
255c
256 jj = jj + 1
257 wa(jj) = gbuf%MOM(kk(1)+i)
258 jj = jj + 1
259 wa(jj) = gbuf%MOM(kk(2)+i)
260 jj = jj + 1
261 wa(jj) = gbuf%MOM(kk(3)+i)
262 ELSE ! NPG > 1
263 DO ir=1,nptr
264 DO is=1,npts
265 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(ir,is,1)
266 ipg = nptr*(is-1) + ir
267 k = (ipg-1)*nel*5
268 jj = jj + 1
269 wa(jj) = gbuf%FORPG(k + kk(1) + i)
270 jj = jj + 1
271 wa(jj) = gbuf%FORPG(k + kk(2) + i)
272 jj = jj + 1
273 wa(jj) = gbuf%FORPG(k + kk(3) + i)
274 jj = jj + 1
275 wa(jj) = gbuf%FORPG(k + kk(4) + i)
276 jj = jj + 1
277 wa(jj) = gbuf%FORPG(k + kk(5) + i)
278c
279 jj = jj + 1
280 IF (gbuf%G_PLA > 0) THEN
281 wa(jj) = lbuf%PLA(i)
282 ELSE
283 wa(jj) = zero
284 ENDIF
285c
286 k = (ipg-1)*nel*3
287 jj = jj + 1
288 wa(jj) = gbuf%MOMPG(k + kk(1) + i)
289 jj = jj + 1
290 wa(jj) = gbuf%MOMPG(k + kk(2) + i)
291 jj = jj + 1
292 wa(jj) = gbuf%MOMPG(k + kk(3) + i)
293 ENDDO
294 ENDDO
295 ENDIF ! IF (MLW == 0 .or. MLW == 13)
296C (MPT /=0 ):
297 ELSEIF (mlw == 0 .or. mlw == 13) THEN
298 DO k=1,mpt
299 DO ipg=1,npg
300 DO j=1,6 ! Stress + plastic strain
301 jj = jj + 1
302 wa(jj) = zero
303 ENDDO
304 ENDDO
305 ENDDO
306 ELSEIF (nlay == 1) THEN ! PID1
307 bufly => elbuf_tab(ng)%BUFLY(1)
308 nptt = bufly%NPTT
309 DO it=1,nptt
310 DO is=1,npts
311 DO ir=1,nptr
312 lbuf => bufly%LBUF(ir,is,it)
313 ipg = nptr*(is-1) + ir
314 jj = jj + 1
315 wa(jj) = lbuf%SIG(kk(1)+i)
316 jj = jj + 1
317 wa(jj) = lbuf%SIG(kk(2)+i)
318 jj = jj + 1
319 wa(jj) = lbuf%SIG(kk(3)+i)
320 jj = jj + 1
321 wa(jj) = lbuf%SIG(kk(4)+i)
322 jj = jj + 1
323 wa(jj) = lbuf%SIG(kk(5)+i)
324 jj = jj + 1
325 IF (bufly%L_PLA > 0) THEN
326 wa(jj) = lbuf%PLA(i)
327 ELSE
328 wa(jj) = zero
329 ENDIF
330 ENDDO
331 ENDDO
332 ENDDO ! DO IPT = 1,NPTT
333 ELSE ! nlay > 1, pid10,pid11,pid16,pid17,pid51
334 ii = 5*(i-1)
335 DO il = 1,nlay
336 bufly => elbuf_tab(ng)%BUFLY(il)
337 nptt = bufly%NPTT
338 DO it=1,nptt
339 DO is=1,npts
340 DO ir=1,nptr
341 lbuf => bufly%LBUF(ir,is,it)
342 jj = jj + 1
343 wa(jj) = lbuf%SIG(kk(1)+i)
344 jj = jj + 1
345 wa(jj) = lbuf%SIG(kk(2)+i)
346 jj = jj + 1
347 wa(jj) = lbuf%SIG(kk(3)+i)
348 jj = jj + 1
349 wa(jj) = lbuf%SIG(kk(4)+i)
350 jj = jj + 1
351 wa(jj) = lbuf%SIG(kk(5)+i)
352 jj = jj + 1
353 IF (bufly%L_PLA > 0) THEN
354 wa(jj) = lbuf%PLA(i)
355 ELSE
356 wa(jj) = zero
357 ENDIF
358 ENDDO
359 ENDDO
360 ENDDO
361 ENDDO
362 ENDIF ! MPT, NLAY
363c---------
364 ELSE ! IHBE = 23 (QEPH)
365c---------
366 IF (mlw==0 .or. mlw==13) THEN
367 st(1) = zero
368 st(2) = zero
369 mt(1) = zero
370 mt(2) = zero
371 sk(1) = zero
372 sk(2) = zero
373 mk(1) = zero
374 mk(2) = zero
375 sht(1)= zero
376 sht(2)= zero
377 shk(1)= zero
378 shk(2)= zero
379 IF (mpt == 0) THEN
380 DO ipg=1,npg
381 DO j=1,8
382 jj = jj + 1
383 wa(jj) = zero
384 ENDDO
385 ENDDO
386 ELSE
387 DO ipg=1,npg
388 DO j=1,6
389 jj = jj + 1
390 wa(jj) = zero
391 ENDDO
392 ENDDO
393 ENDIF
394 ELSE ! MLW /= 0
395 st(1) = gbuf%HOURG(kk(1)+i)
396 st(2) =-gbuf%HOURG(kk(2)+i)
397 mt(1) = gbuf%HOURG(kk(3)+i)
398 mt(2) =-gbuf%HOURG(kk(4)+i)
399 sk(1) =-gbuf%HOURG(kk(7)+i)
400 sk(2) = gbuf%HOURG(kk(8)+i)
401 mk(1) =-gbuf%HOURG(kk(9)+i)
402 mk(2) = gbuf%HOURG(kk(10)+i)
403 sht(1)= gbuf%HOURG(kk(5)+i)
404 sht(2)=-gbuf%HOURG(kk(6)+i)
405 shk(1)=-gbuf%HOURG(kk(11)+i)
406 shk(2)= gbuf%HOURG(kk(12)+i)
407 ENDIF
408c
409 IF (mpt == 0 .and. mlw /= 0 .and. mlw /= 13) THEN
410 DO ipg=1,npg
411 jj = jj + 1
412 wa(jj) = gbuf%FOR(kk(1)+i)
413 . + st(1)*qpg(2,ipg) + sk(1)*qpg(1,ipg)
414 jj = jj + 1
415 wa(jj) = gbuf%FOR(kk(2)+i)
416 . + st(2)*qpg(2,ipg)+sk(2)*qpg(1,ipg)
417 jj = jj + 1
418 wa(jj) = gbuf%FOR(kk(3)+i)
419 jj = jj + 1
420 wa(jj) = gbuf%FOR(kk(4)+i)
421 . + sht(2)*qpg(2,ipg)+shk(2)*qpg(1,ipg)
422 jj = jj + 1
423 wa(jj) = gbuf%FOR(kk(5)+i)
424 . + sht(1)*qpg(2,ipg)+shk(1)*qpg(1,ipg)
425c
426 jj = jj + 1
427 wa(jj) = gbuf%MOM(kk(1)+i)
428 . + mt(1)*qpg(2,ipg)+mk(1)*qpg(1,ipg)
429 jj = jj + 1
430 wa(jj) = gbuf%MOM(kk(2)+i)
431 . + mt(2)*qpg(2,ipg)+mk(2)*qpg(1,ipg)
432 jj = jj + 1
433 wa(jj) = gbuf%MOM(kk(3)+i)
434 ENDDO
435 ELSEIF (mlw /= 0 .and. mlw /= 13) THEN ! NPT > 0
436 DO il=1,nlay
437 bufly =>elbuf_tab(ng)%BUFLY(il)
438 nptt = bufly%NPTT
439 DO it=1,nptt
440 lbuf => bufly%LBUF(1,1,it)
441 l_pla = bufly%L_PLA
442C
443 ipt = nptt*(il-1) + it
444 zz = gbuf%THK(i)*z01(ipt,max(nlay,npt))
445C
446 DO ipg=1,npg
447 jj = jj + 1
448 wa(jj) = lbuf%SIG(kk(1)+i)
449 . + (st(1)+zz*mt(1))*qpg(2,ipg)
450 . + (sk(1)+zz*mk(1))*qpg(1,ipg)
451C
452 jj = jj + 1
453 wa(jj) = lbuf%SIG(kk(2)+i)
454 . + (st(2)+zz*mt(2))*qpg(2,ipg)
455 . + (sk(2)+zz*mk(2))*qpg(1,ipg)
456C
457 jj = jj + 1
458 wa(jj) = lbuf%SIG(kk(3)+i)
459C
460 jj = jj + 1
461 wa(jj) = lbuf%SIG(kk(4)+i)
462 . + sht(2)*qpg(2,ipg) + shk(2)*qpg(1,ipg)
463C
464 jj = jj + 1
465 wa(jj) = lbuf%SIG(kk(5)+i)
466 . + sht(1)*qpg(2,ipg) + shk(1)*qpg(1,ipg)
467C
468 jj = jj + 1
469 IF (l_pla > 0) THEN
470 wa(jj) = lbuf%PLA(i)
471 ELSE
472 wa(jj) = zero
473 ENDIF
474 ENDDO ! DO IPG=1,NPG
475 ENDDO ! DO IT=1,NPTT
476 ENDDO ! DO IL=1,NLAY
477 ENDIF ! IF (MPT == 0 .and. MLW /= 0 .and. MLW /= 13)
478 ENDIF
479C
480 ie=ie+1
481C pointeur de fin de zone dans WA
482 ptwa(ie)=jj
483 ENDDO ! DO I=LFT,LLT
484c------- end loop over 4 node shell elements
485 ENDIF ! ITY == 3
486 ENDDO ! NG = 1, NGROUP
487C
488 200 CONTINUE
489c-----------------------------------------------------------------------
490c 4N SHELLS - WRITE
491c-----------------------------------------------------------------------
492 IF (nspmd == 1) THEN
493 ptwa_p0(0)=0
494 DO n=1,stat_numelc
495 ptwa_p0(n)=ptwa(n)
496 ENDDO
497 len=jj
498 DO j=1,len
499 wap0(j)=wa(j)
500 ENDDO
501 ELSE
502C construit les pointeurs dans le tableau global WAP0
503 CALL spmd_stat_pgather(ptwa,stat_numelc,ptwa_p0,stat_numelc_g)
504 len = 0
505 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
506 ENDIF
507c-------------------------------------
508 IF (ispmd == 0.AND.len > 0) THEN
509 iprt0=0
510 DO n=1,stat_numelc_g
511C retrouve le nieme elt dans l'ordre d'id croissant
512 k=stat_indxc(n)
513C retrouve l'adresse dans WAP0
514 j=ptwa_p0(k-1)
515
516 ioff = nint(wap0(j + 1))
517 IF (ioff >= 1) THEN
518 iprt = nint(wap0(j + 2))
519 IF (iprt /= iprt0) THEN
520 IF (izipstrs == 0) THEN
521 WRITE(iugeo,'(A)') delimit
522 WRITE(iugeo,'(A)')'/INISHE/STRS_F'
523 WRITE(iugeo,'(A)')
524 . '#------------------------ REPEAT --------------------------'
525 WRITE(iugeo,'(A)')
526 . '# SHELLID NPT NPG THK'
527 WRITE(iugeo,'(A)') '# EM, EB, H1, H2, H3'
528 WRITE(iugeo,'(A/A/A)')
529 . '# IF(NPT == 0), REPEAT I=1,NPG :',
530 . '# N1, N2, N12, N23, N31',
531 . '# EPSP, M1, M2, M12'
532 WRITE(iugeo,'(A/A/A)')
533 . '# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :',
534 . '# S1, S2, S12',
535 . '# S23, S31, EPSP'
536 WRITE(iugeo,'(A)')
537 . '#---------------------- END REPEAT ------------------------'
538 WRITE(iugeo,'(A)') delimit
539 ELSE
540 WRITE(line,'(A)') delimit
541 CALL strs_txt50(line,100)
542 WRITE(line,'(A)')'/INISHE/STRS_F'
543 CALL strs_txt50(line,100)
544 WRITE(line,'(A)')
545 . '#------------------------ REPEAT --------------------------'
546 CALL strs_txt50(line,100)
547 WRITE(line,'(A)')
548 . '# SHELLID NPT NPG THK'
549 CALL strs_txt50(line,100)
550 WRITE(line,'(A)') '# EM, EB, H1, H2, H3'
551 CALL strs_txt50(line,100)
552 WRITE(line,'(A)') '# IF(NPT == 0), REPEAT I=1,NPG :'
553 CALL strs_txt50(line,100)
554 WRITE(line,'(A)')'# N1, N2, N12, N23, N31'
555 CALL strs_txt50(line,100)
556 WRITE(line,'(A)')'# EPSP, M1, M2, M12'
557 CALL strs_txt50(line,100)
558 WRITE(line,'(A)')
559 . '# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :'
560 CALL strs_txt50(line,100)
561 WRITE(line,'(A)')'# S1, S2, S12'
562 CALL strs_txt50(line,100)
563 WRITE(line,'(A)')'# S23, S31, EPSP'
564 CALL strs_txt50(line,100)
565 WRITE(line,'(A)')
566 . '#---------------------- END REPEAT ------------------------'
567 CALL strs_txt50(line,100)
568 WRITE(line,'(a)') DELIMIT
569 CALL STRS_TXT50(LINE,100)
570 ENDIF
571 IPRT0=IPRT
572 ENDIF
573c
574 ID = NINT(WAP0(J + 3))
575 NPT = NINT(WAP0(J + 4))
576 NPG = NINT(WAP0(J + 5))
577 THK = WAP0(J + 6)
578 EM = WAP0(J + 7)
579 EB = WAP0(J + 8)
580 H1 = WAP0(J + 9)
581 H2 = WAP0(J + 10)
582 H3 = WAP0(J + 11)
583 J = J + 11
584 IF (IZIPSTRS == 0) THEN
585 WRITE(IUGEO,'(3i10,1pe20.13)')ID,NPT,NPG,THK
586 WRITE(IUGEO,'(1p5e20.13)')EM,EB,H1,H2,H3
587 ELSE
588 WRITE(LINE,'(3i10,1pe20.13)')ID,NPT,NPG,THK
589 CALL STRS_TXT50(LINE,100)
590 WRITE(LINE,'(1p5e20.13)')EM,EB,H1,H2,H3
591 CALL STRS_TXT50(LINE,100)
592 ENDIF
593 IF (NPT == 0) THEN
594 DO IPG=1,NPG
595 IF (IZIPSTRS == 0) THEN
596 WRITE(IUGEO,'(1p5e20.13)')(WAP0(J + K),K=1,5)
597 WRITE(IUGEO,'(1p4e20.13)')(WAP0(J + K),K=6,9)
598 ELSE
599 CALL TAB_STRS_TXT50(WAP0(1),5,J,SIZP0,5)
600 CALL TAB_STRS_TXT50(WAP0(6),4,J,SIZP0,4)
601 ENDIF
602 ENDDO
603 ELSE
604 IF (IZIPSTRS == 0) THEN
605 WRITE(IUGEO,'(1p3e20.13)')(WAP0(J + K),K=1,6*NPT*NPG)
606 ELSE
607 CALL TAB_STRS_TXT50(WAP0(1),6*NPT*NPG,J,SIZP0,3)
608 ENDIF
609 ENDIF ! IF (NPT == 0)
610 ENDIF ! IF (IOFF >= 1)
611 ENDDO ! DO N=1,STAT_NUMELC_G
612.AND. ENDIF ! IF (ISPMD == 0LEN > 0)
613C-----------------------------------------------
614C 3-NODE SHELLS
615C-----------------------------------------------
616 JJ = 0
617 IF (STAT_NUMELTG==0) GOTO 300
618 IE=0
619C
620 DO NG=1,NGROUP
621 ITY = IPARG(5,NG)
622 IF (ITY == 7) THEN
623 GBUF => ELBUF_TAB(NG)%GBUF
624 MLW = IPARG(1,NG)
625 NEL = IPARG(2,NG)
626 NFT = IPARG(3,NG)
627 MPT = IPARG(6,NG)
628 IHBE = IPARG(23,NG)
629 ITHK = IPARG(28,NG)
630 IGTYP= IPARG(38,NG)
631 NPTR = ELBUF_TAB(NG)%NPTR
632 NPTS = ELBUF_TAB(NG)%NPTS
633 NPTT = ELBUF_TAB(NG)%NPTT
634 NLAY = ELBUF_TAB(NG)%NLAY
635 NPG = NPTR*NPTS
636 NPT = NLAY*NPTT
637 LFT=1
638 LLT=NEL
639!
640 DO I=1,5
641 KK(I) = NEL*(I-1)
642 ENDDO
643!
644C
645C pre counting of all NPTT (especially for PID_51)
646C
647.OR. IF (IGTYP == 51 IGTYP == 52) THEN
648 NPT_ALL = 0
649 DO K=1,NLAY
650 NPT_ALL = NPT_ALL + ELBUF_TAB(NG)%BUFLY(K)%NPTT
651 ENDDO
652 MPT = MAX(1,NPT_ALL)
653 ENDIF
654.OR..OR. IF (MLW == 1 MLW == 3 MLW == 23) MPT=0
655C
656c------- loop over 3 node shell elements
657C
658 DO I=LFT,LLT
659 N = I + NFT
660 IPRT=IPARTTG(N)
661 IF (IPART_STATE(IPRT) == 0) CYCLE
662 JJ = JJ + 1
663.AND. IF (MLW /= 0 MLW /= 13) THEN
664 WA(JJ) = GBUF%OFF(I)
665 ELSE
666 WA(JJ) = ZERO
667 ENDIF
668 JJ = JJ + 1
669 WA(JJ) = IPRT
670 JJ = JJ + 1
671 WA(JJ) = IXTG(NIXTG,N)
672 JJ = JJ + 1
673 WA(JJ) = MPT
674 JJ = JJ + 1
675 WA(JJ) = NPG
676 JJ = JJ + 1
677.AND. IF (MLW /= 0 MLW /= 13) THEN
678 IF (ITHK > 0) THEN
679 WA(JJ) = GBUF%THK(I)
680 ELSE
681 WA(JJ) = THKE(N+NUMELC)
682 ENDIF
683 ELSE
684 WA(JJ) = ZERO
685 ENDIF
686 JJ = JJ + 1
687.AND. IF (MLW /= 0 MLW /= 13) THEN
688 WA(JJ) = GBUF%EINT(I)
689 ELSE
690 WA(JJ) = ZERO
691 ENDIF
692 JJ = JJ + 1
693.AND. IF (MLW /= 0 MLW /= 13) THEN
694 WA(JJ) = GBUF%EINT(I+LLT)
695 ELSE
696 WA(JJ) = ZERO
697 ENDIF
698 JJ = JJ + 1
699 WA(JJ) = ZERO
700 JJ = JJ + 1
701 WA(JJ) = ZERO
702 JJ = JJ + 1
703 WA(JJ) = ZERO
704c----
705 IF (MPT == 0) THEN ! global integration
706.or. IF (MLW == 0 MLW == 13) THEN
707 DO IPG=1,NPG
708 DO J=1,9
709 JJ = JJ + 1
710 WA(JJ) = ZERO
711 ENDDO
712 ENDDO
713 ELSEIF (NPG == 1) THEN
714 JJ = JJ + 1
715 WA(JJ) = GBUF%FOR(KK(1) + I)
716 JJ = JJ + 1
717 WA(JJ) = GBUF%FOR(KK(2) + I)
718 JJ = JJ + 1
719 WA(JJ) = GBUF%FOR(KK(3) + I)
720 JJ = JJ + 1
721 WA(JJ) = GBUF%FOR(KK(4) + I)
722 JJ = JJ + 1
723 WA(JJ) = GBUF%FOR(KK(5) + I)
724c
725 JJ = JJ + 1
726 IF (GBUF%G_PLA > 0) THEN
727 WA(JJ) = GBUF%PLA(I)
728 ELSE
729 WA(JJ) = ZERO
730 ENDIF
731c
732 JJ = JJ + 1
733 WA(JJ) = GBUF%MOM(KK(1) + I)
734 JJ = JJ + 1
735 WA(JJ) = GBUF%MOM(KK(2) + I)
736 JJ = JJ + 1
737 WA(JJ) = GBUF%MOM(KK(3) + I)
738 ELSE
739 DO IPG=1,NPG
740 LBUF => ELBUF_TAB(NG)%BUFLY(1)%LBUF(IPG,1,1)
741 K = (IPG-1)*NEL*5
742 JJ = JJ + 1
743 WA(JJ) = GBUF%FORPG(K + KK(1) + I)
744 JJ = JJ + 1
745 WA(JJ) = GBUF%FORPG(K + KK(2) + I)
746 JJ = JJ + 1
747 WA(JJ) = GBUF%FORPG(K + KK(3) + I)
748 JJ = JJ + 1
749 WA(JJ) = GBUF%FORPG(K + KK(4) + I)
750 JJ = JJ + 1
751 WA(JJ) = GBUF%FORPG(K + KK(5) + I)
752c
753 JJ = JJ + 1
754 IF (GBUF%G_PLA > 0) THEN
755 WA(JJ) = LBUF%PLA(I)
756 ELSE
757 WA(JJ) = ZERO
758 ENDIF
759c
760 K = (IPG-1)*NEL*3
761 JJ = JJ + 1
762 WA(JJ) = GBUF%MOMPG(K + KK(1) + I)
763 JJ = JJ + 1
764 WA(JJ) = GBUF%MOMPG(K + KK(2) + I)
765 JJ = JJ + 1
766 WA(JJ) = GBUF%MOMPG(K + KK(3) + I)
767 ENDDO ! DO IPG=1,NPG
768.or. ENDIF ! IF (MLW == 0 MLW == 13)
769 ELSE ! MPT > 0
770.or. IF (MLW == 0 MLW == 13) THEN
771 DO IPG=1,NPG
772 DO J=1,6
773 JJ = JJ + 1
774 WA(JJ) = ZERO
775 ENDDO
776 ENDDO
777 ELSE
778 DO IL=1,NLAY
779 BUFLY => ELBUF_TAB(NG)%BUFLY(IL)
780 NPTT = BUFLY%NPTT
781 DO IT=1,NPTT
782 DO IPG=1,NPG
783 LBUF => BUFLY%LBUF(IPG,1,IT)
784 L_PLA = BUFLY%L_PLA
785 DO J=1,5
786 JJ = JJ + 1
787 WA(JJ) = LBUF%SIG(KK(J)+I)
788 ENDDO
789 JJ = JJ + 1
790 IF (L_PLA > 0) THEN
791 WA(JJ) = LBUF%PLA(I)
792 ELSE
793 WA(JJ) = ZERO
794 ENDIF
795 ENDDO ! DO IPG=1,NPG
796 ENDDO ! DO IT=1,NPTT
797 ENDDO ! DO IL=1,NLAY
798.or. ENDIF ! IF (MLW == 0 MLW == 13)
799 ENDIF ! IF (MPT == 0)
800C
801 IE=IE+1
802C pointeur de fin de zone
803 PTWA(IE)=JJ
804 ENDDO ! DO I=LFT,LLT
805 ENDIF ! IF (ITY == 7)
806 ENDDO ! DO NG=1,NGROUP
807C
808 300 CONTINUE
809c-----------------------------------------------------------------------
810 IF (NSPMD == 1) THEN
811 LEN=JJ
812 DO J=1,LEN
813 WAP0(J)=WA(J)
814 ENDDO
815 PTWA_P0(0)=0
816 DO N=1,STAT_NUMELTG
817 PTWA_P0(N)=PTWA(N)
818 ENDDO
819 ELSE
820C construit les pointeurs dans le tableau global WAP0
821 CALL SPMD_STAT_PGATHER(PTWA,STAT_NUMELTG,PTWA_P0,STAT_NUMELTG_G)
822 LEN = 0
823 CALL SPMD_RGATHER9_DP(WA,JJ,WAP0,SIZP0,LEN)
824 ENDIF
825
826.AND. IF (ISPMD == 0LEN > 0) THEN
827 IPRT0=0
828 DO N=1,STAT_NUMELTG_G
829C retrouve le nieme elt dans l'ordre d'id croissant
830 K=STAT_INDXTG(N)
831C retrouve l'adresse dans WAP0
832 J=PTWA_P0(K-1)
833C
834 IOFF = NINT(WAP0(J + 1))
835 IF (IOFF >= 1) THEN
836 IPRT = NINT(WAP0(J + 2))
837 IF (IPRT /= IPRT0) THEN
838 IF (IZIPSTRS == 0) THEN
839 WRITE(IUGEO,'(a)') DELIMIT
840 WRITE(IUGEO,'(a)')'/inish3/strs_f'
841 WRITE(IUGEO,'(a)')
842 .'#------------------------ REPEAT --------------------------'
843 WRITE(iugeo,'(A)')
844 . '# SH3NID NPT NPG THK'
845 WRITE(iugeo,'(A)')
846 .'# EM, EB, H1, H2, H3'
847 WRITE(iugeo,'(A/A/A)')
848 .'# IF(NPT == 0), REPEAT I=1,NPG :',
849 .'# N1, N2, N12, N23, N31',
850 .'# EPSP, M1, M2, M12'
851 WRITE(iugeo,'(A/A/A)')
852 .'# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :',
853 .'# S1, S2, S12',
854 .'# S23, S31, EPSP'
855 WRITE(iugeo,'(A)')
856 .'#---------------------- END REPEAT ------------------------'
857 WRITE(iugeo,'(A)') delimit
858 ELSE
859 WRITE(line,'(A)') delimit
860 CALL strs_txt50(line,100)
861 WRITE(line,'(A)')'/INISH3/STRS_F'
862 CALL strs_txt50(line,100)
863 WRITE(line,'(A)')
864 .'#------------------------ REPEAT --------------------------'
865 CALL strs_txt50(line,100)
866 WRITE(line,'(A)')
867 . '# SH3NID NPT NPG THK'
868 CALL strs_txt50(line,100)
869 WRITE(line,'(A)')
870 .'# EM, EB, H1, H2, H3'
871 CALL strs_txt50(line,100)
872 WRITE(line,'(A)')
873 .'# IF(NPT == 0), REPEAT I=1,NPG :'
874 CALL strs_txt50(line,100)
875 WRITE(line,'(A)')'# N1, N2, N12, N23, N31'
876 CALL strs_txt50(line,100)
877 WRITE(line,'(A)')'# EPSP, M1, M2, M12'
878 CALL strs_txt50(line,100)
879 WRITE(line,'(A)')
880 .'# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :'
881 CALL strs_txt50(line,100)
882 WRITE(line,'(A)')'# S1, S2, S12'
883 CALL strs_txt50(line,100)
884 WRITE(line,'(A)')'# S23, S31, EPSP'
885 CALL strs_txt50(line,100)
886 WRITE(line,'(A)')
887 .'#---------------------- END REPEAT ------------------------'
888 CALL strs_txt50(line,100)
889 WRITE(line,'(A)') delimit
890 CALL strs_txt50(line,100)
891 ENDIF ! IF (IZIPSTRS == 0)
892 iprt0=iprt
893 ENDIF ! IF (IPRT /= IPRT0)
894 id = nint(wap0(j + 3))
895 npt = nint(wap0(j + 4))
896 npg = nint(wap0(j + 5))
897 thk = wap0(j + 6)
898 em = wap0(j + 7)
899 eb = wap0(j + 8)
900 h1 = wap0(j + 9)
901 h2 = wap0(j + 10)
902 h3 = wap0(j + 11)
903 j = j + 11
904 IF (izipstrs == 0) THEN
905 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
906 WRITE(iugeo,'(1P5E20.13)')em,eb,h1,h2,h3
907 ELSE
908 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
909 CALL strs_txt50(line,100)
910 WRITE(line,'(1P5E20.13)')em,eb,h1,h2,h3
911 CALL strs_txt50(line,100)
912 ENDIF
913 IF (npt == 0) THEN
914 DO ipg=1,npg
915 IF (izipstrs == 0) THEN
916 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=1,5)
917 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=6,9)
918 ELSE
919 CALL tab_strs_txt50(wap0(1),5,j,sizp0,5)
920 CALL tab_strs_txt50(wap0(6),4,j,sizp0,4)
921 ENDIF
922 ENDDO
923 ELSE
924 IF (izipstrs == 0) THEN
925 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,6*npt*npg)
926 ELSE
927 CALL tab_strs_txt50(wap0(1),6*npt*npg,j,sizp0,3)
928 ENDIF
929 ENDIF ! IF (NPT == 0)
930 ENDIF ! IF (IOFF >= 1)
931 ENDDO ! DO N=1,STAT_NUMELTG_G
932 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
933C
934c----------
935 DEALLOCATE(ptwa)
936 DEALLOCATE(ptwa_p0)
937c-----------
938 RETURN
939 END
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
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
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
stat_c_strsf
subroutine stat_c_strsf(elbuf_tab, iparg, ipm, igeo, ixc, ixtg, wa, wap0, ipartc, iparttg, ipart_state, stat_indxc, stat_indxtg, thke, sizp0)
Definition stat_c_strsf.F:40