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