OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i20pwr3.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| i20pwr3ae ../starter/source/interfaces/inter3d1/i20pwr3.F
25!||--- called by ------------------------------------------------------
26!|| i20ini3 ../starter/source/interfaces/inter3d1/i20ini3.F
27!||--- uses -----------------------------------------------------
28!|| format_mod ../starter/share/modules1/format_mod.F90
29!||====================================================================
30 SUBROUTINE i20pwr3ae(ITAB ,INACTI,CAND_M,CAND_S,
31 2 STFS ,STFM ,XANEW ,NSV ,IWPENE,
32 3 N1 ,N2 ,M1 ,M2 ,NX ,
33 4 NY ,NZ ,GAPV ,GAP_S ,GAP_M ,
34 5 IGAP ,X ,FPENMAX)
35 USE format_mod , ONLY : fmw_4i, fmw_i_3f, fmw_5i
36C-----------------------------------------------
37C I m p l i c i t T y p e s
38C-----------------------------------------------
39#include "implicit_f.inc"
40C-----------------------------------------------
41C G l o b a l P a r a m e t e r s
42C-----------------------------------------------
43#include "mvsiz_p.inc"
44C-----------------------------------------------
45C D u m m y A r g u m e n t s
46C-----------------------------------------------
47 INTEGER ITAB(*),CAND_M(*),CAND_S(*),INACTI,IGAP ,
48 4 N1(*) ,N2(*) ,M1(*) ,M2(*)
49 INTEGER NSV(*),IWPENE
50 my_real FPENMAX
51 my_real stfs(*),stfm(*),xanew(3,*),x(3,*),gap_s(*) ,gap_m(*),
52 . nx(mvsiz), ny(mvsiz), nz(mvsiz),gapv(*)
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "units_c.inc"
57#include "vect07_c.inc"
58#include "scr03_c.inc"
59C-----------------------------------------------
60C L o c a l V a r i a b l e s
61C-----------------------------------------------
62 INTEGER I, IS, IM
63C REAL
64 my_real
65 . PENE(MVSIZ),
66 . peneold, s2, d, pplus,ps2, penmax
67C-----------------------------------------------
68C
69
70 DO i=1,llt
71 s2 = sqrt(nx(i)**2 + ny(i)**2 + nz(i)**2)
72 gapv(i) = sqrt(gapv(i))
73 pene(i) = gapv(i) - s2
74 s2 = 1./max(em30,s2)
75 nx(i) = nx(i)*s2
76 ny(i) = ny(i)*s2
77 nz(i) = nz(i)*s2
78 ENDDO
79C
80 DO 100 i=lft,llt
81 IF(ipri>=1)THEN
82 WRITE(iout,fmt=fmw_4i)
83 2 itab(n1(i)),itab(n2(i)),itab(m1(i)),itab(m2(i))
84 ENDIF
85 IF(pene(i)>zero)THEN
86 WRITE(iout,1000)pene(i)
87 WRITE(iout,fmt=fmw_i_3f)itab(n1(i)),
88 . xanew(1,n1(i))+pene(i)*nx(i),
89 . xanew(2,n1(i))+pene(i)*ny(i),
90 . xanew(3,n1(i))+pene(i)*nz(i)
91 WRITE(iout,fmt=fmw_i_3f)itab(n2(i)),
92 . xanew(1,n2(i))+pene(i)*nx(i),
93 . xanew(2,n2(i))+pene(i)*ny(i),
94 . xanew(3,n2(i))+pene(i)*nz(i)
95 pene(i) = pene(i) + em8*pene(i)
96 penmax = fpenmax*gapv(i)
97 IF (inacti == 1 .OR. pene(i) > penmax) THEN
98C DESACTIVATION DES NOEUDS
99 IF (pene(i) > penmax)
100 . WRITE(iout,'(A,1PG20.13,A)')
101 . ' MAX INITIAL PENETRATION ',penmax,' IS REACHED'
102 WRITE(iout,'(A)')' SECONDARY STIFFNESS IS SET TO ZERO'
103 stfs(cand_s(i)) = zero
104 ELSE IF(inacti==2) THEN
105C DESACTIVATION DES ELEMENTS
106 WRITE(iout,'(A)')'MAIN STIFFNESS IS SET TO ZERO'
107 stfm(cand_m(i)) = zero
108 ELSE IF(inacti==6) THEN
109C INACTI==6
110C CHANGE LES COORDONNEES DES NOEUDS SECONDARY
111 WRITE(iout,'(A)')'NODE COORD IS CHANGED AS PROPOSED'
112 ps2 = half*pene(i)
113 peneold = sqrt( (xanew(1,n1(i))-x(1,n1(i)))**2 +
114 . (xanew(2,n1(i))-x(2,n1(i)))**2 +
115 . (xanew(3,n1(i))-x(3,n1(i)))**2 )
116 IF(ps2>peneold) THEN
117 xanew(1,n1(i)) = x(1,n1(i))+ps2*nx(i)
118 xanew(2,n1(i)) = x(2,n1(i))+ps2*ny(i)
119 xanew(3,n1(i)) = x(3,n1(i))+ps2*nz(i)
120 ENDIF
121 peneold = sqrt( (xanew(1,n2(i))-x(1,n2(i)))**2 +
122 . (xanew(2,n2(i))-x(2,n2(i)))**2 +
123 . (xanew(3,n2(i))-x(3,n2(i)))**2 )
124 IF(ps2>peneold) THEN
125 xanew(1,n2(i)) = x(1,n2(i))+ps2*nx(i)
126 xanew(2,n2(i)) = x(2,n2(i))+ps2*ny(i)
127 xanew(3,n2(i)) = x(3,n2(i))+ps2*nz(i)
128 ENDIF
129C CHANGE LES COORDONNEES DES NOEUDS MAIN
130 WRITE(iout,'(A)')'SEG. COORD IS CHANGED AS PROPOSED'
131 peneold = sqrt( (xanew(1,m1(i))-x(1,m1(i)))**2 +
132 . (xanew(2,m1(i))-x(2,m1(i)))**2 +
133 . (xanew(3,m1(i))-x(3,m1(i)))**2 )
134 IF(ps2>peneold) THEN
135 xanew(1,m1(i)) = x(1,m1(i))-ps2*nx(i)
136 xanew(2,m1(i)) = x(2,m1(i))-ps2*ny(i)
137 xanew(3,m1(i)) = x(3,m1(i))-ps2*nz(i)
138 ENDIF
139C
140 peneold = sqrt( (xanew(1,m2(i))-x(1,m2(i)))**2 +
141 . (xanew(2,m2(i))-x(2,m2(i)))**2 +
142 . (xanew(3,m2(i))-x(3,m2(i)))**2 )
143 IF(ps2>peneold) THEN
144 xanew(1,m2(i)) = x(1,m2(i))-ps2*nx(i)
145 xanew(2,m2(i)) = x(2,m2(i))-ps2*ny(i)
146 xanew(3,m2(i)) = x(3,m2(i))-ps2*nz(i)
147 ENDIF
148
149 END IF
150 iwpene=iwpene+1
151 ENDIF
152 100 CONTINUE
153C
154 1000 FORMAT(2x,'** INITIAL PENETRATION =',1pg20.13,
155 . ' POSSIBLE NEW COORDINATES OF SECONDARY NODES')
156 RETURN
157 END
158!||====================================================================
159!|| i20pwr3a ../starter/source/interfaces/inter3d1/i20pwr3.F
160!||--- called by ------------------------------------------------------
161!|| i20ini3 ../starter/source/interfaces/inter3d1/i20ini3.F
162!||--- calls -----------------------------------------------------
163!|| ancmsg ../starter/source/output/message/message.F
164!||--- uses -----------------------------------------------------
165!|| format_mod ../starter/share/modules1/format_mod.F90
166!|| message_mod ../starter/share/message_module/message_mod.F
167!||====================================================================
168 SUBROUTINE i20pwr3a(ITAB,INACTI,CAND_E,CAND_N,STFN,
169 1 STF ,XANEW ,NSV ,IWPENE,IWRN ,
170 2 CAND_EN,CAND_NN,TAG,NOINT,GAPV ,NTY,
171 3 ITIED , FPENMAX,ID,TITR,
172 4 IX1,IX2,IX3,IX4,X1,
173 5 X2 ,X3 ,X4 ,Y1 ,Y2,
174 6 Y3 ,Y4 ,Z1 ,Z2 ,Z3,
175 7 Z4 ,XI ,YI ,ZI ,N1,
176 8 N2 ,N3 ,PENE,NSVG)
177 USE message_mod
178 USE names_and_titles_mod , ONLY : nchartitle
179 USE format_mod , ONLY : fmw_5i, fmw_i_3f
180C-----------------------------------------------
181C I m p l i c i t T y p e s
182C-----------------------------------------------
183#include "implicit_f.inc"
184C-----------------------------------------------
185C G l o b a l P a r a m e t e r s
186C-----------------------------------------------
187#include "mvsiz_p.inc"
188C-----------------------------------------------
189C D u m m y A r g u m e n t s
190C-----------------------------------------------
191 INTEGER ITAB(*),CAND_E(*),CAND_N(*),CAND_EN(*),CAND_NN(*)
192 INTEGER NSV(*),TAG(*),IWPENE,INACTI,NOINT,NTY,ITIED,IWRN
193 my_real FPENMAX
194 my_real STF(*),STFN(*),XANEW(3,*),GAPV(*)
195 INTEGER ID
196 CHARACTER(LEN=NCHARTITLE) :: TITR
197C-----------------------------------------------
198C C o m m o n B l o c k s
199C-----------------------------------------------
200#include "units_c.inc"
201#include "vect07_c.inc"
202#include "scr03_c.inc"
203C-----------------------------------------------
204C D u m m y A r g u m e n t s
205C-----------------------------------------------
206 INTEGER, DIMENSION(MVSIZ), INTENT(IN) :: IX1,IX2,IX3,IX4,NSVG
207 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: x1,x2,x3,x4
208 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: y1,y2,y3,y4
209 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: z1,z2,z3,z4
210 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: n1,n2,n3,pene
211 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: xi,yi,zi
212C-----------------------------------------------
213C L o c a l V a r i a b l e s
214C-----------------------------------------------
215 INTEGER I,IS,IM
216C REAL
217 my_real ::PENEOLD,PPLUS,PS2,PENMAX
218 my_real
219 . dn
220C-----------------------------------------------
221 DO 100 i=lft,llt
222 IF(ipri>=1.AND.pene(i)>zero)THEN
223 WRITE(iout,fmt=fmw_5i)
224 1 itab(nsvg(i)),
225 2 itab(ix1(i)),itab(ix2(i)),itab(ix3(i)),itab(ix4(i))
226 ELSEIF(ipri>=6)THEN
227 WRITE(iout,fmt=fmw_5i)
228 1 itab(nsvg(i)),
229 2 itab(ix1(i)),itab(ix2(i)),itab(ix3(i)),itab(ix4(i))
230 ENDIF
231 penmax = fpenmax*gapv(i)
232C
233 IF(pene(i)>zero)THEN
234 tag(nsvg(i))=tag(nsvg(i))+1
235 dn=n1(i)*n1(i)+n2(i)*n2(i)+n3(i)*n3(i)
236 IF(dn<=em30) THEN
237 WRITE(iout,1100)pene(i),itab(nsvg(i))
238 IF(nty/=10.OR.itied==0)THEN
239 IF (inacti/=1.AND.inacti/=2.AND.
240 . pene(i)<=penmax) THEN
241
242 IF (inacti==0) THEN
243 CALL ancmsg(msgid=612,
244 . msgtype=msgerror,
245 . anmode=aninfo_blind_1,
246 . i1=id,
247 . c1=titr,
248 . i2=inacti,
249 . i3=itab(nsvg(i)))
250 ELSE
251 CALL ancmsg(msgid=611,
252 . msgtype=msgerror,
253 . anmode=aninfo_blind_1,
254 . i1=id,
255 . c1=titr,
256 . i2=inacti,
257 . i3=itab(nsvg(i)))
258 ENDIF
259 ENDIF
260 END IF
261 ELSEIF (pene(i) <= penmax) THEN
262 WRITE(iout,1000)pene(i)
263 pene(i) = pene(i) + em8*pene(i)
264 WRITE(iout,fmt=fmw_i_3f)itab(nsvg(i)),
265 . xi(i)+pene(i)*n1(i),
266 . yi(i)+pene(i)*n2(i),
267 . zi(i)+pene(i)*n3(i)
268 ENDIF
269
270 IF (inacti == 1 .OR. pene(i) > penmax) THEN
271C DESACTIVATION DES NOEUDS
272 IF (pene(i) > penmax)
273 . WRITE(iout,'(A,I8,A,1PG20.13,A)')' NODE ',itab(nsvg(i)),
274 . ' : MAX INITIAL PENETRATION ',penmax,' IS REACHED'
275 WRITE(iout,'(A)')' SECONDARY STIFFNESS IS SET TO ZERO'
276 stfn(cand_n(i)) = zero
277 ELSE IF(inacti==2) THEN
278C DESACTIVATION DES ELEMENTS
279 WRITE(iout,'(A)')'ELEMENT STIFFNESS IS SET TO ZERO'
280 stf(cand_e(i)) = zero
281 ELSE IF(inacti==3) THEN
282C CHANGE LES COORDONNEES DES NOEUDS SECONDARY
283 WRITE(iout,'(A)')'NODE COORD IS CHANGED AS PROPOSED'
284 peneold = sqrt( (xanew(1,nsv(cand_n(i)))-xi(i))**2 +
285 . (xanew(2,nsv(cand_n(i)))-yi(i))**2 +
286 . (xanew(3,nsv(cand_n(i)))-zi(i))**2 )
287 IF(pene(i)>peneold) THEN
288 xanew(1,nsv(cand_n(i))) = xi(i)+pene(i)*n1(i)
289 xanew(2,nsv(cand_n(i))) = yi(i)+pene(i)*n2(i)
290 xanew(3,nsv(cand_n(i))) = zi(i)+pene(i)*n3(i)
291 ENDIF
292 ELSE IF(inacti==4) THEN
293C CHANGE LES COORDONNEES DES NOEUDS MAIN
294 WRITE(iout,'(A)')'SEG. COORD IS CHANGED AS PROPOSED'
295 peneold = sqrt( (xanew(1,ix1(i))-x1(i))**2 +
296 . (xanew(2,ix1(i))-y1(i))**2 +
297 . (xanew(3,ix1(i))-z1(i))**2 )
298 IF(pene(i)>peneold) THEN
299 xanew(1,ix1(i)) = x1(i)-pene(i)*n1(i)
300 xanew(2,ix1(i)) = y1(i)-pene(i)*n2(i)
301 xanew(3,ix1(i)) = z1(i)-pene(i)*n3(i)
302 ENDIF
303C
304 peneold = sqrt( (xanew(1,ix2(i))-x2(i))**2 +
305 . (xanew(2,ix2(i))-y2(i))**2 +
306 . (xanew(3,ix2(i))-z2(i))**2 )
307 IF(pene(i)>peneold) THEN
308 xanew(1,ix2(i)) = x2(i)-pene(i)*n1(i)
309 xanew(2,ix2(i)) = y2(i)-pene(i)*n2(i)
310 xanew(3,ix2(i)) = z2(i)-pene(i)*n3(i)
311 ENDIF
312C
313 peneold = sqrt( (xanew(1,ix3(i))-x3(i))**2 +
314 . (xanew(2,ix3(i))-y3(i))**2 +
315 . (xanew(3,ix3(i))-z3(i))**2 )
316 IF(pene(i)>peneold) THEN
317 xanew(1,ix3(i)) = x3(i)-pene(i)*n1(i)
318 xanew(2,ix3(i)) = y3(i)-pene(i)*n2(i)
319 xanew(3,ix3(i)) = z3(i)-pene(i)*n3(i)
320 ENDIF
321C
322 peneold = sqrt( (xanew(1,ix4(i))-x4(i))**2 +
323 . (xanew(2,ix4(i))-y4(i))**2 +
324 . (xanew(3,ix4(i))-z4(i))**2 )
325 IF(pene(i)>peneold) THEN
326 xanew(1,ix4(i)) = x4(i)-pene(i)*n1(i)
327 xanew(2,ix4(i)) = y4(i)-pene(i)*n2(i)
328 xanew(3,ix4(i)) = z4(i)-pene(i)*n3(i)
329 ENDIF
330 ELSE IF(inacti == 6) THEN
331C INACTI == 6
332C CHANGE LES COORDONNEES DES NOEUDS SECONDARY
333 WRITE(iout,'(A)')'NODE COORD IS CHANGED AS PROPOSED'
334 ps2 = half*pene(i)
335 peneold = sqrt( (xanew(1,nsv(cand_n(i)))-xi(i))**2 +
336 . (xanew(2,nsv(cand_n(i)))-yi(i))**2 +
337 . (xanew(3,nsv(cand_n(i)))-zi(i))**2 )
338 IF(ps2>peneold) THEN
339 xanew(1,nsv(cand_n(i))) = xi(i)+ps2*n1(i)
340 xanew(2,nsv(cand_n(i))) = yi(i)+ps2*n2(i)
341 xanew(3,nsv(cand_n(i))) = zi(i)+ps2*n3(i)
342 ENDIF
343C CHANGE LES COORDONNEES DES NOEUDS MAIN
344 WRITE(iout,'(A)')'SEG. COORD IS CHANGED AS PROPOSED'
345 peneold = sqrt( (xanew(1,ix1(i))-x1(i))**2 +
346 . (xanew(2,ix1(i))-y1(i))**2 +
347 . (xanew(3,ix1(i))-z1(i))**2 )
348 IF(ps2>peneold) THEN
349 xanew(1,ix1(i)) = x1(i)-ps2*n1(i)
350 xanew(2,ix1(i)) = y1(i)-ps2*n2(i)
351 xanew(3,ix1(i)) = z1(i)-ps2*n3(i)
352 ENDIF
353C
354 peneold = sqrt( (xanew(1,ix2(i))-x2(i))**2 +
355 . (xanew(2,ix2(i))-y2(i))**2 +
356 . (xanew(3,ix2(i))-z2(i))**2 )
357 IF(ps2>peneold) THEN
358 xanew(1,ix2(i)) = x2(i)-ps2*n1(i)
359 xanew(2,ix2(i)) = y2(i)-ps2*n2(i)
360 xanew(3,ix2(i)) = z2(i)-ps2*n3(i)
361 ENDIF
362C
363 peneold = sqrt( (xanew(1,ix3(i))-x3(i))**2 +
364 . (xanew(2,ix3(i))-y3(i))**2 +
365 . (xanew(3,ix3(i))-z3(i))**2 )
366 IF(ps2>peneold) THEN
367 xanew(1,ix3(i)) = x3(i)-ps2*n1(i)
368 xanew(2,ix3(i)) = y3(i)-ps2*n2(i)
369 xanew(3,ix3(i)) = z3(i)-ps2*n3(i)
370 ENDIF
371C
372 peneold = sqrt( (xanew(1,ix4(i))-x4(i))**2 +
373 . (xanew(2,ix4(i))-y4(i))**2 +
374 . (xanew(3,ix4(i))-z4(i))**2 )
375 IF(ps2>peneold) THEN
376 xanew(1,ix4(i)) = x4(i)-ps2*n1(i)
377 xanew(2,ix4(i)) = y4(i)-ps2*n2(i)
378 xanew(3,ix4(i)) = z4(i)-ps2*n3(i)
379 ENDIF
380 END IF
381
382 iwpene=iwpene+1
383 ENDIF
384 100 CONTINUE
385
386 IF(iwpene /= 0 .and.inacti == 3 .or.inacti == 4) iwrn = 1
387C
388 1000 FORMAT(2x,'** INITIAL PENETRATION =',1pg20.13,
389 . ' POSSIBLE NEW COORDINATES OF SECONDARY NODE')
390 1100 FORMAT(2x,'** INITIAL PENETRATION =',e14.7,
391 . ' IMPOSSIBLE TO CALCULATE NEW COORDINATES OF SECONDARY NODE',i8)
392 RETURN
393 END
394!||====================================================================
395!|| i20pwr3 ../starter/source/interfaces/inter3d1/i20pwr3.F
396!||--- called by ------------------------------------------------------
397!|| i20ini3 ../starter/source/interfaces/inter3d1/i20ini3.F
398!||--- calls -----------------------------------------------------
399!|| ancmsg ../starter/source/output/message/message.F
400!||--- uses -----------------------------------------------------
401!|| format_mod ../starter/share/modules1/format_mod.F90
402!|| message_mod ../starter/share/message_module/message_mod.F
403!||====================================================================
404 SUBROUTINE i20pwr3(ITAB,INACTI,CAND_E,CAND_N,STFN ,
405 1 STF ,X ,NSV ,IWPENE,IWRN ,
406 2 CAND_EN,CAND_NN,TAG,NOINT,GAPV ,
407 3 NTY ,ITIED ,PENIS ,PENIM ,GAP_S,
408 4 IGAP,ID ,TITR,IX1,IX2,
409 5 IX3 ,IX4,N1 ,N2 ,N3 ,
410 6 PENE,NSVG)
411C-----------------------------------------------
412C M o d u l e s
413C-----------------------------------------------
414 USE message_mod
415 USE names_and_titles_mod , ONLY : nchartitle
416 USE format_mod , ONLY : fmw_5i, fmw_4i, fmw_i_3f
417C-----------------------------------------------
418C I m p l i c i t T y p e s
419C-----------------------------------------------
420#include "implicit_f.inc"
421C-----------------------------------------------
422C G l o b a l P a r a m e t e r s
423C-----------------------------------------------
424#include "mvsiz_p.inc"
425C-----------------------------------------------
426C C o m m o n B l o c k s
427C-----------------------------------------------
428#include "units_c.inc"
429#include "vect07_c.inc"
430#include "scr03_c.inc"
431C-----------------------------------------------
432C D u m m y A r g u m e n t s
433C-----------------------------------------------
434 INTEGER ITAB(*),CAND_E(*),CAND_N(*),CAND_EN(*),CAND_NN(*)
435 INTEGER NSV(*),TAG(*),IWPENE,INACTI,NOINT,NTY,ITIED,IWRN,IGAP
436 my_real STF(*),STFN(*),X(3,*),GAPV(*),PENIS(2,*) ,PENIM(2,*),GAP_S(*)
437 INTEGER ID
438 CHARACTER(LEN=NCHARTITLE) :: TITR
439 INTEGER, DIMENSION(MVSIZ), INTENT(IN) :: IX1,IX2,IX3,IX4,NSVG
440 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: N1,N2,N3,PENE
441C-----------------------------------------------
442C L o c a l V a r i a b l e s
443C-----------------------------------------------
444 INTEGER I,IS,IM,JWARN
445 my_real PENEOLD,PPLUS,AAA
446 my_real DN
447C-----------------------------------------------
448 JWARN = 0
449 do 100 i=lft,llt
450 is=cand_n(i)
451 im=cand_e(i)
452 IF(stfn(is)==zero) cycle
453C
454 IF(ipri>=1.AND.pene(i)>zero)THEN
455 WRITE(iout,fmt=fmw_5i)
456 1 itab(nsvg(i)),
457 2 itab(ix1(i)),itab(ix2(i)),itab(ix3(i)),itab(ix4(i))
458 ELSEIF(ipri>=6)THEN
459 WRITE(iout,fmt=fmw_5i)
460 1 itab(nsvg(i)),
461 2 itab(ix1(i)),itab(ix2(i)),itab(ix3(i)),itab(ix4(i))
462 ENDIF
463 IF(pene(i)>zero)THEN
464 tag(nsvg(i))=tag(nsvg(i))+1
465 dn=n1(i)*n1(i)+n2(i)*n2(i)+n3(i)*n3(i)
466 IF(dn<=em30) THEN
467 WRITE(iout,1100)pene(i),itab(nsvg(i))
468 IF(nty/=10.OR.itied==0)THEN
469 IF(inacti/=1.AND.inacti/=2) THEN
470
471 IF (inacti==0) THEN
472 CALL ancmsg(msgid=612,
473 . msgtype=msgerror,
474 . anmode=aninfo_blind_1,
475 . i1=id,
476 . c1=titr,
477 . i2=inacti,
478 . i3=itab(nsvg(i)))
479 ELSE
480 CALL ancmsg(msgid=611,
481 . msgtype=msgerror,
482 . anmode=aninfo_blind_1,
483 . i1=id,
484 . c1=titr,
485 . i2=inacti,
486 . i3=itab(nsvg(i)))
487 ENDIF
488 ENDIF
489 END IF
490
491 ELSE
492 pene(i) = pene(i) + em8*pene(i)
493 ENDIF
494
495 IF(inacti == 5.or.inacti == 6) THEN
496C INACTI == 6
497 IF(pene(i) >= gapv(i)*zep995)THEN
498 WRITE(iout,'(A)')' *** PENETRATION > GAP - 0.5% !! '
499 WRITE(iout,'(A)')'SECONDARY STIFFNESS IS SET TO ZERO'
500 pene(i)=gapv(i)
501 stfn(is) = zero
502 ELSE
503 jwarn = 1
504 pplus=(pene(i)+zep05*(gapv(i)-pene(i)))
505 IF(igap > 0) THEN
506C---
507 IF (pplus < gap_s(is)) THEN
508 penis(2,is)=max(penis(2,is),pplus)
509 ELSE
510 penis(2,is)=max(penis(2,is),gap_s(is))
511 penim(2,im)=max(penim(2,im),pplus-gap_s(is))
512 ENDIF
513 ELSE
514 penim(2,im)=max(penim(2,im),pplus)
515 END IF
516C---
517c AAA = GAP_S(IS)/GAPV(I)
518c PENIS(2,IS)=MAX(PENIS(2,IS),AAA*PPLUS)
519c PENIM(2,IM)=MAX(PENIM(2,IM),(ONE-AAA)*PPLUS)
520C---
521 penis(1,is)=penis(2,is)
522 penim(1,im)=penim(2,im)
523 ENDIF
524
525c CAND_P(IWPENE+1) = PENE(I)
526 cand_nn(iwpene+1) = cand_n(i)
527 cand_en(iwpene+1) = cand_e(i)
528 END IF
529
530 iwpene=iwpene+1
531 ENDIF
532 100 CONTINUE
533
534 IF(iwpene /= 0.and.inacti == 3.or.inacti == 4) iwrn = 1
535C
536 1100 FORMAT(2x,'** INITIAL PENETRATION =',e14.7,
537 . ' IMPOSSIBLE TO CALCULATE NEW COORDINATES OF SECONDARY NODE',i8)
538 RETURN
539 END
540!||====================================================================
541!|| i20pwr3e ../starter/source/interfaces/inter3d1/i20pwr3.F
542!||--- called by ------------------------------------------------------
543!|| i20ini3 ../starter/source/interfaces/inter3d1/i20ini3.F
544!||--- uses -----------------------------------------------------
545!|| format_mod ../starter/share/modules1/format_mod.F90
546!||====================================================================
547 SUBROUTINE i20pwr3e(ITAB ,INACTI,CAND_M,CAND_S,
548 2 STFS ,STFM ,X ,NSV ,IWPENE,
549 3 N1 ,N2 ,M1 ,M2 ,NX ,
550 4 NY ,NZ ,GAPV ,GAP_S ,GAP_M ,
551 5 PENIS ,PENIM ,IGAP )
552 USE format_mod , ONLY : fmw_4i, fmw_i_3f
553C-----------------------------------------------
554C I m p l i c i t T y p e s
555C-----------------------------------------------
556#include "implicit_f.inc"
557C-----------------------------------------------
558C G l o b a l P a r a m e t e r s
559C-----------------------------------------------
560#include "mvsiz_p.inc"
561C-----------------------------------------------
562C D u m m y A r g u m e n t s
563C-----------------------------------------------
564 INTEGER ITAB(*),CAND_M(*),CAND_S(*),INACTI,IGAP ,N1(*) ,N2(*) ,M1(*) ,M2(*)
565 INTEGER NSV(*),IWPENE
566 my_real STFS(*),STFM(*),X(3,*),GAP_S(*) ,GAP_M(*),PENIS(2,*) , PENIM(2,*),NX(MVSIZ), NY(MVSIZ), NZ(MVSIZ),GAPV(*)
567C-----------------------------------------------
568C C o m m o n B l o c k s
569C-----------------------------------------------
570#include "units_c.inc"
571#include "vect07_c.inc"
572#include "scr03_c.inc"
573C-----------------------------------------------
574C L o c a l V a r i a b l e s
575C-----------------------------------------------
576 INTEGER I, IS, IM,JWARN
577C REAL
578 my_real
579 . PENE(MVSIZ),
580 . PENEOLD, S2, D, PPLUS
581C-----------------------------------------------
582C
583 JWARN = 0
584 do i=1,llt
585 s2 = sqrt(nx(i)**2 + ny(i)**2 + nz(i)**2)
586 gapv(i) = sqrt(gapv(i))
587 pene(i) = gapv(i) - s2
588 s2 = 1./max(em30,s2)
589 nx(i) = nx(i)*s2
590 ny(i) = ny(i)*s2
591 nz(i) = nz(i)*s2
592 ENDDO
593C
594 DO 100 i=lft,llt
595 IF(stfs(cand_s(i))==zero) cycle
596 IF(ipri>=1)THEN
597 WRITE(iout,fmt=fmw_4i)
598 2 itab(n1(i)),itab(n2(i)),itab(m1(i)),itab(m2(i))
599 ENDIF
600 IF(pene(i)>zero)THEN
601 WRITE(iout,1000)pene(i)
602 WRITE(iout,fmt=fmw_i_3f)itab(n1(i)),
603 . x(1,n1(i))+pene(i)*nx(i),
604 . x(2,n1(i))+pene(i)*ny(i),
605 . x(3,n1(i))+pene(i)*nz(i)
606 WRITE(iout,fmt=fmw_i_3f)itab(n2(i)),
607 . x(1,n2(i))+pene(i)*nx(i),
608 . x(2,n2(i))+pene(i)*ny(i),
609 . x(3,n2(i))+pene(i)*nz(i)
610 pene(i) = pene(i) + em8*pene(i)
611 IF(inacti == 5.or.inacti == 6) THEN
612C INACTI==6
613 IF(pene(i)>=gapv(i)*zep995)THEN
614 WRITE(iout,'(A)')' *** PENETRATION > GAP - 0.5% !! '
615 WRITE(iout,'(A)')'SECONDARY STIFFNESS IS SET TO ZERO'
616 pene(i)=gapv(i)
617 stfs(cand_s(i)) = zero
618 ELSE
619 jwarn = 1
620 is=cand_s(i)
621 im=cand_m(i)
622 pplus=half*(pene(i)+zep05*(gapv(i)-pene(i)))
623 penis(2,is)=max(penis(2,is),pplus)
624 penim(2,im)=max(penim(2,im),pplus)
625 penis(1,is)=penis(2,is)
626 penim(1,im)=penim(2,im)
627 ENDIF
628 END IF
629 iwpene=iwpene+1
630 ENDIF
631 100 CONTINUE
632 IF (jwarn /= 0) WRITE(iout,'(A)')'REDUCE INITIAL GAP'
633C
634 1000 FORMAT(2x,'** INITIAL PENETRATION =',1pg20.13,
635 . ' POSSIBLE NEW COORDINATES OF SECONDARY NODES')
636 RETURN
637 END
i20pwr3ae
subroutine i20pwr3ae(itab, inacti, cand_m, cand_s, stfs, stfm, xanew, nsv, iwpene, n1, n2, m1, m2, nx, ny, nz, gapv, gap_s, gap_m, igap, x, fpenmax)
Definition i20pwr3.F:35
i20pwr3e
subroutine i20pwr3e(itab, inacti, cand_m, cand_s, stfs, stfm, x, nsv, iwpene, n1, n2, m1, m2, nx, ny, nz, gapv, gap_s, gap_m, penis, penim, igap)
Definition i20pwr3.F:552
i20pwr3
subroutine i20pwr3(itab, inacti, cand_e, cand_n, stfn, stf, x, nsv, iwpene, iwrn, cand_en, cand_nn, tag, noint, gapv, nty, itied, penis, penim, gap_s, igap, id, titr, ix1, ix2, ix3, ix4, n1, n2, n3, pene, nsvg)
Definition i20pwr3.F:411
i20pwr3a
subroutine i20pwr3a(itab, inacti, cand_e, cand_n, stfn, stf, xanew, nsv, iwpene, iwrn, cand_en, cand_nn, tag, noint, gapv, nty, itied, fpenmax, id, titr, ix1, ix2, ix3, ix4, x1, x2, x3, x4, y1, y2, y3, y4, z1, z2, z3, z4, xi, yi, zi, n1, n2, n3, pene, nsvg)
Definition i20pwr3.F:177
max
#define max(a, b)
Definition macros.h:21
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
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