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 37 of file stat_p_aux.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 : nixp
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 "param_c.inc"
56#include "units_c.inc"
57#include "scr14_c.inc"
58#include "scr16_c.inc"
59#include "task_c.inc"
60C-----------------------------------------------
61C D u m m y A r g u m e n t s
62C-----------------------------------------------
63 INTEGER SIZP0
64 INTEGER IXP(NIXP,*),
65 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
66 . IPARTP(*),IPART_STATE(*),STAT_INDXP(*)
67 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
68 double precision WA(*),WAP0(*)
69C-----------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 INTEGER I,N,J,K,JJ,LEN,IOFF,NG,NEL,NFT,ITY,LFT,LLT,ID,IPRT0,IPRT,IE,
73 . NPT,IR,IS,IPT,IL,IVAR,MY_NUVAR,IGTYP,IPROP,MLW
74 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
75 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
76 CHARACTER*100 DELIMIT,LINE
77 TYPE(G_BUFEL_) ,POINTER :: GBUF
78 my_real,
79 . DIMENSION(:) ,POINTER :: uvar
80C-----------------------------------------------
81 DATA delimit(1:60)
82 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
83 DATA delimit(61:100)
84 ./'----7----|----8----|----9----|----10---|'/
85C-----------------------------------------------
86C BEAM
87C-----------------------------------------------
88 CALL my_alloc(ptwa,stat_numelp)
89 ALLOCATE(ptwa_p0(0:max(1,stat_numelp_g)))
90C-----------------------------------------------
91 jj = 0
92!
93 IF (stat_numelp /= 0) THEN
94!
95 ie=0
96 DO ng=1,ngroup
97 ity = iparg(5,ng)
98 IF (ity == 5) THEN
99 gbuf => elbuf_tab(ng)%GBUF
100 mlw = iparg(1,ng)
101 nel = iparg(2,ng)
102 nft = iparg(3,ng)
103 npt = iparg(6,ng)
104 iprop = ixp(5,nft+1)
105 igtyp = igeo(11,iprop)
106 lft=1
107 llt=nel
108!
109 DO i=lft,llt
110 n = i + nft
111 iprt=ipartp(n)
112 IF (ipart_state(iprt) /= 0) THEN
113 wa(jj + 1) = gbuf%OFF(i)
114 wa(jj + 2) = iprt
115 wa(jj + 3) = ixp(nixp,n)
116 wa(jj + 4) = igtyp
117 wa(jj + 5) = npt
118 jj = jj + 5
119!---
120 IF (mlw == 36) THEN ! only one user law compatible with beams
121!---
122 my_nuvar = ipm(8,ixp(1,n))
123 jj = jj + 1
124 wa(jj) = my_nuvar
125!
126 DO ipt=1,npt
127 il = 1
128 ir = 1
129 is = 1
130!! NUVAR = ELBUF_STR%BUFLY(ILAY)%NVAR_MAT
131 uvar => elbuf_tab(ng)%BUFLY(il)%MAT(ir,is,ipt)%VAR
132 DO ivar=1,my_nuvar
133 jj = jj + 1
134 wa(jj) = uvar((ivar-1)*nel + i)
135 ENDDO
136 ENDDO ! DO IPT=1,NPT
137!---
138 ELSE ! Not User law
139!---
140 my_nuvar = 0
141 jj = jj + 1
142 wa(jj) = my_nuvar
143 ENDIF ! IF (MLW == 36)
144!---
145 ie=ie+1
146! end-of-zone pointer in wa
147 ptwa(ie)=jj
148 ENDIF ! IF (IPART_STATE(IPRT) /= 0)
149 ENDDO ! DO I=LFT,LLT
150 ENDIF ! IF (ITY == 5)
151 ENDDO ! DO NG=1,NGROUP
152 ENDIF ! IF (STAT_NUMELP /= 0)
153!-----------------------------------------------------------------------
154! BEAM - WRITE
155!-----------------------------------------------------------------------
156 IF (nspmd == 1) THEN
157! unnecessary copies for code simplification
158 ptwa_p0(0)=0
159 DO n=1,stat_numelp
160 ptwa_p0(n)=ptwa(n)
161 ENDDO
162 len=jj
163 DO j=1,len
164 wap0(j)=wa(j)
165 ENDDO
166 ELSE
167! builds the pointers in the global wap0 array
168 CALL spmd_stat_pgather(ptwa,stat_numelp,ptwa_p0,stat_numelp_g)
169 len = 0
170 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
171 END IF
172!-------------------------------------
173 IF (ispmd == 0 .AND. len > 0) THEN
174 iprt0 = 0
175 DO n=1,stat_numelp_g
176! find the nieme elt in the order of an increasing id
177 k=stat_indxp(n)
178! Find the address in WAP0
179 j=ptwa_p0(k-1)
180!
181 ioff = nint(wap0(j + 1))
182 my_nuvar = nint(wap0(j + 6))
183 IF (ioff >= 1 .AND. my_nuvar /= 0) THEN
184 iprt = nint(wap0(j + 2))
185 IF (iprt /= iprt0) THEN
186 IF (izipstrs == 0) THEN
187 WRITE(iugeo,'(A)') delimit
188 WRITE(iugeo,'(A)')'/INIBEAM/AUX'
189 WRITE(iugeo,'(A)')
190 .'#------------------------ REPEAT --------------------------'
191 WRITE(iugeo,'(A)')
192 . '# BEAMID NPT PROP_TYPE NVAR'
193 WRITE(iugeo,'(A/A)')
194 .'# THE CONTENT OF THE FOLLOWING CARDS WILL NOT BE DISCLOSED',
195 .'# THEY MUST NOT BE CHANGED.'
196 WRITE(iugeo,'(A)')
197 .'#---------------------- END REPEAT ------------------------'
198 WRITE(iugeo,'(A)') delimit
199 ELSE
200 WRITE(line,'(A)') delimit
201 CALL strs_txt50(line,100)
202 WRITE(line,'(A)')'/INIBEAM/AUX'
203 CALL strs_txt50(line,100)
204 WRITE(line,'(A)')
205 .'#------------------------ REPEAT --------------------------'
206 CALL strs_txt50(line,100)
207 WRITE(line,'(A)')
208 . '# BEAMID NPT PROP_TYPE NVAR'
209 CALL strs_txt50(line,100)
210 WRITE(line,'(A)')
211 .'# THE CONTENT OF THE FOLLOWING CARDS WILL NOT BE DISCLOSED'
212 CALL strs_txt50(line,100)
213 WRITE(line,'(A)')
214 .'# THEY MUST NOT BE CHANGED.'
215 CALL strs_txt50(line,100)
216 WRITE(line,'(A)')
217 .'#---------------------- END REPEAT ------------------------'
218 CALL strs_txt50(line,100)
219 WRITE(line,'(A)') delimit
220 CALL strs_txt50(line,100)
221 ENDIF ! IF (IZIPSTRS == 0)
222 iprt0=iprt
223 ENDIF ! IF (IPRT /= IPRT0)
224 id = nint(wap0(j + 3))
225 igtyp = nint(wap0(j + 4))
226 npt = nint(wap0(j + 5))
227 my_nuvar = nint(wap0(j + 6))
228 j = j + 6
229 IF (izipstrs == 0) THEN
230 WRITE(iugeo,'(4I10)')id,npt,igtyp,my_nuvar
231 ELSE
232 WRITE(line,'(4I10)')id,npt,igtyp,my_nuvar
233 CALL strs_txt50(line,100)
234 ENDIF
235 DO jj=1,npt
236 IF (izipstrs == 0) THEN
237 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=1,my_nuvar)
238 ELSE
239 CALL tab_strs_txt50(wap0(1),my_nuvar,j,sizp0,5)
240 ENDIF
241 j=j+my_nuvar
242 ENDDO
243 ENDIF ! IF (IOFF == 1 .AND. MY_NUVAR /= 0)
244 ENDDO ! DO N=1,STAT_NUMELP_G
245 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
246c-----------
247 DEALLOCATE(ptwa)
248 DEALLOCATE(ptwa_p0)
249c------------
250 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
the
end diagonal values have been computed in the(sparse) matrix id.SOL
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