OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
thpout.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "task_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine thpout (iparg, nthgrp2, ithgrp, geo, ixp, ithbuf, elbuf_tab, wa)

Function/Subroutine Documentation

◆ thpout()

subroutine thpout ( integer, dimension(nparg,*) iparg,
integer, intent(in) nthgrp2,
integer, dimension(nithgr,*), intent(in) ithgrp,
geo,
integer, dimension(nixp,numelp), intent(in) ixp,
integer, dimension(*) ithbuf,
type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
wa )

Definition at line 31 of file thpout.F.

33C-----------------------------------------------
34C M o d u l e s
35C-----------------------------------------------
36 USE elbufdef_mod
37 use element_mod , only : nixp
38C-----------------------------------------------
39C I m p l i c i t T y p e s
40C-----------------------------------------------
41#include "implicit_f.inc"
42C-----------------------------------------------
43C C o m m o n B l o c k s
44C-----------------------------------------------
45#include "com01_c.inc"
46#include "com04_c.inc"
47#include "task_c.inc"
48#include "param_c.inc"
49C-----------------------------------------------
50C D u m m y A r g u m e n t s
51C-----------------------------------------------
52 INTEGER IPARG(NPARG,*),ITHBUF(*)
53 INTEGER, INTENT(in) :: NTHGRP2
54 INTEGER, DIMENSION(NITHGR,*), INTENT(in) :: ITHGRP
55 INTEGER, DIMENSION(NIXP,NUMELP) ,INTENT(IN):: IXP
56 my_real
57 . wa(*)
58 my_real
59 . geo(npropg,numgeo)
60C
61 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
62C-----------------------------------------------
63C L o c a l V a r i a b l e s
64C-----------------------------------------------
65 INTEGER II,I,K,L,N,IP,IH,NG,IPT,NPT,ITY,MTE,JJ,IK,
66 . ILAYER,NEL,NFT,IGTYP,IPA,KK(3)
67 INTEGER :: NITER,IAD,NN,IADV,NVAR,ITYP,IJK,PID
68C
69 my_real
70 . area,areapt,sx,sxy,szx,idx
71 TYPE(G_BUFEL_) ,POINTER :: GBUF
72
73 TYPE(L_BUFEL_) ,POINTER :: LBUF
74C-----------------------------------------------
75 area = -huge(area)
76C-------------------------
77C ELEMENTS POUTRE
78C-------------------------
79
80 ijk = 0
81 ipa = 400
82 DO niter=1,nthgrp2
83 ityp=ithgrp(2,niter)
84 nn =ithgrp(4,niter)
85 iad =ithgrp(5,niter)
86 nvar=ithgrp(6,niter)
87 iadv=ithgrp(7,niter)
88 ii=0
89 IF(ityp==5)THEN
90! -------------------------------
91 ii=0
92 ih=iad
93
94 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
95 ih = ih + 1
96 ENDDO
97 IF (ih >= iad+nn) GOTO 666
98C
99 DO ng=1,ngroup
100 ity = iparg(5,ng)
101 ilayer = 1
102 gbuf => elbuf_tab(ng)%GBUF
103
104 IF (ity == 5) THEN
105 mte=iparg(1,ng)
106 nel=iparg(2,ng)
107 nft=iparg(3,ng)
108 npt = iparg(6,ng)
109 igtyp =iparg(38,ng)
110 IF (igtyp == 18) THEN
111 !BUFLY => ELBUF_TAB(NG)%BUFLY(ILAYER)
112 END IF
113
114 DO i=1,3
115 kk(i) = nel*(i-1)
116 ENDDO
117
118 DO i=1,nel
119 n=i+nft
120 k=ithbuf(ih)
121 ip=ithbuf(ih+nn)
122 pid = ixp(5,nft+i)
123 IF (igtyp == 3) area = geo(1,pid)
124 IF(igtyp == 18 ) THEN
125 area = zero
126 DO ipt = 1, npt
127 area = area + geo(ipa+ipt,pid)
128 ENDDO
129 ENDIF
130
131
132 IF (k == n) THEN
133 ih=ih+1
134 ii = ((ih-1) - iad)*nvar
135 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
136 ih = ih + 1
137 ENDDO
138
139 IF (ih > iad+nn) GOTO 666
140
141 DO l=iadv,iadv+nvar-1
142 k=ithbuf(l)
143 ijk=ijk+1
144 IF (ithbuf(l) == 1) THEN
145 wa(ijk)=gbuf%OFF(i)
146 ELSEIF(ithbuf(l) == 2)THEN
147 wa(ijk)=gbuf%FOR(kk(1)+i)
148 ELSEIF (ithbuf(l) == 3) THEN
149 wa(ijk)=gbuf%FOR(kk(2)+i)
150 ELSEIF (ithbuf(l) == 4) THEN
151 wa(ijk)=gbuf%FOR(kk(3)+i)
152 ELSEIF (ithbuf(l) == 5) THEN
153 wa(ijk)=gbuf%MOM(kk(1)+i)
154 ELSEIF (ithbuf(l) == 6) THEN
155 wa(ijk)=gbuf%MOM(kk(2)+i)
156 ELSEIF (ithbuf(l) == 7) THEN
157 wa(ijk)=gbuf%MOM(kk(3)+i)
158 ELSEIF (ithbuf(l) == 8) THEN
159 wa(ijk)=gbuf%EINT(i) + gbuf%EINT(i+nel)
160 ELSEIF (ithbuf(l) == 9) THEN
161 wa(ijk)=zero
162 IF (igtyp == 3) THEN
163 ! stress = force/area for the 3 directions
164 sx = gbuf%FOR(kk(1)+i)/area
165 wa(ijk)=sx
166 ELSEIF(igtyp == 18 ) THEN
167 IF (elbuf_tab(ng)%BUFLY(ilayer)%L_SIG > 0) THEN
168 DO ipt = 1,npt
169 areapt = geo(ipa+ipt,pid)
170 lbuf => elbuf_tab(ng)%BUFLY(ilayer)%LBUF(1,1,ipt)
171 wa(ijk) = wa(ijk)+ lbuf%SIG(kk(1)+i) * areapt/area
172 ENDDO
173 END IF !(BUFLY%L_SIG > 0)
174 END if! (IGTYP)
175 ELSEIF (ithbuf(l) == 10) THEN
176 wa(ijk)=zero
177 IF (igtyp == 3) THEN
178 ! stress = force/area for the 3 directions
179 sxy = gbuf%FOR(kk(2)+i)/area
180 wa(ijk)=sxy
181 ELSEIF(igtyp == 18 ) THEN
182 IF (elbuf_tab(ng)%BUFLY(ilayer)%L_SIG > 0) THEN
183 DO ipt = 1,npt
184 areapt = geo(ipa+ipt,pid)
185 lbuf => elbuf_tab(ng)%BUFLY(ilayer)%LBUF(1,1,ipt)
186 wa(ijk) = wa(ijk)+ lbuf%SIG(kk(2)+i)*areapt/area
187 ENDDO
188 END IF !(BUFLY%L_SIG > 0)
189 END if! (IGTYP)
190 ELSEIF (ithbuf(l) == 11) THEN
191 wa(ijk)=zero
192 IF (igtyp == 3) THEN
193 ! stress = force/area for the 3 directions
194 szx = gbuf%FOR(kk(3)+i)/area
195 wa(ijk)=szx
196 ELSEIF(igtyp == 18 ) THEN
197 IF (elbuf_tab(ng)%BUFLY(ilayer)%L_SIG > 0) THEN
198 DO ipt = 1,npt
199 areapt = geo(ipa+ipt,pid)
200 lbuf => elbuf_tab(ng)%BUFLY(ilayer)%LBUF(1,1,ipt)
201 wa(ijk) = wa(ijk)+ lbuf%SIG(kk(3)+i) * areapt/area
202 ENDDO
203 END IF !(BUFLY%L_SIG > 0)
204 END if! (IGTYP)
205 ELSEIF (ithbuf(l) > 11 .AND.ithbuf(l) <= 254 ) THEN
206 IF(igtyp == 18 ) THEN
207 idx = (ithbuf(l) - 12)/ 3
208 jj = nint(idx)
209 ipt = jj + 1
210 ik = mod((ithbuf(l) - 12),3) + 1
211 lbuf => elbuf_tab(ng)%BUFLY(ilayer)%LBUF(1,1,ipt)
212 wa(ijk) = lbuf%SIG(kk(ik)+i)
213 ENDIF
214 ELSEIF (ithbuf(l) == 255) THEN
215 wa(ijk)=zero
216 IF(igtyp == 3 ) THEN
217 IF(gbuf%G_PLA>0)THEN
218 wa(ijk)=gbuf%PLA(i)
219 ENDIF
220 ELSEIF(igtyp == 18 ) THEN
221 IF (elbuf_tab(ng)%BUFLY(ilayer)%L_PLA > 0) THEN
222 DO ipt = 1,npt
223 areapt = geo(ipa+ipt,pid)
224 lbuf => elbuf_tab(ng)%BUFLY(ilayer)%LBUF(1,1,ipt)
225 wa(ijk) = wa(ijk)+ lbuf%PLA(i) * areapt/area
226 ENDDO
227 END IF
228 END if! (IGTYP)
229 ELSEIF (ithbuf(l) > 255 .AND.ithbuf(l) <= 336 ) THEN
230 IF(igtyp == 18 ) THEN
231 IF (elbuf_tab(ng)%BUFLY(ilayer)%L_PLA > 0) THEN
232 ipt = ithbuf(l) - 255
233 lbuf => elbuf_tab(ng)%BUFLY(ilayer)%LBUF(1,1,ipt)
234 wa(ijk) = lbuf%PLA(i)
235 ENDIF
236 ENDIF
237 ELSEIF (ithbuf(l) == 337 ) THEN
238 IF(gbuf%G_EPSD>0)THEN
239 wa(ijk)=gbuf%EPSD(i)
240 ENDIF
241 ENDIF
242 ENDDO
243 ijk = ijk + 1
244 wa(ijk) = ii
245 ENDIF
246 ENDDO
247 ENDIF
248 ENDDO
249 666 continue
250! -------------------------------
251 ENDIF
252 ENDDO
253C---
254C-----------
255 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
if
if(complex_arithmetic) id
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
nvar
integer function nvar(text)
Definition nvar.F:32