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