OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_c_strsf.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine stat_c_strsf (elbuf_tab, iparg, ipm, igeo, ixc, ixtg, wa, wap0, ipartc, iparttg, ipart_state, stat_indxc, stat_indxtg, thke, sizp0)

Function/Subroutine Documentation

◆ stat_c_strsf()

subroutine stat_c_strsf ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) ipartc,
integer, dimension(*) iparttg,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxc,
integer, dimension(*) stat_indxtg,
thke,
integer sizp0 )

Definition at line 36 of file stat_c_strsf.F.

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 ENDIF ! IF (ISPMD == 0.AND.LEN > 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 IF (igtyp == 51 .OR. 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 IF (mlw == 1 .OR. mlw == 3 .OR. 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 IF (mlw /= 0 .AND. 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 IF (mlw /= 0 .AND. 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 IF (mlw /= 0 .AND. mlw /= 13) THEN
688 wa(jj) = gbuf%EINT(i)
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+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 IF (mlw == 0 .or. 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 ENDIF ! IF (MLW == 0 .or. MLW == 13)
769 ELSE ! MPT > 0
770 IF (mlw == 0 .or. 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 ENDIF ! IF (MLW == 0 .or. 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 IF (ispmd == 0.AND.len > 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
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
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