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

Go to the source code of this file.

Functions/Subroutines

subroutine stat_s_ortho (elbuf_tab, iparg, ipm, igeo, ixs, wa, wap0, iparts, ipart_state, stat_indxs, x, iglob, ipart, idel, sizp0)

Function/Subroutine Documentation

◆ stat_s_ortho()

subroutine stat_s_ortho ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixs,*) ixs,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) iparts,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxs,
x,
integer iglob,
integer, dimension(lipart1,*) ipart,
integer idel,
integer sizp0 )

Definition at line 39 of file stat_s_ortho.F.

42C-----------------------------------------------
43C M o d u l e s
44C-----------------------------------------------
45 USE initbuf_mod
46 USE elbufdef_mod
47 USE my_alloc_mod
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "com01_c.inc"
56#include "param_c.inc"
57#include "units_c.inc"
58#include "task_c.inc"
59#include "scr14_c.inc"
60#include "scr16_c.inc"
61#include "vect01_c.inc"
62#include "scr17_c.inc"
63C-----------------------------------------------
64C D u m m y A r g u m e n t s
65C-----------------------------------------------
66 INTEGER SIZLOC,SIZP0,IGLOB,IDEL
67 INTEGER IXS(NIXS,*),
68 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
69 . IPARTS(*), IPART_STATE(*), STAT_INDXS(*),IPART(LIPART1,*)
70 my_real
71 . x(3,*)
72 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
73 double precision WA(*),WAP0(*)
74C-----------------------------------------------
75C L o c a l V a r i a b l e s
76C-----------------------------------------------
77 INTEGER I,N,J,K,II(6),JJ,LEN,ISOLNOD,IUS, NPTR, NPTS, NPTT, NPTG,
78 . NG, NEL, MLW,ID, IPRT0, IPRT, NPG,IPG,IPT, NUVAR,IE,
79 . NLAY,IP,IL,IR,IS,IT,PID,ICSIG,IOFF
80 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
81 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
82 my_real
83 . gama(6)
84 CHARACTER*100 DELIMIT,LINE
85 DATA delimit(1:60)
86 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
87 DATA delimit(61:100)
88 ./'----7----|----8----|----9----|----10---|'/
89C----
90 TYPE(L_BUFEL_) ,POINTER :: LBUF
91 TYPE(G_BUFEL_) ,POINTER :: GBUF
92C-----------------------------------------------
93C 8 NODES BRICK
94C======================================================================|
95 CALL my_alloc(ptwa,stat_numels)
96 ALLOCATE(ptwa_p0(0:max(1,stat_numels_g)))
97C-----------------------------------------------
98 jj = 0
99 IF(stat_numels==0) GOTO 200
100
101 ie=0
102 DO ng=1,ngroup
103 ity =iparg(5,ng)
104 isolnod = iparg(28,ng)
105 mlw =iparg(1,ng)
106 nel =iparg(2,ng)
107 nft =iparg(3,ng)
108 iad =iparg(4,ng)
109 icsig =iparg(17,ng)
110 lft=1
111 llt = nel
112c
113 IF (ity == 1) THEN
114 CALL initbuf(iparg ,ng ,
115 2 mlw ,nel ,nft ,iad ,ity ,
116 3 npt ,jale ,ismstr ,jeul ,jtur ,
117 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
118 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
119 6 irep ,iint ,igtyp ,israt ,isrot ,
120 7 icsen ,isorth ,isorthg ,ifailure,jsms )
121
122 iprt=iparts(lft+nft)
123 pid = ipart(2,iprt)
124C JHBE = IGEO(10,PID)
125c
126 IF (jhbe==17.AND.iint==2) jhbe = 18
127 IF (jhbe==1.AND.iint==3) jhbe = 5
128 gbuf => elbuf_tab(ng)%GBUF
129 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
130 IF(igtyp == 22) THEN
131 nlay = elbuf_tab(ng)%NLAY
132 ELSE
133 nlay = 1
134 ENDIF
135 nptr = elbuf_tab(ng)%NPTR
136 npts = elbuf_tab(ng)%NPTS
137 nptt = elbuf_tab(ng)%NPTT
138 npt = nptr * npts * nptt * nlay
139!
140 DO j=1,6
141 ii(j) = nel*(j-1)
142 ENDDO
143!
144c
145 DO i=lft,llt
146 n = i + nft
147 iprt=iparts(n)
148 IF(ipart_state(iprt)==0)cycle
149c
150 wa(jj+ 1)= iprt
151 wa(jj+ 2)= ixs(nixs,n)
152 wa(jj+ 3)= isorth
153 wa(jj+ 4)= nlay
154 wa(jj+ 5)= nptr
155 wa(jj+ 6)= npts
156 wa(jj+ 7)= nptt
157 wa(jj+ 8)= isolnod
158 wa(jj+ 9)= jhbe
159 wa(jj+10)= igtyp
160 wa(jj+11)= gbuf%OFF(i)
161 jj = jj + 11
162c
163 DO j=1,nlay
164 lbuf => elbuf_tab(ng)%BUFLY(j)%LBUF(1,1,1)
165 IF (isorth == 1) THEN
166 IF(igtyp == 21 .OR. igtyp == 22) THEN
167 IF (iglob == 1)THEN ! Orthotropic directions in global reference
168 IF (igtyp == 22) THEN
169 gama(1)= lbuf%GAMA(ii(1)+i)
170 gama(2)= lbuf%GAMA(ii(2)+i)
171 ELSEIF (igtyp == 21) THEN
172 gama(1)= gbuf%GAMA(ii(1)+i)
173 gama(2)= gbuf%GAMA(ii(2)+i)
174 ENDIF
175 gama(3)= zero
176 gama(4)= zero
177 gama(5)= zero
178 gama(6)= zero
179 CALL srotorth(x,ixs(1,n),gama,jhbe,igtyp,
180 . icsig) ! Transformation : COS(PHI), SIN(PHI) -> Orthotropic Axes in global reference
181 wa(jj+1)=gama(1)
182 wa(jj+2)=gama(2)
183 wa(jj+3)=gama(3)
184 wa(jj+4)=gama(4)
185 wa(jj+5)=gama(5)
186 wa(jj+6)=gama(6)
187 ELSE
188 IF (igtyp == 22) THEN
189 wa(jj+1)= lbuf%GAMA(ii(1)+i)
190 wa(jj+2)= lbuf%GAMA(ii(2)+i)
191 ELSEIF (igtyp == 21) THEN
192 wa(jj+1)= gbuf%GAMA(ii(1)+i)
193 wa(jj+2)= gbuf%GAMA(ii(2)+i)
194 ENDIF
195 wa(jj+3)= zero
196 wa(jj+4)= zero
197 wa(jj+5)= zero
198 wa(jj+6)= zero
199 ENDIF
200 ELSEIF (jhbe == 1 .OR.
201 . jhbe == 2 .OR. jhbe == 12) THEN
202 wa(jj+1)= gbuf%GAMA(ii(1)+i)
203 wa(jj+2)= gbuf%GAMA(ii(2)+i)
204 wa(jj+3)= gbuf%GAMA(ii(3)+i)
205 wa(jj+4)= gbuf%GAMA(ii(4)+i)
206 wa(jj+5)= gbuf%GAMA(ii(5)+i)
207 wa(jj+6)= gbuf%GAMA(ii(6)+i)
208 ELSE
209 gama(1) = gbuf%GAMA(ii(1)+i)
210 gama(2) = gbuf%GAMA(ii(2)+i)
211 gama(3) = gbuf%GAMA(ii(3)+i)
212 gama(4) = gbuf%GAMA(ii(4)+i)
213 gama(5) = gbuf%GAMA(ii(5)+i)
214 gama(6) = gbuf%GAMA(ii(6)+i)
215 CALL srotorth(x,ixs(1,n),gama,jhbe,igtyp,
216 . icsig)
217 wa(jj+1)=gama(1)
218 wa(jj+2)=gama(2)
219 wa(jj+3)=gama(3)
220 wa(jj+4)=gama(4)
221 wa(jj+5)=gama(5)
222 wa(jj+6)=gama(6)
223 ENDIF
224 ELSE
225 wa(jj+1)= zero
226 wa(jj+2)= zero
227 wa(jj+3)= zero
228 wa(jj+4)= zero
229 wa(jj+5)= zero
230 wa(jj+6)= zero
231 ENDIF
232 jj = jj + 6
233 ENDDO
234 ie=ie+1
235C pointeur de fin de zone dans WA
236 ptwa(ie)=jj
237 ENDDO
238 ENDIF
239 ENDDO
240 200 CONTINUE
241c-----------------------
242 IF(nspmd == 1)THEN
243C recopies inutiles pour simplification du code.
244 ptwa_p0(0)=0
245 DO n=1,stat_numels
246 ptwa_p0(n)=ptwa(n)
247 END DO
248 len=jj
249 DO j=1,len
250 wap0(j)=wa(j)
251 END DO
252 ELSE
253C construit les pointeurs dans le tableau global WAP0
254 CALL spmd_stat_pgather(ptwa,stat_numels,ptwa_p0,stat_numels_g)
255 len = 0
256 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
257 END IF
258 IF(ispmd==0.AND.len>0) THEN
259 iprt0=0
260 DO n=1,stat_numels_g
261C retrouve le nieme elt dans l'ordre d'id croissant
262 k=stat_indxs(n)
263C retrouve l'adresse dans WAP0
264 j=ptwa_p0(k-1)
265c
266 iprt = nint(wap0(j + 1))
267 id = nint(wap0(j + 2))
268 isorth = nint(wap0(j + 3))
269 nlay = nint(wap0(j + 4))
270 nptr = nint(wap0(j + 5))
271 npts = nint(wap0(j + 6))
272 nptt = nint(wap0(j + 7))
273 isolnod= nint(wap0(j + 8))
274 jhbe = nint(wap0(j + 9))
275 igtyp = nint(wap0(j +10))
276 ioff = nint(wap0(j + 11))
277 IF(idel==0.OR.(idel==1.AND.ioff >=1))THEN
278c
279 IF(iprt /= iprt0 .AND. isorth /= 0)THEN
280 IF (izipstrs == 0) THEN
281 WRITE(iugeo,'(A)') delimit
282 IF(iglob==1.) THEN
283 WRITE(iugeo,'(A)')'/INIBRI/ORTHO_FGLO'
284 ELSE
285 WRITE(iugeo,'(A)')'/INIBRI/ORTHO'
286 ENDIF
287 WRITE(iugeo,'(A)')
288 . '# BRICKID NLAY ISOLNOD IGTYP JJHBE'
289 WRITE(iugeo,'(A)')
290 .'#------------------------ REPEAT --------------------------'
291 IF(iglob==1.OR.(igtyp /= 21 .AND. igtyp /= 22)) THEN
292 WRITE(iugeo,'(A)')
293 . '# X1, Y1, Z1, X2, Y2'
294 WRITE(iugeo,'(A)')
295 . '# Z2'
296 ELSE
297 WRITE(iugeo,'(A)')
298 . '# COS(PHI), SIN(PHI)'
299 ENDIF
300 WRITE(iugeo,'(A)')
301 .'#---------------------- END REPEAT ------------------------'
302 WRITE(iugeo,'(A)') delimit
303 ELSE
304 WRITE(line,'(A)') delimit
305 CALL strs_txt50(line,100)
306 IF(iglob==1.) THEN
307 WRITE(line,'(A)')'/INIBRI/ORTHO_FGLO'
308 ELSE
309 WRITE(line,'(A)')'/INIBRI/ORTHO'
310 ENDIF
311 CALL strs_txt50(line,100)
312 WRITE(line,'(A)')
313 . '#------------------------ REPEAT --------------------------'
314 CALL strs_txt50(line,100)
315 WRITE(line,'(A)')
316 . '# BRICKID NLAY ISOLNOD IGTYP JJHBE'
317 CALL strs_txt50(line,100)
318 IF(igtyp /= 21 .AND. igtyp /= 22) THEN
319 WRITE(line,'(A)')
320 . '# X1, Y1, Z1, X2, Y2'
321 CALL strs_txt50(line,100)
322 WRITE(line,'(A)')
323 . '# Z2'
324 CALL strs_txt50(line,100)
325 ELSE
326 WRITE(line,'(A)')
327 . '# COS(PHI), SIN(PHI)'
328 CALL strs_txt50(line,100)
329 ENDIF
330 WRITE(line,'(A)')
331 . '#------------------------ REPEAT --------------------------'
332 CALL strs_txt50(line,100)
333 WRITE(line,'(A)') delimit
334 CALL strs_txt50(line,100)
335 END IF
336 iprt0=iprt
337 END IF
338 IF(isorth == 1)THEN
339 IF (izipstrs == 0) THEN
340 WRITE(iugeo,'(5I10)') id,nlay,isolnod,igtyp,jhbe
341 ELSE
342 WRITE(line,'(5I10)') id,nlay,isolnod,igtyp,jhbe
343 CALL strs_txt50(line,100)
344 ENDIF
345 j = j + 11
346 IF(iglob==1.OR.(igtyp /= 21 .AND. igtyp /= 22)) THEN
347 jj = j
348 DO i=1,nlay
349 IF (izipstrs == 0) THEN
350 WRITE(iugeo,'(1P5E20.13)')(wap0(jj + k),k=1,5)
351 WRITE(iugeo,'(1PE20.13)')(wap0(jj + k),k=6,6)
352 ELSE
353 CALL tab_strs_txt50(wap0(1),5,jj,sizp0,5)
354 CALL tab_strs_txt50(wap0(6),1,jj,sizp0,1)
355 ENDIF
356 jj = jj + 6
357 ENDDO
358 ELSE
359 jj = j
360 DO i=1,nlay
361 IF (izipstrs == 0) THEN
362 WRITE(iugeo,'(1P2E20.13)')(wap0(jj + k),k=1,2)
363 ELSE
364 CALL tab_strs_txt50(wap0(1),2,jj,sizp0,2)
365 ENDIF
366 jj = jj + 6
367 ENDDO
368
369 ENDIF
370 ENDIF
371 ENDIF !IOFF
372 ENDDO
373 ENDIF
374c-----------
375 DEALLOCATE(ptwa)
376 DEALLOCATE(ptwa_p0)
377c-----------
378 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
initbuf_mod
Definition initbuf.F:160
initbuf_mod::initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, mid, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure, jsms)
Definition initbuf.F:261
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
srotorth
subroutine srotorth(x, ixs, gama, khbe, ityp, icsig)
Definition srotorth.F:35
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