OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
inspcnd.F File Reference
#include "implicit_f.inc"
#include "scr17_c.inc"
#include "com04_c.inc"
#include "sphcom.inc"
#include "units_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine inspcnd (ispcond, igrnod, kxsp, ixsp, nod2sp, itab, icode, iskew, iskn, skew, xframe, x, ispsym, isptag, pm, geo, ipart, ipartsp)

Function/Subroutine Documentation

◆ inspcnd()

subroutine inspcnd ( integer, dimension(nispcond,*) ispcond,
type (group_), dimension(ngrnod) igrnod,
integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
integer, dimension(*) nod2sp,
integer, dimension(*) itab,
integer, dimension(*) icode,
integer, dimension(*) iskew,
integer, dimension(liskn,*) iskn,
skew,
xframe,
x,
integer, dimension(nspcond,*) ispsym,
integer, dimension(*) isptag,
pm,
geo,
integer, dimension(lipart1,*) ipart,
integer, dimension(*) ipartsp )

Definition at line 35 of file inspcnd.F.

39C-----------------------------------------------
40C M o d u l e s
41C-----------------------------------------------
42 USE message_mod
43 USE groupdef_mod
44C-----------------------------------------------
45C I m p l i c i t T y p e s
46C-----------------------------------------------
47#include "implicit_f.inc"
48C-----------------------------------------------
49C C o m m o n B l o c k s
50C-----------------------------------------------
51#include "scr17_c.inc"
52#include "com04_c.inc"
53#include "sphcom.inc"
54#include "units_c.inc"
55#include "param_c.inc"
56C-----------------------------------------------
57C D u m m y A r g u m e n t s
58C-----------------------------------------------
59 INTEGER ISPCOND(NISPCOND,*),
60 . KXSP(NISP,*),IXSP(KVOISPH,*),NOD2SP(*),
61 . ITAB(*),ICODE(*),ISKEW(*),ISKN(LISKN,*),
62 . ISPSYM(NSPCOND,*),ISPTAG(*),IPART(LIPART1,*),IPARTSP(*)
63C REAL
64 my_real
65 . skew(lskew,*),xframe(nxframe,*),x(3,*),
66 . pm(npropm,*),geo(npropg,*)
67C-----------------------------------------------
68 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
69C-----------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 INTEGER I,IGRS,J,INOD,N,
73 . K,K2,K3,IFR,NC,ICSP,ISK,IC1,IC2,IC,J6(6),
74 . ISLIDE,IMAT,IPROP,IPRT
75C REAL
76 my_real
77 . tx,ty,tz,ux,uy,uz,vx,vy,vz,wx,wy,wz,nw,nt,ps,
78 . dd,ox,oy,oz,xi,yi,zi,di,mp,rho,vol,
79 . untiers
80C-----------------------------------------------
81C E x t e r n a l F u n c t i o n s
82C-----------------------------------------------
83 INTEGER MY_OR
84 my_real
85 . get_u_geo
86 EXTERNAL get_u_geo
87C-----------------------------------------------
88 DO i=1,numsph
89 isptag(i)=1
90 ENDDO
91C-----------------------------------------------
92C creation des skews (prepare l'addition des conditions cinematiques).
93 DO i=1,numsph
94 j =numskw+1+i
95 inod=kxsp(3,i)
96C SKEWS were built when LECSKW.
97C ISKN(4,J)=-1
98 IF (icode(inod)/=0) THEN
99 isk=iskew(inod)
100 DO k=1,lskew
101 skew(k,j)=skew(k,isk)
102 ENDDO
103 iskn(1,j)=iskn(1,isk)
104 iskn(2,j)=iskn(2,isk)
105 iskn(3,j)=iskn(3,isk)
106 iskew(inod)=j
107 ELSE
108C DO K=1,9
109C SKEW(K,J)=0.
110C ENDDO
111C SKEW(1,J)=1.
112C SKEW(5,J)=1.
113C SKEW(9,J)=1.
114C ISKN(1,J)=0
115C ISKN(2,J)=0
116C ISKN(3,J)=0
117 iskew(inod)=j
118 icode(inod)=0
119 ENDIF
120 ENDDO
121C-----------------------------------------------
122 WRITE(iout,*) ' SPH SYMMETRY CONDITIONS INITIALIZATION :'
123 WRITE(iout,*) ' -------------------------------------- '
124 untiers=1./3.
125 DO i=1,nspcond
126 igrs=ispcond(4,i)
127 ifr =ispcond(3,i)
128 icsp=ispcond(2,i)
129 islide=ispcond(5,i)
130
131 ux=xframe(3*(icsp-1)+1,ifr)
132 uy=xframe(3*(icsp-1)+2,ifr)
133 uz=xframe(3*(icsp-1)+3,ifr)
134C---------
135C prepares particles to be symetrized with respect to the condition.
136 ox=xframe(10,ifr)
137 oy=xframe(11,ifr)
138 oz=xframe(12,ifr)
139 DO n=1,numsph
140 inod =kxsp(3,n)
141 xi =x(1,inod)
142 yi =x(2,inod)
143 zi =x(3,inod)
144 dd=(xi-ox)*ux+(yi-oy)*uy+(zi-oz)*uz
145 iprt =ipartsp(n)
146 imat =ipart(1,iprt)
147 rho =pm(1,imat)
148 iprop =ipart(2,iprt)
149 mp =get_u_geo(1,iprop)
150 vol =mp/rho
151 di =get_u_geo(6,iprop)
152C Default=Characteristic length of hexagonal compact net:
153 IF(di==0.) di=(sqrt(2.)*vol)**untiers
154 IF (dd<em3*di) THEN
155 isptag(n)=isptag(n)+1
156 ENDIF
157 ENDDO
158C---------
159C boundary conditions addition on nodes group.
160 IF(igrs/=0)THEN
161 DO 888 j=1,igrnod(igrs)%NENTITY
162 inod=igrnod(igrs)%ENTITY(j)
163 ic =icode(inod)
164 isk=iskew(inod)
165 IF(ic/=0.AND.iskn(1,isk)/=0) THEN
166C WRITE(IOUT,*)
167C .' ** ERROR INCOMPATIBLE KINEMATIC CONDITIONS :',
168C .' SPH KINEMATIC CONDITION + BOUNDARY CONDITION',
169C .' INTO A MOVING SKEW IS NOT ALLOWED (NODE ID=',ITAB(INOD),').'
170C IERR=IERR+1
171 CALL ancmsg(msgid=394,
172 . msgtype=msgerror,
173 . anmode=aninfo_blind_1,
174 . i1=itab(inod))
175 GOTO 888
176 ENDIF
177C---------------
178 ic1=ic/512
179 ic2=(ic-512*ic1)/64
180 j6(1)=ic1/4
181 j6(2)=(ic1-4*j6(1))/2
182 j6(3)=(ic1-4*j6(1)-2*j6(2))
183 j6(4)=ic2/4
184 j6(5)=(ic2-4*j6(4))/2
185 j6(6)=(ic2-4*j6(4)-2*j6(5))
186 nc=0
187 DO k=1,3
188 IF(j6(k)/=0) nc=nc+1
189 ENDDO
190 IF(nc==3) THEN
191C---------------
192 CALL ancmsg(msgid=395,
193 . msgtype=msgwarning,
194 . anmode=aninfo_blind_2,
195 . i1=itab(inod))
196 ELSEIF(nc==2)THEN
197C---------------
198C 2 conditions deja realisees + 1 condition :
199 IF(j6(1)==1)THEN
200 k=1
201 IF(j6(2)==1)THEN
202 k2=4
203 k3=7
204 ELSE
205 k2=7
206 k3=4
207 ENDIF
208 ELSEIF(j6(2)==1)THEN
209 k =4
210 k2=7
211 k3=1
212 ENDIF
213 wx=skew(k3,isk)
214 wy=skew(k3+1,isk)
215 wz=skew(k3+2,isk)
216 ps=ux*wx+uy*wy+uz*wz
217 IF(abs(ps)<em20) THEN
218 CALL ancmsg(msgid=396,
219 . msgtype=msgwarning,
220 . anmode=aninfo_blind_2,
221 . i1=itab(inod))
222 GOTO 888
223 ENDIF
224 j6(1)=0
225 j6(2)=0
226 j6(3)=0
227 IF(k3==1)j6(1)=1
228 IF(k3==4)j6(2)=1
229 IF(k3==7)j6(3)=1
230 ic1=j6(1)*4+j6(2)*2+j6(3)
231 ic2=0
232 ic=ic1*512+ic2*64
233 icode(inod)=my_or(ic,icode(inod))
234 ELSEIF(nc==1)THEN
235C---------------
236 k=7*j6(3)+4*j6(2)+j6(1)
237 vx=skew(k,isk)
238 vy=skew(k+1,isk)
239 vz=skew(k+2,isk)
240 wx=vy*uz-vz*uy
241 wy=vz*ux-vx*uz
242 wz=vx*uy-vy*ux
243 nw=sqrt(wx*wx+wy*wy+wz*wz)
244 IF(nw<em20) THEN
245 CALL ancmsg(msgid=397,
246 . msgtype=msgwarning,
247 . anmode=aninfo_blind_2)
248 GOTO 888
249 ENDIF
250 wx=wx/max(nw,em20)
251 wy=wy/max(nw,em20)
252 wz=wz/max(nw,em20)
253 tx=wy*vz-wz*vy
254 ty=wz*vx-wx*vz
255 tz=wx*vy-wy*vx
256 nt=sqrt(tx*tx+ty*ty+tz*tz)
257 tx=tx/max(nt,em20)
258 ty=ty/max(nt,em20)
259 tz=tz/max(nt,em20)
260 k2=k+3
261 IF(k2>9)k2=1
262 k3=k2+3
263 IF(k3>9)k3=1
264 skew(k2,isk) =tx
265 skew(k2+1,isk)=ty
266 skew(k2+2,isk)=tz
267 skew(k3,isk) =wx
268 skew(k3+1,isk)=wy
269 skew(k3+2,isk)=wz
270 j6(1)=0
271 j6(2)=0
272 j6(3)=0
273 IF(k2==1)j6(1)=1
274 IF(k2==4)j6(2)=1
275 IF(k2==7)j6(3)=1
276 ic1=j6(1)*4+j6(2)*2+j6(3)
277 ic2=0
278 ic=ic1*512+ic2*64
279 icode(inod)=my_or(ic,icode(inod))
280 ELSEIF(nc==0)THEN
281 DO k=1,9
282 skew(k,isk)=xframe(k,ifr)
283 ENDDO
284 IF(islide==0)THEN
285 ic1=7
286 ELSE
287 ic1=2**(3-icsp)
288 ENDIF
289 ic2=0
290 ic=ic1*512+ic2*64
291 icode(inod)=my_or(ic,icode(inod))
292 ENDIF
293 888 CONTINUE
294 ENDIF
295 ENDDO
296C-----------------------------------------------
297 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
groupdef_mod
Definition groupdef_mod.F:662
message_mod
Definition message_mod.F:1249
my_or
int my_or(int *a, int *b)
Definition precision.c:63
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