OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_t_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_t_full (elbuf_tab, iparg, geo, igeo, ixt, wa, wap0, ipartt, ipart_state, stat_indxt, sizp0)

Function/Subroutine Documentation

◆ stat_t_full()

subroutine stat_t_full ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
geo,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixt,*) ixt,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) ipartt,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxt,
integer sizp0 )

Definition at line 35 of file stat_t_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 : nixt
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 IXT(NIXT,*),IPARG(NPARG,*),IGEO(NPROPGI,*),
62 . IPARTT(*),IPART_STATE(*),STAT_INDXT(*)
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,JJ,LEN,IOFF,IE,NG,NEL,NFT,LFT,
71 . LLT,ITY,ID,IPRT0,IPRT,IGTYP,IPROP
72 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
73 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
74 CHARACTER*100 DELIMIT
75 TYPE(G_BUFEL_) ,POINTER :: GBUF
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 TRUSS
83C-----------------------------------------------
84 CALL my_alloc(ptwa,stat_numelt)
85 ALLOCATE(ptwa_p0(0:max(1,stat_numels_g)))
86C-----------------------------------------------
87 jj = 0
88!
89 IF (stat_numelt /= 0) THEN
90!
91 ie=0
92 DO ng=1,ngroup
93 ity = iparg(5,ng)
94 IF (ity == 4) THEN
95 nel = iparg(2,ng)
96 nft = iparg(3,ng)
97 iprop = ixt(4,nft+1)
98 igtyp = igeo(11,iprop)
99 lft=1
100 llt=nel
101!
102 gbuf => elbuf_tab(ng)%GBUF
103!
104 DO i=lft,llt
105 n = i + nft
106 iprt=ipartt(n)
107 IF (ipart_state(iprt) /= 0) THEN
108 wa(jj + 1) = gbuf%OFF(i)
109 wa(jj + 2) = iprt
110 wa(jj + 3) = ixt(nixt,n)
111 wa(jj + 4) = igtyp
112 jj = jj + 4
113!
114 wa(jj + 1) = gbuf%EINT(i)
115 wa(jj + 2) = gbuf%FOR(i)
116 IF (gbuf%G_PLA > 0) THEN
117 wa(jj + 3) = gbuf%PLA(i)
118 ELSE
119 wa(jj + 3) = zero
120 ENDIF
121 wa(jj + 4) = gbuf%AREA(i)
122!
123 jj = jj + 4
124!---
125 ie=ie+1
126!end-of-zone pointer in wa
127 ptwa(ie)=jj
128 ENDIF ! IF (IPART_STATE(IPRT) /= 0)
129 ENDDO ! DO I=LFT,LLT
130c------- end loop over truss elements
131 ENDIF ! ITY == 4
132 ENDDO ! NG = 1, NGROUP
133 ENDIF ! IF (STAT_NUMELT == 0) THEN
134!-----------------------------------------------------------------------
135! TRUSS - WRITE
136!-----------------------------------------------------------------------
137 IF (nspmd == 1) THEN
138! unnecessary copies for code simplification
139 ptwa_p0(0)=0
140 DO n=1,stat_numelt
141 ptwa_p0(n)=ptwa(n)
142 ENDDO
143 len=jj
144 DO j=1,len
145 wap0(j)=wa(j)
146 ENDDO
147 ELSE
148! builds the pointers in the global array wap0
149 CALL spmd_stat_pgather(ptwa,stat_numelt,ptwa_p0,stat_numelt_g)
150 len = 0
151 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
152 ENDIF
153!-------------------------------------
154 IF (ispmd == 0 .AND. len > 0) THEN
155 iprt0 = 0
156 DO n=1,stat_numelt_g
157! find the nieme elt in the order of an increasing id
158 k=stat_indxt(n)
159! Find the address in WAP0
160 j=ptwa_p0(k-1)
161!
162 ioff = nint(wap0(j + 1))
163!! IF (IOFF >= 1) THEN
164 IF (ioff /= 0) THEN
165 iprt = nint(wap0(j + 2))
166 id = nint(wap0(j + 3))
167 igtyp = nint(wap0(j + 4))
168 j = j + 4
169!--------------------------------------
170 IF (igtyp == 2) THEN
171!--------------------------------------
172 IF (iprt /= iprt0) THEN
173 WRITE(iugeo,'(A)') delimit
174 WRITE(iugeo,'(A)')'/INITRUSS/FULL'
175 WRITE(iugeo,'(A)')
176 . '#----------------------------------------------------------'
177 WRITE(iugeo,'(A)')'#TRUSS_ID PROP_TYPE'
178 WRITE(iugeo,'(A)')'#FORMAT:(1P4E20.13) #(EIN(I),FOR(I),EPSP(I),AREA(I),I=TRUSS_ID)'
179 WRITE(iugeo,'(A)')
180 . '#----------------------------------------------------------'
181!
182 iprt0=iprt
183 ENDIF ! IF (IPRT /= IPRT0)
184!
185 WRITE(iugeo,'(I10,10X,I10)') id,igtyp
186 WRITE(iugeo,'(1P4E20.13)')(wap0(j+k),k=1,4) ! EINT,FOR,EPSP,AREA
187!--------------------------------------
188 ENDIF ! IF (IGTYP)
189!--------------------------------------
190 ENDIF ! IF (IOFF >= 1)
191 ENDDO ! DO N=1,STAT_NUMELT_G
192 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
193!---
194 DEALLOCATE(ptwa)
195 DEALLOCATE(ptwa_p0)
196c-----------
197 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
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
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