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

Go to the source code of this file.

Functions/Subroutines

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

Function/Subroutine Documentation

◆ stat_c_epspf()

subroutine stat_c_epspf ( 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 37 of file stat_c_epspf.F.

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 "scr14_c.inc"
59#include "task_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,N,J,K,JJ,LEN,IOFF,NG, NEL, NFT, ITY, LFT,LLT,IHBE,
77 . MLW, NPTR,NPTS,NPTT,NLAY,NPG,NPT,IR,IS,ID,IPRT0,IPRT,
78 . IPG,MPT,NPTM,IPT,IE,ITHK,IT,IGTYP,NPT_ALL
79 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
80 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
81 double precision
82 . THK
83 CHARACTER*100 DELIMIT,LINE
84 TYPE(G_BUFEL_) ,POINTER :: GBUF
85
86 TYPE(BUF_LAY_) ,POINTER :: BUFLY
87c
88 DATA delimit(1:60)
89 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
90 DATA delimit(61:100)
91 ./'----7----|----8----|----9----|----10---|'/
92C=======================================================================
93C 4-NODE SHELLS
94C-----------------------------------------------
95 CALL my_alloc(ptwa,max(stat_numelc ,stat_numeltg))
96 ALLOCATE(ptwa_p0(0:max(1,stat_numelc_g,stat_numeltg_g)))
97C-----------------------------------------------
98 jj = 0
99 IF (stat_numelc == 0) GOTO 200
100C
101 ie=0
102 DO ng=1,ngroup
103 ity = iparg(5,ng)
104 IF (ity == 3) THEN
105 gbuf => elbuf_tab(ng)%GBUF
106 mlw = iparg(1,ng)
107 nel = iparg(2,ng)
108 nft = iparg(3,ng)
109 mpt = iparg(6,ng)
110 ihbe = iparg(23,ng)
111 ithk = iparg(28,ng)
112 igtyp= iparg(38,ng)
113 nptr = elbuf_tab(ng)%NPTR
114 npts = elbuf_tab(ng)%NPTS
115 nptt = elbuf_tab(ng)%NPTT
116 nlay = elbuf_tab(ng)%NLAY
117 npt = nlay*nptt
118 npg = nptr*npts
119 IF (ihbe == 23) npg=4
120 lft = 1
121 llt = nel
122C
123C pre counting of all NPTT (especially for PID_51)
124C
125 IF (igtyp == 51 .OR. igtyp ==52) THEN
126 npt_all = 0
127 DO k=1,nlay
128 npt_all = npt_all + elbuf_tab(ng)%BUFLY(k)%NPTT
129 ENDDO
130 mpt = max(1,npt_all)
131 ENDIF
132C
133 DO i=lft,llt
134 n = i + nft
135 iprt=ipartc(n)
136 IF (ipart_state(iprt) == 0) cycle
137C
138 jj = jj + 1
139 IF (mlw /= 0 .AND. mlw /= 13) THEN
140 wa(jj) = gbuf%OFF(i)
141 ELSE
142 wa(jj) = zero
143 ENDIF
144 jj = jj + 1
145 wa(jj) = iprt
146 jj = jj + 1
147 wa(jj) = ixc(nixc,n)
148 jj = jj + 1
149 wa(jj) = mpt
150 jj = jj + 1
151 wa(jj) = npg
152 jj = jj + 1
153 IF (mlw /= 0 .AND. mlw /= 13) THEN
154 IF (ithk >0 ) THEN
155 wa(jj) = gbuf%THK(i)
156 ELSE
157 wa(jj) = thke(n)
158 END IF
159 ELSE
160 wa(jj) = zero
161 ENDIF
162c
163 IF (nlay > 1) THEN
164 IF (ihbe == 23) THEN
165 DO k=1,nlay
166 bufly => elbuf_tab(ng)%BUFLY(k)
167 nptt = bufly%NPTT
168 IF (bufly%L_PLA > 0) THEN
169 DO it=1,nptt
170 DO ir=1,npg
171 jj = jj + 1
172 wa(jj) = bufly%LBUF(1,1,it)%PLA(i)
173 ENDDO
174 ENDDO
175 ELSE
176 DO it=1,nptt
177 DO ir=1,npg
178 jj = jj + 1
179 wa(jj)=zero
180 ENDDO
181 ENDDO
182 ENDIF
183 ENDDO
184 ELSE ! (IHBE /= 23)
185 DO k=1,nlay
186 bufly => elbuf_tab(ng)%BUFLY(k)
187 nptt = bufly%NPTT
188 IF (bufly%L_PLA > 0) THEN
189 DO it=1,nptt
190 DO is=1,npts
191 DO ir=1,nptr
192 jj = jj + 1
193 wa(jj) = bufly%LBUF(ir,is,it)%PLA(i)
194 ENDDO
195 ENDDO
196 ENDDO
197 ELSE
198 DO it=1,nptt
199 DO is=1,npts
200 DO ir=1,nptr
201 jj = jj + 1
202 wa(jj)=zero
203 ENDDO
204 ENDDO
205 ENDDO
206 ENDIF
207 ENDDO
208 ENDIF ! IHBE
209c NLAY = 1 :
210 ELSEIF (elbuf_tab(ng)%BUFLY(1)%L_PLA > 0) THEN
211 bufly => elbuf_tab(ng)%BUFLY(1)
212 nptt = bufly%NPTT
213 IF (ihbe == 23) THEN
214 DO it=1,nptt
215 DO ir=1,npg
216 jj = jj + 1
217 wa(jj) = bufly%LBUF(1,1,it)%PLA(i)
218 ENDDO
219 ENDDO
220 ELSE
221 DO it=1,nptt
222 DO is=1,npts
223 DO ir=1,nptr
224 jj = jj + 1
225 wa(jj) = bufly%LBUF(ir,is,it)%PLA(i)
226 ENDDO
227 ENDDO
228 ENDDO
229 ENDIF ! IHBE
230 ELSE
231 IF (ihbe == 23) THEN
232 DO k=1,nptt
233 DO ir=1,npg
234 jj = jj + 1
235 wa(jj) = zero
236 ENDDO
237 ENDDO
238 ELSE
239 DO k=1,nptt
240 DO is=1,npts
241 DO ir=1,nptr
242 jj = jj + 1
243 wa(jj) = zero
244 ENDDO
245 ENDDO
246 ENDDO
247 ENDIF ! IHBE
248 ENDIF ! (NLAY > 1)
249C
250 ie=ie+1
251C end-of-zone pointer in wa
252 ptwa(ie)=jj
253 ENDDO ! I=LFT,LLT
254 ENDIF ! IF (ITY == 3)
255 ENDDO ! DO NG=1,NGROUP
256C
257 200 CONTINUE
258C
259 IF (nspmd == 1)THEN
260 ptwa_p0(0)=0
261 DO n=1,stat_numelc
262 ptwa_p0(n)=ptwa(n)
263 END DO
264 len=jj
265 DO j=1,len
266 wap0(j)=wa(j)
267 END DO
268 ELSE
269C builds the pointers in the global array wap0
270 CALL spmd_stat_pgather(ptwa,stat_numelc,ptwa_p0,stat_numelc_g)
271 len = 0
272 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
273 ENDIF
274C
275 IF (ispmd == 0 .AND. len > 0) THEN
276C
277 iprt0=0
278 DO n=1,stat_numelc_g
279C find the nieme elt in the order of an increasing id
280 k=stat_indxc(n)
281C Find the address in WAP0
282 j=ptwa_p0(k-1)
283
284 ioff = nint(wap0(j + 1))
285 IF (ioff == 1) THEN
286 iprt = nint(wap0(j + 2))
287 IF (iprt /= iprt0) THEN
288 IF (izipstrs == 0) THEN
289 WRITE(iugeo,'(A)') delimit
290 WRITE(iugeo,'(A)')'/INISHE/EPSP_F'
291 WRITE(iugeo,'(A)')
292 .'#------------------------ REPEAT --------------------------'
293 WRITE(iugeo,'(A)')
294 . '# SHELLID, NPT, NPG, THK'
295 WRITE(iugeo,'(A)')
296 .'# REPEAT IPT=1,MAX(1,NPT) : REPEAT IPG=1,NPG : EPSP(IPG,IPT)'
297 WRITE(iugeo,'(A)')
298 .'#---------------------- END REPEAT ------------------------'
299 WRITE(iugeo,'(A)') delimit
300 ELSE
301 WRITE(line,'(A)') delimit
302 CALL strs_txt50(line,100)
303 WRITE(line,'(A)') '/INISHE/EPSP_F'
304 CALL strs_txt50(line,100)
305 WRITE(line,'(A)')
306 .'#------------------------ REPEAT --------------------------'
307 CALL strs_txt50(line,100)
308 WRITE(line,'(A)')
309 . '# SHELLID, NPT, NPG, THK'
310 CALL strs_txt50(line,100)
311 WRITE(line,'(A)')
312 .'# REPEAT IPT=1,MAX(1,NPT) : REPEAT IPG=1,NPG : EPSP(IPG,IPT)'
313 CALL strs_txt50(line,100)
314 WRITE(line,'(A)')
315 .'#---------------------- END REPEAT ------------------------'
316 CALL strs_txt50(line,100)
317 WRITE(line,'(A)') delimit
318 CALL strs_txt50(line,100)
319 ENDIF ! IF (IZIPSTRS == 0)
320 iprt0=iprt
321 ENDIF ! IF (IPRT /= IPRT0)
322 id = nint(wap0(j + 3))
323 npt = nint(wap0(j + 4))
324 npg = nint(wap0(j + 5))
325 thk = wap0(j + 6)
326 j = j + 6
327 IF (izipstrs == 0) THEN
328 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
329 ELSE
330 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
331 CALL strs_txt50(line,100)
332 ENDIF
333 mpt = iabs(npt)
334 nptm = max(1,mpt)
335 IF (izipstrs == 0) THEN
336 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=1,nptm*npg)
337 ELSE
338 CALL tab_strs_txt50(wap0,nptm*npg,j,sizp0,5)
339 ENDIF
340 ENDIF ! IF (IOFF == 1)
341 ENDDO ! DO N=1,STAT_NUMELC_G
342 ENDIF ! IF (ISPMD == 0 .AND. LEN > 0)
343
344C-----------------------------------------------
345C 3-NODE SHELLS
346C-----------------------------------------------
347 jj = 0
348 IF (stat_numeltg==0) GOTO 300
349C
350 ie=0
351C
352 DO ng=1,ngroup
353 ity = iparg(5,ng)
354 IF (ity == 7) THEN
355 gbuf => elbuf_tab(ng)%GBUF
356 mlw = iparg(1,ng)
357 nel = iparg(2,ng)
358 nft = iparg(3,ng)
359 mpt = iparg(6,ng)
360 ithk = iparg(28,ng)
361 igtyp= iparg(38,ng)
362 nptr = elbuf_tab(ng)%NPTR
363 npts = elbuf_tab(ng)%NPTS
364 nptt = elbuf_tab(ng)%NPTT
365 nlay = elbuf_tab(ng)%NLAY
366 npg = nptr*npts
367 npt = nlay*nptt
368 lft=1
369 llt=nel
370C
371C pre counting of all NPTT (especially for PID_51)
372C
373 IF (igtyp == 51 .OR. igtyp == 52) THEN
374 npt_all = 0
375 DO k=1,nlay
376 npt_all = npt_all + elbuf_tab(ng)%BUFLY(k)%NPTT
377 ENDDO
378 mpt = max(1,npt_all)
379 ENDIF
380C
381 DO i=lft,llt
382 n = i + nft
383C
384 iprt=iparttg(n)
385 IF (ipart_state(iprt) == 0) cycle
386C
387 jj = jj + 1
388 IF (mlw /= 0 .AND. mlw /= 13) THEN
389 wa(jj) = gbuf%OFF(i)
390 ELSE
391 wa(jj) = zero
392 ENDIF
393 jj = jj + 1
394 wa(jj) = iprt
395 jj = jj + 1
396 wa(jj) = ixtg(nixtg,n)
397 jj = jj + 1
398 wa(jj) = mpt
399 jj = jj + 1
400 wa(jj) = npg
401 jj = jj + 1
402 IF (mlw /= 0 .AND. mlw /= 13) THEN
403 IF (ithk > 0) THEN
404 wa(jj) = gbuf%THK(i)
405 ELSE
406 wa(jj) = thke(n+numelc)
407 ENDIF
408 ELSE
409 wa(jj) = zero
410 ENDIF
411c
412 IF (nlay > 1) THEN
413 DO k=1,nlay
414 bufly => elbuf_tab(ng)%BUFLY(k)
415 nptt = bufly%NPTT
416 IF (bufly%L_PLA > 0) THEN
417 DO it=1,nptt
418 DO ir=1,nptr
419 DO is=1,npts
420 jj = jj + 1
421 wa(jj) = bufly%LBUF(ir,is,it)%PLA(i)
422 ENDDO
423 ENDDO
424 ENDDO
425 ELSE
426 DO it=1,nptt
427 DO ir=1,nptr
428 DO is=1,npts
429 jj = jj + 1
430 wa(jj)=zero
431 ENDDO
432 ENDDO
433 ENDDO
434 ENDIF
435 ENDDO
436c NLAY = 1 :
437 ELSEIF (elbuf_tab(ng)%BUFLY(1)%L_PLA > 0) THEN
438 bufly => elbuf_tab(ng)%BUFLY(1)
439 nptt = bufly%NPTT
440 DO it=1,nptt
441 DO ir=1,nptr
442 DO is=1,npts
443 jj = jj + 1
444 wa(jj) = bufly%LBUF(ir,is,it)%PLA(i)
445 ENDDO
446 ENDDO
447 ENDDO
448 ELSE
449 DO k=1,nptt
450 DO ir=1,nptr
451 DO is=1,npts
452 jj = jj + 1
453 wa(jj) = zero
454 ENDDO
455 ENDDO
456 ENDDO
457 ENDIF ! IF (NLAY > 1)
458C
459 ie=ie+1
460C end-of-zone pointer
461 ptwa(ie)=jj
462 ENDDO ! I=LFT,LLT
463 ENDIF ! IF (ITY == 7)
464 ENDDO ! DO NG=1,NGROUP
465C
466 300 CONTINUE
467C
468 IF (nspmd == 1) THEN
469 len=jj
470 DO j=1,len
471 wap0(j)=wa(j)
472 ENDDO
473 ptwa_p0(0)=0
474 DO n=1,stat_numeltg
475 ptwa_p0(n)=ptwa(n)
476 ENDDO
477 ELSE
478C builds the pointers in the global array wap0
479 CALL spmd_stat_pgather(ptwa,stat_numeltg,ptwa_p0,stat_numeltg_g)
480 len = 0
481 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
482 ENDIF
483C
484 IF(ispmd == 0.AND.len>0) THEN
485C
486 iprt0=0
487 DO n=1,stat_numeltg_g
488C find the nieme elt in the order of an increasing id
489 k=stat_indxtg(n)
490C Find the address in WAP0
491 j=ptwa_p0(k-1)
492C
493 ioff = nint(wap0(j + 1))
494 IF (ioff == 1) THEN
495 iprt = nint(wap0(j + 2))
496 IF (iprt /= iprt0) THEN
497 IF (izipstrs == 0) THEN
498 WRITE(iugeo,'(A)') delimit
499 WRITE(iugeo,'(A)')'/INISH3/EPSP_F'
500 WRITE(iugeo,'(A)')
501 .'#------------------------ REPEAT --------------------------'
502 WRITE(iugeo,'(A)')
503 . '# SH3NID NPT NPG THK'
504 WRITE(iugeo,'(A)')
505 .'# REPEAT IPT=1,MAX(1,NPT) : REPEAT IPG=1,NPG : EPSP(IPG,IPT)'
506 WRITE(iugeo,'(A)')
507 .'#---------------------- END REPEAT ------------------------'
508 WRITE(iugeo,'(A)') delimit
509 ELSE
510 WRITE(line,'(A)') delimit
511 CALL strs_txt50(line,100)
512 WRITE(line,'(A)')'/INISH3/EPSP_F'
513 CALL strs_txt50(line,100)
514 WRITE(line,'(A)')
515 .'#------------------------ REPEAT --------------------------'
516 CALL strs_txt50(line,100)
517 WRITE(line,'(A)')
518 . '# SH3NID NPT NPG THK'
519 CALL strs_txt50(line,100)
520 WRITE(line,'(A)')
521 .'# REPEAT IPT=1,MAX(1,NPT) : REPEAT IPG=1,NPG : EPSP(IPG,IPT)'
522 CALL strs_txt50(line,100)
523 WRITE(line,'(A)')
524 .'#---------------------- END REPEAT ------------------------'
525 CALL strs_txt50(line,100)
526 WRITE(line,'(A)') delimit
527 CALL strs_txt50(line,100)
528 ENDIF ! IF (IZIPSTRS == 0)
529 iprt0=iprt
530 ENDIF ! IF (IPRT /= IPRT0)
531 id = nint(wap0(j + 3))
532 npt = nint(wap0(j + 4))
533 npg = nint(wap0(j + 5))
534 thk = wap0(j + 6)
535 j = j + 6
536 IF (izipstrs == 0) THEN
537 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
538 ELSE
539 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
540 CALL strs_txt50(line,100)
541 ENDIF
542 mpt = iabs(npt)
543 nptm = max(1,mpt)
544 IF (izipstrs == 0) THEN
545 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=1,nptm*npg)
546 ELSE
547 CALL tab_strs_txt50(wap0,nptm*npg,j,sizp0,5)
548 ENDIF
549 ENDIF ! IF (IOFF == 1)
550 ENDDO ! DO N=1,STAT_NUMELTG_G
551 ENDIF ! IF(ISPMD == 0.AND.LEN>0)
552c-----------
553 DEALLOCATE(ptwa)
554 DEALLOCATE(ptwa_p0)
555c-----------
556C
557 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: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