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

Go to the source code of this file.

Functions/Subroutines

subroutine stat_p_full (elbuf_tab, iparg, geo, igeo, ixp, wa, wap0, ipartp, ipart_state, stat_indxp, sizp0)

Function/Subroutine Documentation

◆ stat_p_full()

subroutine stat_p_full ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
geo,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixp,*) ixp,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) ipartp,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxp,
integer sizp0 )

Definition at line 35 of file stat_p_full.F.

39C-----------------------------------------------
40C M o d u l e s
41C-----------------------------------------------
42 USE elbufdef_mod
43 USE my_alloc_mod
44 use element_mod , only : nixp
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 "param_c.inc"
54#include "units_c.inc"
55#include "task_c.inc"
56#include "scr16_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER SIZP0
61 INTEGER IXP(NIXP,*),IPARG(NPARG,*),IGEO(NPROPGI,*),
62 . IPARTP(*),IPART_STATE(*),STAT_INDXP(*)
63 my_real
64 . geo(npropg,*)
65 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
66 double precision WA(*),WAP0(*)
67C-----------------------------------------------
68C L o c a l V a r i a b l e s
69C-----------------------------------------------
70 INTEGER I,J,K,N,II(3),JJ,LEN,IOFF,IE,NG,NEL,NFT,LFT,
71 . LLT,ITY,ID,IPRT0,IPRT,IGTYP,IPROP,NPT,IPT,ILAY,
72 . IR,IS,PT,L_PLA,G_PLA
73 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
74 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
75 CHARACTER*100 DELIMIT
76 TYPE(G_BUFEL_) ,POINTER :: GBUF
77 TYPE(L_BUFEL_) ,POINTER :: LBUF
78C-----------------------------------------------
79 DATA delimit(1:60)
80 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
81 DATA delimit(61:100)
82 ./'----7----|----8----|----9----|----10---|'/
83C=======================================================================
84C BEAM
85C-----------------------------------------------
86 CALL my_alloc(ptwa,stat_numelp)
87 ALLOCATE(ptwa_p0(0:max(1,stat_numelp_g)))
88C-----------------------------------------------
89 jj = 0
90!
91 IF (stat_numelp /= 0) THEN
92!
93 ie=0
94 DO ng=1,ngroup
95 ity = iparg(5,ng)
96 IF (ity == 5) THEN
97 gbuf => elbuf_tab(ng)%GBUF
98 nel = iparg(2,ng)
99 nft = iparg(3,ng)
100 npt = iparg(6,ng)
101 iprop = ixp(5,nft+1)
102 igtyp = igeo(11,iprop)
103 lft=1
104 llt=nel
105!
106 DO j=1,3
107 ii(j) = (j-1)*nel
108 ENDDO
109!
110 DO i=lft,llt
111 n = i + nft
112 iprt=ipartp(n)
113 IF (ipart_state(iprt) /= 0) THEN
114 wa(jj + 1) = gbuf%OFF(i)
115 wa(jj + 2) = iprt
116 wa(jj + 3) = ixp(nixp,n)
117 wa(jj + 4) = igtyp
118 wa(jj + 5) = npt
119 jj = jj + 5
120!
121 wa(jj + 1) = gbuf%EINT(ii(1)+i)
122 wa(jj + 2) = gbuf%EINT(ii(2)+i)
123!
124 wa(jj + 3) = gbuf%FOR(ii(1)+i)
125 wa(jj + 4) = gbuf%FOR(ii(2)+i)
126 wa(jj + 5) = gbuf%FOR(ii(3)+i)
127!
128 wa(jj + 6) = gbuf%MOM(ii(1)+i)
129 wa(jj + 7) = gbuf%MOM(ii(2)+i)
130 wa(jj + 8) = gbuf%MOM(ii(3)+i)
131 jj = jj + 8
132!------------
133 IF (igtyp == 3) THEN
134!------------
135 g_pla = gbuf%G_PLA
136 IF (g_pla > 0) THEN
137 wa(jj + 1) = gbuf%PLA(i)
138 ELSE
139 wa(jj + 1) = zero
140 ENDIF
141 jj = jj + 1
142!------------
143 ELSEIF (igtyp == 18) THEN
144!------------
145 pt = 0
146 DO ipt=1,npt
147 ilay=1
148 ir = 1
149 is = 1
150 lbuf => elbuf_tab(ng)%BUFLY(ilay)%LBUF(ir,is,ipt)
151 l_pla = elbuf_tab(ng)%BUFLY(ilay)%L_PLA
152 wa(jj + pt + 1) = lbuf%SIG(ii(1)+i)
153 wa(jj + pt + 2) = lbuf%SIG(ii(2)+i)
154 wa(jj + pt + 3) = lbuf%SIG(ii(3)+i)
155 IF (l_pla > 0) THEN
156 wa(jj + pt + 4) = lbuf%PLA(i)
157 ELSE
158 wa(jj + pt + 4) = zero
159 ENDIF
160 pt = pt + 4
161 ENDDO ! DO IPT=1,NPT
162 jj = jj + pt
163 ENDIF ! IF (IGTYP)
164!---
165 ie=ie+1
166!--- end-of-zone pointer in wa
167 ptwa(ie)=jj
168 ENDIF ! IF (IPART_STATE(IPRT) /= 0)
169 ENDDO ! DO I=LFT,LLT
170c------- end loop over beam elements
171 ENDIF ! ITY == 5
172 ENDDO ! NG = 1, NGROUP
173 ENDIF ! IF (STAT_NUMELP == 0) THEN
174!-----------------------------------------------------------------------
175! BEAM - WRITE
176!-----------------------------------------------------------------------
177 IF (nspmd == 1) THEN
178! unnecessary copies for code simplification
179 ptwa_p0(0)=0
180 DO n=1,stat_numelp
181 ptwa_p0(n)=ptwa(n)
182 ENDDO
183 len=jj
184 DO j=1,len
185 wap0(j)=wa(j)
186 ENDDO
187 ELSE
188! builds the pointers in the global wap0 array
189 CALL spmd_stat_pgather(ptwa,stat_numelp,ptwa_p0,stat_numelp_g)
190 len = 0
191 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
192 ENDIF
193!-------------------------------------
194 IF (ispmd == 0 .AND. len > 0) THEN
195 iprt0 = 0
196 DO n=1,stat_numelp_g
197! find the nieme elt in the order of an increasing id
198 k=stat_indxp(n)
199! Find the address in WAP0
200 j=ptwa_p0(k-1)
201!
202 ioff = nint(wap0(j + 1))
203 IF (ioff >= 1) THEN
204 iprt = nint(wap0(j + 2))
205 id = nint(wap0(j + 3))
206 igtyp = nint(wap0(j + 4))
207 npt = nint(wap0(j + 5))
208 j = j + 5
209!--------------------------------------
210 IF (igtyp == 3) THEN
211!--------------------------------------
212 IF (iprt /= iprt0) THEN
213 WRITE(iugeo,'(A)') delimit
214 WRITE(iugeo,'(A)')'/INIBEAM/FULL'
215 WRITE(iugeo,'(A)')
216 . '#----------------------------------------------------------'
217 WRITE(iugeo,'(A)')'#BEAM_ID NPT PROP_TYPE'
218 WRITE(iugeo,'(A)')'#FORMAT:(1P2E20.13) #(EM(I),EB(I) ,I=BEAM_ID)'
219 WRITE(iugeo,'(A)')'#FORMAT:(1P3E20.13) #(FX(I),FXY(I),FXZ(I),I=BEAM_ID)'
220 WRITE(iugeo,'(A)')'#FORMAT:(1P3E20.13) #(MX(I),MY(I),MZ(I),I=BEAM_ID)'
221 WRITE(iugeo,'(A)')'#FORMAT:(1P1E20.13) #(EPSP(I),I=BEAM_ID)'
222 WRITE(iugeo,'(A)')
223 . '#----------------------------------------------------------'
224!
225 iprt0=iprt
226 ENDIF ! IF (IPRT /= IPRT0)
227!
228 WRITE(iugeo,'(3I10)') id,npt,igtyp
229 WRITE(iugeo,'(1P2E20.13)')(wap0(j+k),k=1,2) ! EINT
230 WRITE(iugeo,'(1P3E20.13)')(wap0(j+k),k=3,5) ! FOR
231 WRITE(iugeo,'(1P3E20.13)')(wap0(j+k),k=6,8) ! MOM
232 WRITE(iugeo,'(1P1E20.13)') wap0(j+9) ! EPSP
233!--------------------------------------
234 ELSEIF (igtyp == 18) THEN
235!--------------------------------------
236 IF (iprt /= iprt0) THEN
237 WRITE(iugeo,'(A)') delimit
238 WRITE(iugeo,'(A)')'/INIBEAM/FULL'
239 WRITE(iugeo,'(A)')
240 . '#----------------------------------------------------------'
241 WRITE(iugeo,'(A)')
242 . '#BEAM_ID NPT PROP_TYPE'
243 WRITE(iugeo,'(A)')'#FORMAT:(1P2E20.13) #(EM(I),EB(I) ,I=BEAM_ID)'
244 WRITE(iugeo,'(A)')'#FORMAT:(1P3E20.13) #(FX(I),FXY(I),FXZ(I),I=BEAM_ID)'
245 WRITE(iugeo,'(A)')'#FORMAT:(1P3E20.13) #(MX(I),MY(I) ,MZ(I) ,I=BEAM_ID)'
246 WRITE(iugeo,'(A)')
247 . '#------------------------ REPEAT --------------------------'
248 WRITE(iugeo,'(A/A)')
249 .'# FORMAT:(1P3E20.13) ; REPEAT K=1,NPT : ',
250 .'#(S1(I),S12(I),S13(I),EPSP(I) ,I=BEAM_ID)'
251 WRITE(iugeo,'(A)')
252 . '#---------------------- END REPEAT ------------------------'
253 WRITE(iugeo,'(A)')
254 . '#----------------------------------------------------------'
255!
256 iprt0=iprt
257 ENDIF ! IF (IPRT /= IPRT0)
258 WRITE(iugeo,'(3I10)') id,npt,igtyp
259 WRITE(iugeo,'(1P2E20.13)')(wap0(j+k),k=1,2) ! EINT
260 WRITE(iugeo,'(1P3E20.13)')(wap0(j+k),k=3,5) ! FOR
261 WRITE(iugeo,'(1P3E20.13)')(wap0(j+k),k=6,8) ! MOM
262! WRITE(IUGEO,'(1P4E20.13)')(WAP0(J+K),K=9,9+4*NPT-1)! SIG + EPSP
263 j = j + 8
264 DO ipt=1,npt
265 WRITE(iugeo,'(1P4E20.13)')(wap0(j+k),k=1,4) ! SIG + EPSP
266 j = j + 4
267 ENDDO ! DO IPT=1,NPT
268!--------------------------------------
269 ENDIF ! IF (IGTYP)
270!--------------------------------------
271 ENDIF ! IF (ioff >= 1)
272 ENDDO ! DO N=1,STAT_NUMELP_G
273 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
274!---
275c----------
276 DEALLOCATE(ptwa)
277 DEALLOCATE(ptwa_p0)
278c-----------
279 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