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 30 of file thpout.F.

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