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

Go to the source code of this file.

Functions/Subroutines

subroutine stat_p_aux (elbuf_tab, iparg, ipm, igeo, ixp, wa, wap0, ipartp, ipart_state, stat_indxp, sizp0)

Function/Subroutine Documentation

◆ stat_p_aux()

subroutine stat_p_aux ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
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 36 of file stat_p_aux.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 "param_c.inc"
54#include "units_c.inc"
55#include "scr14_c.inc"
56#include "scr16_c.inc"
57#include "task_c.inc"
58C-----------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 INTEGER SIZLOC,SIZP0
62 INTEGER IXP(NIXP,*),
63 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
64 . IPARTP(*),IPART_STATE(*),STAT_INDXP(*)
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,N,J,K,JJ,LEN,IOFF,NG,NEL,NFT,ITY,LFT,LLT,ID,IPRT0,IPRT,IE,
71 . NPT,IR,IS,IPT,IL,IVAR,NUVAR,MY_NUVAR,IGTYP,IPROP,MLW
72 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
73 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
74 CHARACTER*100 DELIMIT,LINE
75 TYPE(G_BUFEL_) ,POINTER :: GBUF
76 my_real,
77 . DIMENSION(:) ,POINTER :: uvar
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 mlw = iparg(1,ng)
99 nel = iparg(2,ng)
100 nft = iparg(3,ng)
101 npt = iparg(6,ng)
102 iprop = ixp(5,nft+1)
103 igtyp = igeo(11,iprop)
104 lft=1
105 llt=nel
106!
107 DO i=lft,llt
108 n = i + nft
109 iprt=ipartp(n)
110 IF (ipart_state(iprt) /= 0) THEN
111 wa(jj + 1) = gbuf%OFF(i)
112 wa(jj + 2) = iprt
113 wa(jj + 3) = ixp(nixp,n)
114 wa(jj + 4) = igtyp
115 wa(jj + 5) = npt
116 jj = jj + 5
117!---
118 IF (mlw == 36) THEN ! only one user law compatible with beams
119!---
120 my_nuvar = ipm(8,ixp(1,n))
121 jj = jj + 1
122 wa(jj) = my_nuvar
123!
124 DO ipt=1,npt
125 il = 1
126 ir = 1
127 is = 1
128!! NUVAR = ELBUF_STR%BUFLY(ILAY)%NVAR_MAT
129 uvar => elbuf_tab(ng)%BUFLY(il)%MAT(ir,is,ipt)%VAR
130 DO ivar=1,my_nuvar
131 jj = jj + 1
132 wa(jj) = uvar((ivar-1)*nel + i)
133 ENDDO
134 ENDDO ! DO IPT=1,NPT
135!---
136 ELSE ! Not User law
137!---
138 my_nuvar = 0
139 jj = jj + 1
140 wa(jj) = my_nuvar
141 ENDIF ! IF (MLW == 36)
142!---
143 ie=ie+1
144! pointeur de fin de zone dans WA
145 ptwa(ie)=jj
146 ENDIF ! IF (IPART_STATE(IPRT) /= 0)
147 ENDDO ! DO I=LFT,LLT
148 ENDIF ! IF (ITY == 5)
149 ENDDO ! DO NG=1,NGROUP
150 ENDIF ! IF (STAT_NUMELP /= 0)
151!-----------------------------------------------------------------------
152! BEAM - WRITE
153!-----------------------------------------------------------------------
154 IF (nspmd == 1) THEN
155! recopies inutiles pour simplification du code.
156 ptwa_p0(0)=0
157 DO n=1,stat_numelp
158 ptwa_p0(n)=ptwa(n)
159 ENDDO
160 len=jj
161 DO j=1,len
162 wap0(j)=wa(j)
163 ENDDO
164 ELSE
165! construit les pointeurs dans le tableau global WAP0
166 CALL spmd_stat_pgather(ptwa,stat_numelp,ptwa_p0,stat_numelp_g)
167 len = 0
168 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
169 END IF
170!-------------------------------------
171 IF (ispmd == 0 .AND. len > 0) THEN
172 iprt0 = 0
173 DO n=1,stat_numelp_g
174! retrouve le nieme elt dans l'ordre d'id croissant
175 k=stat_indxp(n)
176! retrouve l'adresse dans WAP0
177 j=ptwa_p0(k-1)
178!
179 ioff = nint(wap0(j + 1))
180 my_nuvar = nint(wap0(j + 6))
181 IF (ioff >= 1 .AND. my_nuvar /= 0) THEN
182 iprt = nint(wap0(j + 2))
183 IF (iprt /= iprt0) THEN
184 IF (izipstrs == 0) THEN
185 WRITE(iugeo,'(A)') delimit
186 WRITE(iugeo,'(A)')'/INIBEAM/AUX'
187 WRITE(iugeo,'(A)')
188 .'#------------------------ REPEAT --------------------------'
189 WRITE(iugeo,'(A)')
190 . '# BEAMID NPT PROP_TYPE NVAR'
191 WRITE(iugeo,'(A/A)')
192 .'# THE CONTENT OF THE FOLLOWING CARDS WILL NOT BE DISCLOSED',
193 .'# THEY MUST NOT BE CHANGED.'
194 WRITE(iugeo,'(A)')
195 .'#---------------------- END REPEAT ------------------------'
196 WRITE(iugeo,'(A)') delimit
197 ELSE
198 WRITE(line,'(A)') delimit
199 CALL strs_txt50(line,100)
200 WRITE(line,'(A)')'/INIBEAM/AUX'
201 CALL strs_txt50(line,100)
202 WRITE(line,'(A)')
203 .'#------------------------ REPEAT --------------------------'
204 CALL strs_txt50(line,100)
205 WRITE(line,'(A)')
206 . '# BEAMID NPT PROP_TYPE NVAR'
207 CALL strs_txt50(line,100)
208 WRITE(line,'(A)')
209 .'# THE CONTENT OF THE FOLLOWING CARDS WILL NOT BE DISCLOSED'
210 CALL strs_txt50(line,100)
211 WRITE(line,'(A)')
212 .'# THEY MUST NOT BE CHANGED.'
213 CALL strs_txt50(line,100)
214 WRITE(line,'(A)')
215 .'#---------------------- END REPEAT ------------------------'
216 CALL strs_txt50(line,100)
217 WRITE(line,'(A)') delimit
218 CALL strs_txt50(line,100)
219 ENDIF ! IF (IZIPSTRS == 0)
220 iprt0=iprt
221 ENDIF ! IF (IPRT /= IPRT0)
222 id = nint(wap0(j + 3))
223 igtyp = nint(wap0(j + 4))
224 npt = nint(wap0(j + 5))
225 my_nuvar = nint(wap0(j + 6))
226 j = j + 6
227 IF (izipstrs == 0) THEN
228 WRITE(iugeo,'(4I10)')id,npt,igtyp,my_nuvar
229 ELSE
230 WRITE(line,'(4I10)')id,npt,igtyp,my_nuvar
231 CALL strs_txt50(line,100)
232 ENDIF
233 DO jj=1,npt
234 IF (izipstrs == 0) THEN
235 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=1,my_nuvar)
236 ELSE
237 CALL tab_strs_txt50(wap0(1),my_nuvar,j,sizp0,5)
238 ENDIF
239 j=j+my_nuvar
240 ENDDO
241 ENDIF ! IF (IOFF == 1 .AND. MY_NUVAR /= 0)
242 ENDDO ! DO N=1,STAT_NUMELP_G
243 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
244c-----------
245 DEALLOCATE(ptwa)
246 DEALLOCATE(ptwa_p0)
247c------------
248 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