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

Go to the source code of this file.

Functions/Subroutines

subroutine dparrws (nesbw, nstrf, ixc, ixtg, x, nodcut, rwbuf, nprw, ixs)

Function/Subroutine Documentation

◆ dparrws()

subroutine dparrws ( integer nesbw,
integer, dimension(*) nstrf,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
x,
integer nodcut,
rwbuf,
integer, dimension(*) nprw,
integer, dimension(nixs,*) ixs )

Definition at line 30 of file dparrws.F.

33 use element_mod , only : nixs,nixc,nixtg
34C-----------------------------------------------
35C I m p l i c i t T y p e s
36C-----------------------------------------------
37#include "implicit_f.inc"
38C-----------------------------------------------
39C C o m m o n B l o c k s
40C-----------------------------------------------
41#include "com04_c.inc"
42#include "param_c.inc"
43C-----------------------------------------------
44C D u m m y A r g u m e n t s
45C-----------------------------------------------
46 INTEGER NESBW,NSTRF(*),IXC(NIXC,*),IXTG(NIXTG,*),
47 . NODCUT,NPRW(*), IXS(NIXS,*)
48 my_real
49 . x(3,*),rwbuf(nrwlp,*)
50C-----------------------------------------------
51C L o c a l V a r i a b l e s
52C-----------------------------------------------
53 INTEGER J, JJ, LEN, I, K, L, KK, K0, K1, K5, K9, N,
54 . N0, N1, N2, N3, N4, N10, NSEG, NSEGC, NSEGTG, ITYP,
55 . UNPACK(15,4), II(8), N5, N6, N7, N8, NSEGS, K3,OW
56 my_real
57 . xx1, yy1, zz1, xx2, yy2, zz2, xx3, yy3, zz3,
58 . xx4, yy4, zz4, d13, xxc, yyc, zzc
59 INTEGER POWER2(8),IPACK
60 DATA power2/1,2,4,8,16,32,64,128/
61C-----------------------------------------------
62 DATA unpack/1,2,1,3,1,2,1,4,1,2,1,3,1,2,1,
63 . 0,0,2,0,3,3,2,0,4,4,2,4,3,3,2,
64 . 0,0,0,0,0,0,3,0,0,0,4,0,4,4,3,
65 . 0,0,0,0,0,0,0,0,0,0,0,0,0,0,4/
66 IF (nsect>0) THEN
67 k0 = nstrf(25)
68 DO i=1,nsect
69 jj = 0
70 n0 = numnod + nodcut + i - 1
71 k5=k0+30+nstrf(k0+14)+nstrf(k0+6)
72 1 + 2*nstrf(k0+7) +nstrf(k0+8)*2
73 nsegc = nstrf(k0+9)
74
75 DO j=1,nsegc
76 kk = k5+2*(j-1)
77 n = nstrf(kk)
78 IF(nstrf(kk+1)/=0) THEN
79 n1 = unpack(nstrf(kk+1),1)
80 n2 = unpack(nstrf(kk+1),2)
81 IF(n2==0)THEN
82 n2 = n1
83 n3 = n1
84 ELSE
85 n3 = unpack(nstrf(kk+1),3)
86 IF(n3==0)n3 = n2
87 ENDIF
88 ii(1) = n0
89 ii(2) = ixc(1+n1,n)-1
90 ii(3) = ixc(1+n2,n)-1
91 ii(4) = ixc(1+n3,n)-1
92 CALL write_i_c(ii,4)
93 ENDIF
94 ENDDO
95 jj = 0
96 k9=k5+2*nstrf(k0+9) +2*nstrf(k0+10)
97 1 +2*nstrf(k0+11)+2*nstrf(k0+12)
98 nsegtg = nstrf(k0+13)
99 DO j=1,nsegtg
100 kk = k9+2*(j-1)
101 n = nstrf(kk)
102 IF(nstrf(kk+1)/=0) THEN
103 n1 = unpack(nstrf(1+kk),1)
104 n2 = unpack(nstrf(1+kk),2)
105 IF(n2==0)THEN
106 n2 = n1
107 n3 = n1
108 ELSE
109 n3 = unpack(nstrf(1+kk),3)
110 IF(n3==0)n3 = n2
111 ENDIF
112 ii(1) = n0
113 ii(2) = ixtg(1+n1,n)-1
114 ii(3) = ixtg(1+n2,n)-1
115 ii(4) = ixtg(1+n3,n)-1
116 CALL write_i_c(ii,4)
117 ENDIF
118 ENDDO
119 jj = 0
120 k3=k0+30+nstrf(k0+14)+nstrf(k0+6)
121 nsegs=nstrf(k0+7)
122 IF(nsegs/=0)THEN
123 ii(1) = n0
124 ii(2) = n0
125 ii(3) = n0
126 ii(4) = n0
127 CALL write_i_c(ii,4)
128 END IF
129C
130 DO j=1,nsegs
131 kk=k3+2*(j-1)
132 ipack=nstrf(kk+1)
133 IF(ipack/=0)THEN
134 n =nstrf(kk)
135 ii(1)=ixs(2,n)-1
136 ii(2)=ixs(3,n)-1
137 ii(3)=ixs(4,n)-1
138 ii(4)=ixs(5,n)-1
139 ii(5)=ixs(6,n)-1
140 ii(6)=ixs(7,n)-1
141 ii(7)=ixs(8,n)-1
142 ii(8)=ixs(9,n)-1
143 IF( ii(2)==ii(1).AND.ii(4)==ii(3)
144 . .AND.ii(8)==ii(5).AND.ii(7)==ii(6))THEN
145C tetra4, tetra10
146 n1=mod(ipack/power2(1),2)
147 n2=mod(ipack/power2(3),2)
148 n3=mod(ipack/power2(5),2)
149 n4=mod(ipack/power2(6),2)
150 IF(n1/=0.AND.n2/=0.AND.n3/=0)THEN
151 CALL write_i_c(ii(1),1)
152 CALL write_i_c(ii(3),1)
153 CALL write_i_c(ii(5),1)
154 CALL write_i_c(ii(5),1)
155 END IF
156 IF(n1/=0.AND.n2/=0.AND.n4/=0)THEN
157 CALL write_i_c(ii(1),1)
158 CALL write_i_c(ii(3),1)
159 CALL write_i_c(ii(6),1)
160 CALL write_i_c(ii(6),1)
161 END IF
162 IF(n2/=0.AND.n3/=0.AND.n4/=0)THEN
163 CALL write_i_c(ii(3),1)
164 CALL write_i_c(ii(5),1)
165 CALL write_i_c(ii(6),1)
166 CALL write_i_c(ii(6),1)
167 END IF
168 IF(n3/=0.AND.n1/=0.AND.n4/=0)THEN
169 CALL write_i_c(ii(5),1)
170 CALL write_i_c(ii(1),1)
171 CALL write_i_c(ii(6),1)
172 CALL write_i_c(ii(6),1)
173 END IF
174 ELSE
175C brick, shell16, brick20
176 n1=mod(ipack/power2(1),2)
177 n2=mod(ipack/power2(2),2)
178 n3=mod(ipack/power2(3),2)
179 n4=mod(ipack/power2(4),2)
180 n5=mod(ipack/power2(5),2)
181 n6=mod(ipack/power2(6),2)
182 n7=mod(ipack/power2(7),2)
183 n8=mod(ipack/power2(8),2)
184 IF(n1/=0.AND.n2/=0.AND.n3/=0.AND.n4/=0)THEN
185 CALL write_i_c(ii(1),1)
186 CALL write_i_c(ii(2),1)
187 CALL write_i_c(ii(3),1)
188 CALL write_i_c(ii(4),1)
189 END IF
190 IF(n5/=0.AND.n6/=0.AND.n7/=0.AND.n8/=0)THEN
191 CALL write_i_c(ii(5),1)
192 CALL write_i_c(ii(6),1)
193 CALL write_i_c(ii(7),1)
194 CALL write_i_c(ii(8),1)
195 END IF
196 IF(n1/=0.AND.n5/=0.AND.n6/=0.AND.n2/=0)THEN
197 CALL write_i_c(ii(1),1)
198 CALL write_i_c(ii(5),1)
199 CALL write_i_c(ii(6),1)
200 CALL write_i_c(ii(2),1)
201 END IF
202 IF(n4/=0.AND.n8/=0.AND.n7/=0.AND.n3/=0)THEN
203 CALL write_i_c(ii(4),1)
204 CALL write_i_c(ii(8),1)
205 CALL write_i_c(ii(7),1)
206 CALL write_i_c(ii(3),1)
207 END IF
208 IF(n1/=0.AND.n4/=0.AND.n8/=0.AND.n5/=0)THEN
209 CALL write_i_c(ii(1),1)
210 CALL write_i_c(ii(4),1)
211 CALL write_i_c(ii(8),1)
212 CALL write_i_c(ii(5),1)
213 END IF
214 IF(n2/=0.AND.n3/=0.AND.n7/=0.AND.n6/=0)THEN
215 CALL write_i_c(ii(2),1)
216 CALL write_i_c(ii(3),1)
217 CALL write_i_c(ii(7),1)
218 CALL write_i_c(ii(6),1)
219 END IF
220 END IF
221 END IF
222 END DO
223C
224 k0=nstrf(k0+24)
225 ENDDO
226 ENDIF
227C
228 n0 = numnod + nodcut + nsect
229 n1 = numnod + nodcut + nsect + nrwall
230C
231 DO n=1,nrwall
232 ii(1) = n0
233 ii(2) = n0
234 ii(3) = n0
235 ii(4) = n0
236 CALL write_i_c(ii,4)
237 n0 = n0 + 1
238 k=1
239 n2=n +nrwall
240 n3=n2+nrwall
241 n4=n3+nrwall
242 ityp= nprw(n4)
243C
244 IF(iabs(ityp)==1.OR.ityp==4)THEN
245 ii(1) = n1
246 ii(2) = n1 + 3
247 ii(3) = n1 + 2
248 ii(4) = n1 + 1
249 CALL write_i_c(ii,4)
250 n1 = n1 + 4
251 ELSEIF(ityp==2)THEN
252 n10 = n1
253 DO j = 1,23
254 ii(1) = n1
255 ii(2) = n1 + 2
256 ii(3) = n1 + 3
257 ii(4) = n1 + 1
258 CALL write_i_c(ii,4)
259 n1 = n1 + 2
260 ENDDO
261 ii(1) = n1
262 ii(2) = n10
263 ii(3) = n10 + 1
264 ii(4) = n1 + 1
265 CALL write_i_c(ii,4)
266 n1 = n1 + 2
267 ELSEIF(ityp==3)THEN
268 DO i = 1,6
269 DO j = 1,6
270 DO l = 1,6
271 ii(1) = n1
272 ii(2) = n1 + 1
273 ii(3) = n1 + 8
274 ii(4) = n1 + 7
275 CALL write_i_c(ii,4)
276 n1 = n1 + 1
277 ENDDO
278 n1 = n1 + 1
279 ENDDO
280 n1 = n1 + 7
281 ENDDO
282 ENDIF
283 k=k+nprw(n)
284 IF(nprw(n4)==-1)k=k+nint(rwbuf(8,n))
285 ENDDO
286C
287 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
write_i_c
void write_i_c(int *w, int *len)
Definition write_routines.c:645