OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
r4buf3.F File Reference
#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "scr03_c.inc"
#include "vect01_c.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "random_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine r4buf3 (off, geo, x, x0, y0, z0, ix, skew, rloc, iposx, iposy, iposz, iposxx, iposyy, iposzz, itab, eint6, igeo, ipm)

Function/Subroutine Documentation

◆ r4buf3()

subroutine r4buf3 ( off,
geo,
x,
x0,
y0,
z0,
integer, dimension(nixr,*) ix,
skew,
rloc,
iposx,
iposy,
iposz,
iposxx,
iposyy,
iposzz,
integer, dimension(*) itab,
eint6,
integer, dimension(npropgi,*) igeo,
integer, dimension(npropmi,*) ipm )

Definition at line 33 of file r4buf3.F.

37C-----------------------------------------------
38C M o d u l e s
39C-----------------------------------------------
40 USE message_mod
41 use element_mod , only : nixr
42C-----------------------------------------------
43C I m p l i c i t T y p e s
44C-----------------------------------------------
45#include "implicit_f.inc"
46C-----------------------------------------------
47C G l o b a l P a r a m e t e r s
48C-----------------------------------------------
49#include "mvsiz_p.inc"
50C-----------------------------------------------
51C C o m m o n B l o c k s
52C-----------------------------------------------
53#include "scr03_c.inc"
54#include "vect01_c.inc"
55#include "param_c.inc"
56#include "units_c.inc"
57#include "random_c.inc"
58C-----------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 INTEGER IX(NIXR,*),ITAB(*),IGEO(NPROPGI,*),IPM(NPROPMI,*)
62 my_real
63 . off(*), geo(npropg,*), x(3,*), x0(*), y0(*), z0(*), skew(lskew,*)
64 my_real
65 . rloc(3,*),iposx(5,*) ,iposy(5,*),
66 . iposz(5,*),iposxx(5,*),iposyy(5,*),iposzz(5,*), eint6(6,*),
67 . x1phi,y1phi,z1phi
68C-----------------------------------------------
69C L o c a l V a r i a b l e s
70C-----------------------------------------------
71 INTEGER I, J, NG, I1, I2, I3, ISK, IALIGN, USENS, MTYP, IGTYP
72C REAL
73 my_real
74 . x1, y1, z1,
75 . nrloc(mvsiz),prvc(3,mvsiz),nprvc(mvsiz)
76 my_real
77 . noise
78C-----------------------------------------------
79 noise = two*sqrt(three)*xalea
80C
81 DO i=lft,llt
82 j=i+nft
83 usens=igeo(3,ix(1,j))
84 IF (usens <= 0) THEN
85C no sensor or Isflag=1
86 off(i)=one
87 ELSE
88 off(i)=-ten
89 ENDIF
90 ENDDO
91C
92 IF (codvers >= 44) THEN
93 DO j=1,6
94 DO i=lft,llt
95 eint6(j,i)=zero
96 ENDDO
97 ENDDO
98 ENDIF
99C
100 DO j=1,5
101 DO i=lft,llt
102 iposx(j,i)=zero
103 iposy(j,i)=zero
104 iposz(j,i)=zero
105 iposxx(j,i)=zero
106 iposyy(j,i)=zero
107 iposzz(j,i)=zero
108 ENDDO
109 ENDDO
110C
111 DO i=lft,llt
112 j=i+nft
113 ng=ix(1,j)
114 isk=igeo(2,ng)
115 i1=ix(2,j)
116 i2=ix(3,j)
117 i3=ix(4,j)
118 x1=x(1,i2)-x(1,i1)
119 y1=x(2,i2)-x(2,i1)
120 z1=x(3,i2)-x(3,i1)
121 x0(i)=sqrt(x1**2+y1**2+z1**2)
122 ialign=0
123 IF (x0(i) < em15 .OR. x0(i) <= noise) THEN
124C IWARN=IWARN+1
125 rloc(1,i)= one
126 rloc(2,i)= zero
127 rloc(3,i)= zero
128C WRITE(ISTDO,*) '** WARNING: SPRING LENGTH IS NULL',
129C . ', CANNOT DEFINE FRAME'
130C WRITE(IOUT,1000)IX(NIXR,J)
131C
132 igtyp = igeo(11,ix(1,j))
133 IF (igtyp == 23) THEN
134 mtyp = ipm(2,ix(5,j))
135 ELSE
136 mtyp = 0
137 ENDIF
138C
139 IF (mtyp /= 114) THEN
140C-- message deactivated for seatbelts
141 CALL ancmsg(msgid=325,
142 . msgtype=msgwarning,
143 . anmode=aninfo_blind_1,
144 . i1=ix(nixr,j))
145 ENDIF
146 ELSE
147C First step - computation of vector PRVC with N3 if available or skew
148 IF (i3 /= 0) THEN
149 rloc(1,i)=x(1,i3)-x(1,i1)
150 rloc(2,i)=x(2,i3)-x(2,i1)
151 rloc(3,i)=x(3,i3)-x(3,i1)
152 nrloc(i)=rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2
153 prvc(1,i)=y1*rloc(3,i)-z1*rloc(2,i)
154 prvc(2,i)=z1*rloc(1,i)-x1*rloc(3,i)
155 prvc(3,i)=x1*rloc(2,i)-y1*rloc(1,i)
156 nprvc(i)=prvc(1,i)**2+prvc(2,i)**2+prvc(3,i)**2
157 IF (sqrt(nprvc(i))/nrloc(i)/x0(i) < em5) THEN
158C IWARN=IWARN+1
159C WRITE(ISTDO,*) '** WARNING: THREE SPRING NODES ON A LINE',
160C . ', CANNOT DEFINE FRAME'
161 CALL ancmsg(msgid=326,
162 . msgtype=msgwarning,
163 . anmode=aninfo_blind_1,
164 . i1=ix(nixr,j),
165 . i2=itab(i1),
166 . i3=itab(i2),
167 . i4=itab(i3))
168C
169 rloc(1,i)=skew(4,isk)
170 rloc(2,i)=skew(5,isk)
171 rloc(3,i)=skew(6,isk)
172 nrloc(i)=rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2
173 prvc(1,i)=y1*rloc(3,i)-z1*rloc(2,i)
174 prvc(2,i)=z1*rloc(1,i)-x1*rloc(3,i)
175 prvc(3,i)=x1*rloc(2,i)-y1*rloc(1,i)
176 nprvc(i)=prvc(1,i)**2+prvc(2,i)**2+prvc(3,i)**2
177C
178 IF (sqrt(nprvc(i)/nrloc(i))/x0(i) < em5) THEN
179C WRITE(ISTDO,*) '** WARNING: SECOND AXIS OF SKEW FRAME',
180C . ' IS PARALLEL TO SPRING AXIS, CANNOT DEFINE FRAME'
181C WRITE(IOUT,1200)IX(NIXR,J)
182 CALL ancmsg(msgid=327,
183 . msgtype=msgwarning,
184 . anmode=aninfo_blind_1,
185 . i1=ix(nixr,j))
186 ELSE
187 WRITE(iout,1300)ix(nixr,j)
188 ialign=1
189 ENDIF
190C
191 ELSE
192 ialign=1
193 ENDIF
194 ELSE
195 rloc(1,i)=skew(4,isk)
196 rloc(2,i)=skew(5,isk)
197 rloc(3,i)=skew(6,isk)
198 nrloc(i)=rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2
199 prvc(1,i)=y1*rloc(3,i)-z1*rloc(2,i)
200 prvc(2,i)=z1*rloc(1,i)-x1*rloc(3,i)
201 prvc(3,i)=x1*rloc(2,i)-y1*rloc(1,i)
202 nprvc(i)=prvc(1,i)**2+prvc(2,i)**2+prvc(3,i)**2
203 IF (sqrt(nprvc(i)/nrloc(i))/x0(i) < em5) THEN
204C WRITE(ISTDO,*) '** WARNING: SECOND AXIS OF SKEW FRAME',
205C . ' IS PARALLEL TO SPRING AXIS, CANNOT DEFINE FRAME'
206C WRITE(IOUT,1200)IX(NIXR,J)
207 CALL ancmsg(msgid=327,
208 . msgtype=msgwarning,
209 . anmode=aninfo_blind_1,
210 . i1=ix(nixr,j))
211 ELSE
212 IF(isk /= 1) THEN
213 WRITE(iout,1300)ix(nixr,j)
214 ELSE
215 WRITE(iout,1400)ix(nixr,j)
216 ENDIF
217 ialign=1
218 ENDIF
219 ENDIF ! IF (I3 /= 0)
220C
221C Local X axis is used for computation of RVC
222 IF (ialign /= 1)THEN
223 rloc(1,i)=skew(1,isk)
224 rloc(2,i)=skew(2,isk)
225 rloc(3,i)=skew(3,isk)
226 IF(isk /= 1) THEN
227 WRITE(iout,1350)ix(nixr,j)
228 ELSE
229 WRITE(iout,1450)ix(nixr,j)
230 ENDIF
231 prvc(1,i)=y1*rloc(3,i)-z1*rloc(2,i)
232 prvc(2,i)=z1*rloc(1,i)-x1*rloc(3,i)
233 prvc(3,i)=x1*rloc(2,i)-y1*rloc(1,i)
234 ENDIF ! IF (IALIGN /= 1)
235 ENDIF ! IF (X0(I) < EM15 .OR. X0(I) <= NOISE)
236
237C Second step - computation the second axis of the local skew - Ylocal = Xlocal^PRVC
238 rloc(1,i)=prvc(2,i)*z1-prvc(3,i)*y1
239 rloc(2,i)=prvc(3,i)*x1-prvc(1,i)*z1
240 rloc(3,i)=prvc(1,i)*y1-prvc(2,i)*x1
241 nrloc(i)=sqrt(rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2)
242 rloc(1,i)=rloc(1,i)/nrloc(i)
243 rloc(2,i)=rloc(2,i)/nrloc(i)
244 rloc(3,i)=rloc(3,i)/nrloc(i)
245
246 ENDDO
247C-----------------------------------------------
248 RETURN
249C-----------------------------------------------
250 1300 FORMAT(/,' ** INFO: SPRING ELEMENT:',i10,/,
251 . ' SECOND AXIS OF SKEW FRAME AND SPRING AXIS ARE USED',
252 . ' TO DEFINE SPRING FRAME')
253 1350 FORMAT(/,' ** INFO: SPRING ELEMENT:',i10,/,
254 . ' FIRST AXIS OF SKEW FRAME AND SPRING AXIS ARE USED',
255 . ' TO DEFINE SPRING FRAME')
256 1400 FORMAT(/,' ** INFO: SPRING ELEMENT:',i10,/,
257 . ' GLOBAL Y AXIS AND SPRING AXIS ARE USED',
258 . ' TO DEFINE SPRING FRAME'/)
259 1450 FORMAT(/,' ** INFO: SPRING ELEMENT:',i10,/,
260 . ' GLOBAL X AXIS AND SPRING AXIS ARE USED',
261 . ' TO DEFINE SPRING FRAME'/)
262C-----------------------------------------------
my_real
#define my_real
Definition cppsort.cpp:32
message_mod
Definition message_mod.F:1257
noise
subroutine noise(dt2r, in, j, buf, v, a, ixs, elbuf_tab, iparg, weight, ixq)
Definition noise.F:41
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895