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 29 of file dparrws.F.

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