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
41C-----------------------------------------------
42C I m p l i c i t T y p e s
43C-----------------------------------------------
44#include "implicit_f.inc"
45C-----------------------------------------------
46C G l o b a l P a r a m e t e r s
47C-----------------------------------------------
48#include "mvsiz_p.inc"
49C-----------------------------------------------
50C C o m m o n B l o c k s
51C-----------------------------------------------
52#include "scr03_c.inc"
53#include "vect01_c.inc"
54#include "param_c.inc"
55#include "units_c.inc"
56#include "random_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER IX(NIXR,*),ITAB(*),IGEO(NPROPGI,*),IPM(NPROPMI,*)
61 my_real
62 . off(*), geo(npropg,*), x(3,*), x0(*), y0(*), z0(*), skew(lskew,*)
63 my_real
64 . rloc(3,*),iposx(5,*) ,iposy(5,*),
65 . iposz(5,*),iposxx(5,*),iposyy(5,*),iposzz(5,*), eint6(6,*),
66 . x1phi,y1phi,z1phi
67C-----------------------------------------------
68C L o c a l V a r i a b l e s
69C-----------------------------------------------
70 INTEGER I, J, NG, I1, I2, I3, ISK, IALIGN, K, USENS, MID, MTYP, IGTYP
71C REAL
72 my_real
73 . x1, y1, z1,
74 . nrloc(mvsiz),prvc(3,mvsiz),nprvc(mvsiz)
75 my_real
76 . noise
77C-----------------------------------------------
78 noise = two*sqrt(three)*xalea
79C
80 DO i=lft,llt
81 j=i+nft
82 usens=igeo(3,ix(1,j))
83 IF (usens <= 0) THEN
84C no sensor or Isflag=1
85 off(i)=one
86 ELSE
87 off(i)=-ten
88 ENDIF
89 ENDDO
90C
91 IF (codvers >= 44) THEN
92 DO j=1,6
93 DO i=lft,llt
94 eint6(j,i)=zero
95 ENDDO
96 ENDDO
97 ENDIF
98C
99 DO j=1,5
100 DO i=lft,llt
101 iposx(j,i)=zero
102 iposy(j,i)=zero
103 iposz(j,i)=zero
104 iposxx(j,i)=zero
105 iposyy(j,i)=zero
106 iposzz(j,i)=zero
107 ENDDO
108 ENDDO
109C
110 DO i=lft,llt
111 j=i+nft
112 ng=ix(1,j)
113 isk=igeo(2,ng)
114 i1=ix(2,j)
115 i2=ix(3,j)
116 i3=ix(4,j)
117 x1=x(1,i2)-x(1,i1)
118 y1=x(2,i2)-x(2,i1)
119 z1=x(3,i2)-x(3,i1)
120 x0(i)=sqrt(x1**2+y1**2+z1**2)
121 ialign=0
122 IF (x0(i) < em15 .OR. x0(i) <= noise) THEN
123C IWARN=IWARN+1
124 rloc(1,i)= one
125 rloc(2,i)= zero
126 rloc(3,i)= zero
127C WRITE(ISTDO,*) '** WARNING: SPRING LENGTH IS NULL',
128C . ', CANNOT DEFINE FRAME'
129C WRITE(IOUT,1000)IX(NIXR,J)
130C
131 igtyp = igeo(11,ix(1,j))
132 IF (igtyp == 23) THEN
133 mtyp = ipm(2,ix(5,j))
134 ELSE
135 mtyp = 0
136 ENDIF
137C
138 IF (mtyp /= 114) THEN
139C-- message deactivated for seatbelts
140 CALL ancmsg(msgid=325,
141 . msgtype=msgwarning,
142 . anmode=aninfo_blind_1,
143 . i1=ix(nixr,j))
144 ENDIF
145 ELSE
146 IF (i3 /= 0) THEN
147 rloc(1,i)=x(1,i3)-x(1,i1)
148 rloc(2,i)=x(2,i3)-x(2,i1)
149 rloc(3,i)=x(3,i3)-x(3,i1)
150 nrloc(i)=rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2
151 prvc(1,i)=y1*rloc(3,i)-z1*rloc(2,i)
152 prvc(2,i)=z1*rloc(1,i)-x1*rloc(3,i)
153 prvc(3,i)=x1*rloc(2,i)-y1*rloc(1,i)
154 nprvc(i)=prvc(1,i)**2+prvc(2,i)**2+prvc(3,i)**2
155 IF (sqrt(nprvc(i))/nrloc(i)/x0(i) < em5) THEN
156C IWARN=IWARN+1
157C WRITE(ISTDO,*) '** WARNING: THREE SPRING NODES ON A LINE',
158C . ', CANNOT DEFINE FRAME'
159 CALL ancmsg(msgid=326,
160 . msgtype=msgwarning,
161 . anmode=aninfo_blind_1,
162 . i1=ix(nixr,j),
163 . i2=itab(i1),
164 . i3=itab(i2),
165 . i4=itab(i3))
166 IF (isk /= 1) THEN
167 rloc(1,i)=skew(4,isk)
168 rloc(2,i)=skew(5,isk)
169 rloc(3,i)=skew(6,isk)
170 nrloc(i)=rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2
171 prvc(1,i)=y1*rloc(3,i)-z1*rloc(2,i)
172 prvc(2,i)=z1*rloc(1,i)-x1*rloc(3,i)
173 prvc(3,i)=x1*rloc(2,i)-y1*rloc(1,i)
174 nprvc(i)=prvc(1,i)**2+prvc(2,i)**2+prvc(3,i)**2
175 IF (sqrt(nprvc(i)/nrloc(i))/x0(i) < em5) THEN
176C WRITE(ISTDO,*) '** WARNING: SECOND AXIS OF SKEW FRAME',
177C . ' IS PARALLEL TO SPRING AXIS, CANNOT DEFINE FRAME'
178C WRITE(IOUT,1200)IX(NIXR,J)
179 CALL ancmsg(msgid=327,
180 . msgtype=msgwarning,
181 . anmode=aninfo_blind_1,
182 . i1=ix(nixr,j))
183 ELSE
184 WRITE(iout,1300)ix(nixr,j)
185 rloc(1,i)=prvc(2,i)*z1-prvc(3,i)*y1
186 rloc(2,i)=prvc(3,i)*x1-prvc(1,i)*z1
187 rloc(3,i)=prvc(1,i)*y1-prvc(2,i)*x1
188 nrloc(i)=sqrt(rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2)
189 rloc(1,i)=rloc(1,i)/nrloc(i)
190 rloc(2,i)=rloc(2,i)/nrloc(i)
191 rloc(3,i)=rloc(3,i)/nrloc(i)
192 ialign=1
193 ENDIF
194 ENDIF
195 ELSE
196 rloc(1,i)=prvc(2,i)*z1-prvc(3,i)*y1
197 rloc(2,i)=prvc(3,i)*x1-prvc(1,i)*z1
198 rloc(3,i)=prvc(1,i)*y1-prvc(2,i)*x1
199 nrloc(i)=sqrt(rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2)
200 rloc(1,i)=rloc(1,i)/nrloc(i)
201 rloc(2,i)=rloc(2,i)/nrloc(i)
202 rloc(3,i)=rloc(3,i)/nrloc(i)
203 ialign=1
204 ENDIF
205 ELSEIF (isk /= 1) THEN
206 rloc(1,i)=skew(4,isk)
207 rloc(2,i)=skew(5,isk)
208 rloc(3,i)=skew(6,isk)
209 nrloc(i)=rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2
210 prvc(1,i)=y1*rloc(3,i)-z1*rloc(2,i)
211 prvc(2,i)=z1*rloc(1,i)-x1*rloc(3,i)
212 prvc(3,i)=x1*rloc(2,i)-y1*rloc(1,i)
213 nprvc(i)=prvc(1,i)**2+prvc(2,i)**2+prvc(3,i)**2
214 IF (sqrt(nprvc(i)/nrloc(i))/x0(i) < em5) THEN
215C WRITE(ISTDO,*) '** WARNING: SECOND AXIS OF SKEW FRAME',
216C . ' IS PARALLEL TO SPRING AXIS, CANNOT DEFINE FRAME'
217C WRITE(IOUT,1200)IX(NIXR,J)
218 CALL ancmsg(msgid=327,
219 . msgtype=msgwarning,
220 . anmode=aninfo_blind_1,
221 . i1=ix(nixr,j))
222 ELSE
223 WRITE(iout,1300)ix(nixr,j)
224 rloc(1,i)=prvc(2,i)*z1-prvc(3,i)*y1
225 rloc(2,i)=prvc(3,i)*x1-prvc(1,i)*z1
226 rloc(3,i)=prvc(1,i)*y1-prvc(2,i)*x1
227 nrloc(i)=sqrt(rloc(1,i)**2+rloc(2,i)**2+rloc(3,i)**2)
228 rloc(1,i)=rloc(1,i)/nrloc(i)
229 rloc(2,i)=rloc(2,i)/nrloc(i)
230 rloc(3,i)=rloc(3,i)/nrloc(i)
231 ialign=1
232 ENDIF
233 ENDIF ! IF (I3 /= 0)
234C
235 IF (ialign /= 1)THEN
236 IF (abs(y1) < half*x0(i)) THEN
237 rloc(1,i)=zero
238 rloc(2,i)=one
239 rloc(3,i)=zero
240 WRITE(iout,1400)ix(nixr,j)
241 ELSE
242 rloc(1,i)=one
243 rloc(2,i)=zero
244 rloc(3,i)=zero
245 WRITE(iout,1450)ix(nixr,j)
246 ENDIF
247 ENDIF ! IF (ialign /= 1)
248 ENDIF ! IF (X0(I) < EM15 .OR. X0(I) <= NOISE)
249 ENDDO
250C-----------------------------------------------
251 RETURN
252C-----------------------------------------------
253 1300 FORMAT(/,' ** INFO: SPRING ELEMENT:',i10,/,
254 . ' SECOND 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:1249
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:889