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