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 34 of file stat_p_full.F.

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