OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i24pen3.F File Reference
#include "implicit_f.inc"
#include "units_c.inc"
#include "vect07_c.inc"
#include "scr05_c.inc"
#include "com04_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine i24pen3 (x, irect, gapv, cand_e, cand_n, nsv, inacti, itab, tag, iwpene, nsn, irtlm, msegtyp, iwpene0, pmin, gap_n, mvoisn, ixs, ixs10, ixs16, ixs20, penmax, penmin, id, titr, ilev, pen_old, knod2els, nod2els, ipartns, ipen0, icont_i, xfic, nrtm, irtse, is2se)
subroutine ini_st3 (xx, yy, zz, xi, yi, zi, nn, ssc, ttc, ier, alp, xc, yc, zc)
subroutine i24penmax (pen, penmax, etyp, el, ns, ixs, ixs10, ixs16, ixs20, ielim)
subroutine iconnet (irect, ixs, knod2els, nod2els, ixs10, ixs16, ixs20, ns, iconn)
subroutine i24cand (cand_e, cand_n, nsn, irtlm, ii_stok, msegtyp)

Function/Subroutine Documentation

◆ i24cand()

subroutine i24cand ( integer, dimension(*) cand_e,
integer, dimension(*) cand_n,
integer nsn,
integer, dimension(2,*) irtlm,
integer ii_stok,
integer, dimension(*) msegtyp )

Definition at line 726 of file i24pen3.F.

728C
729C-----------------------------------------------
730C I m p l i c i t T y p e s
731C-----------------------------------------------
732#include "implicit_f.inc"
733C-----------------------------------------------
734C C o m m o n B l o c k s
735C-----------------------------------------------
736 INTEGER CAND_E(*),CAND_N(*),NSN,IRTLM(2,*),II_STOK,
737 * MSEGTYP(*)
738C-----------------------------------------------
739C L o c a l V a r i a b l e s
740C-----------------------------------------------
741 INTEGER E, I,ISH
742 .
743C-----------------------------------------------
744C E x t e r n a l F u n c t i o n s
745C-----------------------------------------------
746 ii_stok = 0
747 DO i=1,nsn
748 e = irtlm(1,i)
749 IF (e >0) THEN
750 ii_stok =ii_stok + 1
751 cand_n(ii_stok) = i
752 cand_e(ii_stok) = e
753
754 ish = abs(msegtyp(e))
755 IF (ish > 0)THEN
756 ii_stok =ii_stok + 1
757 cand_n(ii_stok) = i
758 cand_e(ii_stok) = ish
759 ENDIF
760
761 END IF
762 END DO
763C
764 RETURN

◆ i24pen3()

subroutine i24pen3 ( x,
integer, dimension(4,*) irect,
gapv,
integer, dimension(*) cand_e,
integer, dimension(*) cand_n,
integer, dimension(*) nsv,
integer inacti,
integer, dimension(*) itab,
integer, dimension(*) tag,
integer iwpene,
integer nsn,
integer, dimension(2,*) irtlm,
integer, dimension(*) msegtyp,
integer iwpene0,
pmin,
gap_n,
integer, dimension(4,*) mvoisn,
integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(8,*) ixs16,
integer, dimension(12,*) ixs20,
penmax,
penmin,
integer id,
character(len=nchartitle) titr,
integer ilev,
pen_old,
integer, dimension(*) knod2els,
integer, dimension(*) nod2els,
integer, dimension(*) ipartns,
integer ipen0,
integer, dimension(*) icont_i,
xfic,
integer nrtm,
integer, dimension(*) irtse,
integer, dimension(*) is2se )

Definition at line 38 of file i24pen3.F.

46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49#ifndef HYPERMESH_LIB
50 USE message_mod
51#endif
52 USE names_and_titles_mod , ONLY : nchartitle
53 USE format_mod , ONLY : fmt_i_3f
54C
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "units_c.inc"
63#include "vect07_c.inc"
64#include "scr05_c.inc"
65#include "com04_c.inc"
66C-----------------------------------------------
67 INTEGER IWPENE,TAG(*),INACTI,NSV(*),NSN,MSEGTYP(*),IWPENE0,
68 . MVOISN(4,*),ILEV,KNOD2ELS(*),NOD2ELS(*),IPARTNS(*),NRTM
69C---- IWPENE0 : nb of tiny initial pene; IWPENE nb of initial pene
70 my_real gapv(*)
71 INTEGER IRECT(4,*), ITAB(*),CAND_E(*),CAND_N(*),IRTLM(2,*)
72 INTEGER IXS(NIXS,*),IXS10(6,*), IXS16(8,*), IXS20(12,*),ICONT_I(*),
73 . IRTSE(*) ,IS2SE(*)
74 my_real x(3,*),pmin(*),gap_n(12,*),penmax,penmin,pen_old(5,nsn),xfic(3,*)
75C--------GAP_N(1,*) stock temporarily characteristic length for Pen_max
76 INTEGER ID,IPEN0
77 CHARACTER(LEN=NCHARTITLE) :: TITR
78C-----------------------------------------------
79C L o c a l V a r i a b l e s
80C-----------------------------------------------
81 INTEGER II, I, J, K, L, JJ, NJ, IER,NS,IC,I0,IELIM,NI,ICONN,ip,NS1,
82 . IDEL,NN1,NN2,IE
83C REAL
84 my_real
85 . pen, alp,xx(4),yy(4),zz(4),ssc,ttc,dist,dist0,
86 . xi,yi,zi,xc,yc,zc,nn(3),tol,pen0,dpen,norm,maxpen
87C-----------------------------------------------
88C E x t e r n a l F u n c t i o n s
89C-----------------------------------------------
90C--- MVOISN,IRTLM(2,*) is used temporarily for Pen_ini MVOISN(1,*) -> MTYPE(solid),MVOISN(2,*) -> E_id
91C-----MVOISN(3,*) -> part_id, PEN_OLD(1-3,*)->SECONDARY nodal normal, reput PEN_OLD(1-2,*)=0, 3,)=5,)after
92C-----to be consistent with engine for PENMIN
93 IF (iresp==1.AND.penmin<=em06) penmin = two*em06
94 tol = penmin
95 alp = two*em06
96 IF (iresp==1) alp = two*em05
97 DO i=lft,llt
98 l = cand_e(i)
99 ni = cand_n(i)
100 ns = nsv(ni)
101 IF (ns >numnod) THEN
102 ns1 = ns -numnod
103 xi=xfic(1,ns1)
104 yi=xfic(2,ns1)
105 zi=xfic(3,ns1)
106 ELSE
107 xi=x(1,ns)
108 yi=x(2,ns)
109 zi=x(3,ns)
110 END IF
111 DO jj=1,4
112 nj=irect(jj,l)
113 xx(jj)=x(1,nj)
114 yy(jj)=x(2,nj)
115 zz(jj)=x(3,nj)
116 END DO
117C--------
118 CALL ini_st3(xx,yy,zz,xi,yi,zi,nn,ssc,ttc,ier,alp,
119 2 xc,yc,zc)
120 IF(ier==-1)THEN
121#ifndef HYPERMESH_LIB
122 CALL ancmsg(msgid=85,
123 . msgtype=msgerror,
124 . anmode=aninfo,
125 . i1=id,
126 . c1=titr,
127 . i2=itab(ns),
128 . i3=l,
129 . i4=l,
130 . i5=itab(irect(1,l)),
131 . i6=itab(irect(2,l)),
132 . i7=itab(irect(3,l)),
133 . i8=itab(irect(4,l)))
134#endif
135C
136 ELSE IF(ier==1.AND.(msegtyp(l)/=0.AND.msegtyp(l)<=nrtm))THEN
137C shells except coating shells
138C---------outside
139c IF(IPRI>=1)WRITE(IOUT,FMT=FMT_6I)ITAB(NS),L,
140c . (ITAB(IRECT(JJ,L)),JJ=1,4)
141 ELSE
142C------initial penetration case 1) |PEN|<TOL : on, 2) Inacti<0 on,3)Inacti=3,4
143C-------warnning out for 2),3),4)
144C --------MSEGTYP /=0 ->shell ---
145 pen0=nn(1)*(xi-xc)+nn(2)*(yi-yc)+nn(3)*(zi-zc)
146 IF(ier==1) THEN
147 dist = sqrt((xi-xc)*(xi-xc)+(yi-yc)*(yi-yc)+(zi-zc)*(zi-zc))
148 ELSE
149 dist = abs(pen0)
150 END IF
151C--------for exception of elimination---
152 idel = 1
153C----------coating shell is like solid now----
154 IF (msegtyp(l)/=0.AND.msegtyp(l)<=nrtm) THEN
155 pen=gapv(i)-abs(pen0)
156 IF (pen > penmax ) idel = 0
157C-debug sandwish shell : avoid elimination with high thickness outside
158 IF (pen > zero) dist = abs(gapv(i)-pen0)
159C----------give up the the wrong one (normal direction, and)
160 IF (pen0 < zero .OR. pen > penmax) pen=-abs(pen)-tol
161C----------distance after shifted
162 ELSE
163 pen=gapv(i)-pen0
164C------------used only for eliminating wrong contact w/ smaller distance
165 IF(ier==1) pen=-abs(pen)-tol
166 IF (pen > zero .OR. abs(pen) < tol) THEN
167 maxpen = gap_n(1,l)
168 IF (inacti /= 0) maxpen = penmax
169 CALL i24penmax(pen,maxpen ,mvoisn(1,l),mvoisn(2,l),
170 + ns ,ixs, ixs10, ixs16, ixs20 ,
171 + ielim)
172 iconn = 0
173 IF (ns>numnod) THEN
174 CALL i24fic_getn(ns1 ,irtse ,is2se ,ie ,nn1 ,
175 4 nn2 )
176 CALL iconnet(irect(1,l),ixs ,knod2els,nod2els,
177 . ixs10 ,ixs16 ,ixs20 ,nn1 ,iconn )
178 IF (iconn == 0)
179 . CALL iconnet(irect(1,l),ixs ,knod2els,nod2els,
180 . ixs10 ,ixs16 ,ixs20 ,nn2 ,iconn )
181 ELSE
182 CALL iconnet(irect(1,l),ixs ,knod2els,nod2els,
183 . ixs10 ,ixs16 ,ixs20 ,ns ,iconn )
184 END IF
185 IF ((ielim+iconn) > 0) pen = -abs(pen)-tol
186 IF (pen < zero ) idel = 0
187 END IF
188C------Elimine the impact take into account to SECONDARY nodal normal
189 IF (inacti/=0.AND.(pen > zero .OR. abs(pen) < tol).AND.ilev/=3) THEN
190 norm = nn(1)*pen_old(1,ni)+nn(2)*pen_old(2,ni)
191 + +nn(3)*pen_old(3,ni)
192 IF (norm >= zero) THEN
193 pen = -abs(pen)-tol
194c print *,'impact pair eliminated due to N_SECONDARY'
195 idel = 0
196 END IF
197 END IF
198 END IF !(MSEGTYP(L)/=0 ) THEN
199C------Elimine the impact between the same part
200 IF (ipen0==0) THEN
201 IF (inacti/=0.AND.(pen > zero .OR. abs(pen) < tol)) THEN
202 IF (ipartns(ni) == mvoisn(3,l)) THEN
203 pen = -abs(pen)-tol
204 END IF
205 END IF
206 END IF !(IPEN0==0) THEN
207C------don't take into account auto-impact case for elimination
208 IF (ipartns(ni) == mvoisn(3,l)) idel = 0
209C--------exception for SECONDARY shell (test TV)----
210 IF (gapv(i)>zero.AND.(msegtyp(l)==0.OR.msegtyp(l)>nrtm))idel=0
211C--------PMIN() has been changed from PENE to dist excepting (INACTI ==0,1)
212C--------PMIN() = -dist for ABS(PEN) < TOL .OR. PEN<ZERO
213C------------ cas 1 this part is removed in Engine at T=0 for consisting
214 IF(abs(pen) < tol .OR. (pen<zero.AND.idel>0)) THEN
215C---------only used to calculate Dist_min and to eliminate wrong contact (higher)
216 IF (tag(ns)==0) THEN
217 pmin(ni)=-dist
218 tag(ns)=ni
219 ELSE
220 i0=tag(ns)
221 pen0=pmin(i0)
222 IF (dist <abs(pen0)) THEN
223C----------only update dist_min
224 pmin(ni)=-dist
225 tag(ns)=ni
226 IF (pen0 > zero) THEN
227C----------elimine wrong contact
228 irtlm(1,i0)=0
229 irtlm(2,i0)=0
230 pen_old(5,i0)=zero
231 END IF
232 END IF
233 END IF
234 ELSEIF(pen > penmax) THEN
235C----------warning w/o treatment
236#ifndef HYPERMESH_LIB
237 WRITE(iout,1200)pen
238#endif
239 ELSEIF(pen > zero) THEN
240C------Warning anyway-------------
241 IF (tag(ns)==0) iwpene=iwpene+1
242C------------PMIN has been changed from PENE to dist excepting (INACTI ==0,1)
243 IF(inacti ==0 .OR. inacti ==1) THEN
244C------------use IRTLM(2,NI)-> ICONT_I<0 for initial penetration
245 IF (tag(ns)>0) THEN
246 i0=tag(ns)
247 pen0=pmin(i0)
248C----------exclude case of PMIN(I0)<0 : -dist
249 IF (pen < pen0) THEN
250 icont_i(ni)=-l
251 pmin(ni)=pen
252 tag(ns) = ni
253#ifdef HYPERMESH_LIB
254 pen_old(1:3,ni) = nn(1:3)
255#endif
256 ENDIF
257 ELSE
258 icont_i(ni)=-l
259 pmin(ni)=pen
260 tag(ns) = ni
261#ifdef HYPERMESH_LIB
262 pen_old(1:3,ni) = nn(1:3)
263#endif
264 END IF
265 ELSEIF(inacti ==-1) THEN
266C------------multi-cont-> single by overwriting with min_pene
267 IF (tag(ns)>0) THEN
268 i0=tag(ns)
269 pen0=pmin(i0)
270 dist0 = abs(pmin(i0))
271 IF (dist < dist0) THEN
272 irtlm(1,ni)=l
273 irtlm(2,ni)=1
274 pmin(ni)=dist
275 pen_old(5,ni)=pen
276 tag(ns) = ni
277#ifdef HYPERMESH_LIB
278 pen_old(1:3,ni) = nn(1:3)
279#endif
280 ENDIF
281 ELSE
282 irtlm(1,ni)=l
283 irtlm(2,ni)=1
284 pmin(ni)=dist
285 pen_old(5,ni)=pen
286 tag(ns) = ni
287#ifdef HYPERMESH_LIB
288 pen_old(1:3,ni) = nn(1:3)
289#endif
290 END IF
291C--------hide option------
292 ELSEIF(inacti ==3 ) THEN
293 IF (ilev ==3) THEN
294 dpen = pen + tol
295 ELSE
296 dpen = half*(pen + tol)
297 END IF
298C-------change SECONDARY node
299 IF (tag(ns)==0) THEN
300 irtlm(1,ni)=l
301 irtlm(2,ni)=1
302 iwpene=iwpene+1
303 tag(ns)=ni
304#ifndef HYPERMESH_LIB
305 WRITE(iout,1000)pen
306#endif
307 IF (ns >numnod) THEN
308 ns1 = ns -numnod
309 xfic(1,ns1) = xi + dpen*nn(1)
310 xfic(2,ns1) = yi + dpen*nn(2)
311 xfic(3,ns1) = zi + dpen*nn(3)
312#ifndef HYPERMESH_LIB
313 WRITE(iout,fmt=fmt_i_3f)(itab(numnod)+ns1),xfic(1,ns1),xfic(2,ns1),xfic(3,ns1)
314#endif
315 ELSE
316 x(1,ns) = xi + dpen*nn(1)
317 x(2,ns) = yi + dpen*nn(2)
318 x(3,ns) = zi + dpen*nn(3)
319#ifndef HYPERMESH_LIB
320 WRITE(iout,fmt=fmt_i_3f)itab(ns),x(1,ns),x(2,ns),x(3,ns)
321#endif
322 END IF !(NS >NUMNOD) THEN
323 END IF
324 ELSEIF(inacti ==5) THEN
325C------------multi-cont-> single by overwriting with min_pene
326 IF (tag(ns)>0) THEN
327 i0=tag(ns)
328 pen0=pen_old(5,i0)
329 dist0 = abs(pmin(i0))
330 IF (dist < dist0) THEN
331 irtlm(1,ni)=l
332 irtlm(2,ni)=1
333 pen_old(5,ni)=pen
334 pmin(ni)=dist
335 tag(ns) = ni
336#ifdef HYPERMESH_LIB
337 pen_old(1:3,ni) = nn(1:3)
338#endif
339 ENDIF
340 ELSE
341 irtlm(1,ni)=l
342 irtlm(2,ni)=1
343 pen_old(5,ni)=pen
344 pmin(ni)=dist
345 tag(ns) = ni
346#ifdef HYPERMESH_LIB
347 pen_old(1:3,ni) = nn(1:3)
348#endif
349 END IF
350 END IF !IF(INACTI ==0 .OR. INACTI ==1) THEN
351 END IF !(PEN > ZERO) THEN
352 END IF !(IER==-1)THEN
353 END DO !I=LFT,LLT
354C
355 RETURN
356 1000 FORMAT(2x,'** INITIAL PENETRATION =',1pg20.13,
357 . ' CHANGE COORDINATES OF SECONDARY NODE TO:')
358 1100 FORMAT(2x,'** INITIAL PENETRATION =',1pg20.13,
359 . ' CHANGE COORDINATES OF MAIN NODE TO:')
360 1200 FORMAT(2x,'** TOO HIGH INITIAL PENETRATION=, WILL BE IGNORED',
361 . 1pg20.13)
362C
my_real
#define my_real
Definition cppsort.cpp:32
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
i24fic_getn
subroutine i24fic_getn(ns, irtse, is2se, ie, ns1, ns2)
Definition i24surfi.F:1921
id
initmumps id
Definition multiplerhs_example.m:4
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
ini_st3
subroutine ini_st3(xx, yy, zz, xi, yi, zi, nn, ssc, ttc, ier, alp, xc, yc, zc)
Definition i24pen3.F:371
i24penmax
subroutine i24penmax(pen, penmax, etyp, el, ns, ixs, ixs10, ixs16, ixs20, ielim)
Definition i24pen3.F:594
iconnet
subroutine iconnet(irect, ixs, knod2els, nod2els, ixs10, ixs16, ixs20, ns, iconn)
Definition i24pen3.F:651
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

◆ i24penmax()

subroutine i24penmax ( pen,
penmax,
integer etyp,
integer el,
integer ns,
integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(8,*) ixs16,
integer, dimension(12,*) ixs20,
integer ielim )

Definition at line 592 of file i24pen3.F.

594C-----------------------------------------------
595C I m p l i c i t T y p e s
596C-----------------------------------------------
597#include "implicit_f.inc"
598#include "com04_c.inc"
599C-----------------------------------------------
600C D u m m y A r g u m e n t s
601C-----------------------------------------------
602 INTEGER IXS(NIXS,*),IXS10(6,*), IXS16(8,*), IXS20(12,*)
603 INTEGER ETYP ,EL ,NS,IELIM
604C REAL
605 my_real
606 . pen ,penmax
607C-----------------------------------------------
608C External function
609C-----------------------------------------------
610 LOGICAL INTAB
611 EXTERNAL intab
612C-----------------------------------------------
613C L o c a l V a r i a b l e s
614C-----------------------------------------------
615C REAL
616 INTEGER EL2
617 my_real
618 . s
619C----add commun ID--at end--------------------------
620C--------eliminier some initial penetrations---------
621C------automatic for self_contact
622 ielim=0
623 SELECT CASE (etyp)
624 CASE(1)
625 IF (intab(8,ixs(2,el),ns)) ielim=1
626 CASE(10)
627 el2=el-numels8
628 IF (intab(8,ixs(2,el),ns).OR.intab(6,ixs10(1,el2),ns))
629 + ielim=1
630 CASE(20)
631 el2=el-numels8-numels10
632 IF (intab(8,ixs(2,el),ns).OR.intab(12,ixs20(1,el2),ns))
633 + ielim=1
634 CASE(16)
635 el2=el-numels8-numels10-numels20
636 IF (intab(8,ixs(2,el),ns).OR.intab(8,ixs16(1,el2),ns))
637 + ielim=1
638 END SELECT
639C-------
640 IF (pen >= penmax ) ielim = 1
641
642 RETURN
intab
logical function intab(nic, ic, n)
Definition i24tools.F:95

◆ iconnet()

subroutine iconnet ( integer, dimension(4) irect,
integer, dimension(nixs,*) ixs,
integer, dimension(*) knod2els,
integer, dimension(*) nod2els,
integer, dimension(6,*) ixs10,
integer, dimension(8,*) ixs16,
integer, dimension(12,*) ixs20,
integer ns,
integer iconn )

Definition at line 649 of file i24pen3.F.

651C-----------------------------------------------
652C I m p l i c i t T y p e s
653C-----------------------------------------------
654#include "implicit_f.inc"
655C-----------------------------------------------
656C C o m m o n B l o c k s
657C-----------------------------------------------
658#include "com04_c.inc"
659C-----------------------------------------------
660C D u m m y A r g u m e n t s
661C-----------------------------------------------
662C REAL
663 INTEGER IRECT(4), IXS(NIXS,*), KNOD2ELS(*), NOD2ELS(*),
664 . IXS10(6,*), IXS16(8,*), IXS20(12,*),ICONN,NS
665C REAL
666C-----------------------------------------------
667C L o c a l V a r i a b l e s
668C-----------------------------------------------
669 INTEGER N, JJ, II, K, NN, KK, IC, IAD
670C REAL
671C-----------------------------------------------
672C E x t e r n a l F u n c t i o n s
673C-----------------------------------------------
674C
675 iconn = 0
676 IF(numels==0) RETURN
677 DO 230 iad=knod2els(ns)+1,knod2els(ns+1)
678 n = nod2els(iad)
679 IF(n <= numels8)THEN
680 DO jj=1,4
681 ii=irect(jj)
682 DO k=1,8
683 IF(ixs(k+1,n)==ii) iconn = 1
684 ENDDO
685 ENDDO
686 ELSEIF(n <= numels8+numels10)THEN
687 DO jj=1,4
688 ii=irect(jj)
689 DO k=1,8
690 IF(ixs(k+1,n)==ii) iconn = 1
691 ENDDO
692 DO k=1,6
693 IF(ixs10(k,n-numels8)==ii) iconn = 1
694 ENDDO
695 ENDDO
696 ELSEIF(n <= numels8+numels10+numels20)THEN
697 DO jj=1,4
698 ii=irect(jj)
699 DO k=1,8
700 IF(ixs(k+1,n)==ii) iconn = 1
701 ENDDO
702 DO k=1,12
703 IF(ixs20(k,n-numels8-numels10)==ii) iconn = 1
704 ENDDO
705 ENDDO
706 ELSEIF(n <= numels8+numels10+numels20+numels16)THEN
707 DO jj=1,4
708 ii=irect(jj)
709 DO k=1,8
710 IF(ixs(k+1,n)==ii) iconn = 1
711 ENDDO
712 DO k=1,8
713 IF(ixs16(k,n-numels8-numels10-numels20)==ii) iconn = 1
714 ENDDO
715 ENDDO
716 END IF
717 230 CONTINUE
718 RETURN

◆ ini_st3()

subroutine ini_st3 ( xx,
yy,
zz,
xi,
yi,
zi,
nn,
ssc,
ttc,
integer ier,
alp,
xc,
yc,
zc )

Definition at line 369 of file i24pen3.F.

371C
372C-----------------------------------------------
373C I m p l i c i t T y p e s
374C-----------------------------------------------
375#include "implicit_f.inc"
376C-----------------------------------------------
377C D u m m y A r g u m e n t s
378C-----------------------------------------------
379 INTEGER IER
380 my_real
381 . xx(4),yy(4),zz(4),nn(3), ssc, ttc, alp,xi,yi,zi,xc,yc,zc
382C-----------------------------------------------
383C L o c a l V a r i a b l e s
384C-----------------------------------------------
385 my_real
386 . h(4), x0, y0, z0, xl1, xl2, xl3, xl4, yy1, yy2, yy3, yy4,
387 . zz1, zz2, zz3, zz4, xi1, xi2, xi3, xi4, yi1, yi2, yi3, yi4,
388 . zi1, zi2, zi3, zi4, xn1, yn1, zn1, xn2, yn2, zn2, xn3, yn3,
389 . zn3, xn4, yn4, zn4, an, area, a12, a23, a34, a41, b12, b23,
390 . b34, b41, ab1, ab2, tp, tm, sp, sm, x1,x2,x3,x4,
391 . y1,y2,y3,y4,z1,z2,z3,z4,n1,n2,n3,la,lb,lc,lbs,lcs,tt1,ss1
392C
393 x1=xx(1)
394 x2=xx(2)
395 x3=xx(3)
396 x4=xx(4)
397 y1=yy(1)
398 y2=yy(2)
399 y3=yy(3)
400 y4=yy(4)
401 z1=zz(1)
402 z2=zz(2)
403 z3=zz(3)
404 z4=zz(4)
405C
406 x0 = fourth*(x1+x2+x3+x4)
407 y0 = fourth*(y1+y2+y3+y4)
408 z0 = fourth*(z1+z2+z3+z4)
409C
410 xl1 = x1-x0
411 xl2 = x2-x0
412 xl3 = x3-x0
413 xl4 = x4-x0
414 yy1 = y1-y0
415 yy2 = y2-y0
416 yy3 = y3-y0
417 yy4 = y4-y0
418 zz1 = z1-z0
419 zz2 = z2-z0
420 zz3 = z3-z0
421 zz4 = z4-z0
422C
423 xi1 = x1-xi
424 xi2 = x2-xi
425 xi3 = x3-xi
426 xi4 = x4-xi
427 yi1 = y1-yi
428 yi2 = y2-yi
429 yi3 = y3-yi
430 yi4 = y4-yi
431 zi1 = z1-zi
432 zi2 = z2-zi
433 zi3 = z3-zi
434 zi4 = z4-zi
435C
436 xn1 = yy1*zz2 - yy2*zz1
437 yn1 = zz1*xl2 - zz2*xl1
438 zn1 = xl1*yy2 - xl2*yy1
439 n1=xn1
440 n2=yn1
441 n3=zn1
442C
443 xn2 = yy2*zz3 - yy3*zz2
444 yn2 = zz2*xl3 - zz3*xl2
445 zn2 = xl2*yy3 - xl3*yy2
446 n1=n1+xn2
447 n2=n2+yn2
448 n3=n3+zn2
449C
450 xn3 = yy3*zz4 - yy4*zz3
451 yn3 = zz3*xl4 - zz4*xl3
452 zn3 = xl3*yy4 - xl4*yy3
453 n1=n1+xn3
454 n2=n2+yn3
455 n3=n3+zn3
456C
457 xn4 = yy4*zz1 - yy1*zz4
458 yn4 = zz4*xl1 - zz1*xl4
459 zn4 = xl4*yy1 - xl1*yy4
460 n1=n1+xn4
461 n2=n2+yn4
462 n3=n3+zn4
463C
464 an= max(em20,sqrt(n1*n1+n2*n2+n3*n3))
465 n1=n1/an
466 n2=n2/an
467 n3=n3/an
468 nn(1)=n1
469 nn(2)=n2
470 nn(3)=n3
471 IF(an<=em19) THEN
472 ier=-1
473 RETURN
474 ENDIF
475 area=half*an
476C
477 a12=(n1*xn1+n2*yn1+n3*zn1)
478 a23=(n1*xn2+n2*yn2+n3*zn2)
479 a34=(n1*xn3+n2*yn3+n3*zn3)
480 a41=(n1*xn4+n2*yn4+n3*zn4)
481C
482 xn1 = yi1*zi2 - yi2*zi1
483 yn1 = zi1*xi2 - zi2*xi1
484 zn1 = xi1*yi2 - xi2*yi1
485 b12=(n1*xn1+n2*yn1+n3*zn1)
486C
487 xn2 = yi2*zi3 - yi3*zi2
488 yn2 = zi2*xi3 - zi3*xi2
489 zn2 = xi2*yi3 - xi3*yi2
490 b23=(n1*xn2+n2*yn2+n3*zn2)
491C
492 xn3 = yi3*zi4 - yi4*zi3
493 yn3 = zi3*xi4 - zi4*xi3
494 zn3 = xi3*yi4 - xi4*yi3
495 b34=(n1*xn3+n2*yn3+n3*zn3)
496C
497 xn4 = yi4*zi1 - yi1*zi4
498 yn4 = zi4*xi1 - zi1*xi4
499 zn4 = xi4*yi1 - xi1*yi4
500 b41=(n1*xn4+n2*yn4+n3*zn4)
501C
502 ab1=a23*b41
503 ab2=b23*a41
504C
505 IF(abs(ab1+ab2)/area>em10)THEN
506 ssc=(ab1-ab2)/(ab1+ab2)
507 ELSE
508 ssc=zero
509 ENDIF
510 IF(abs(a34/area)>em10)THEN
511 ab1=b12*a34
512 ab2=b34*a12
513 IF(abs(ab1+ab2)/area>em10)THEN
514 ttc=(ab1-ab2)/(ab1+ab2)
515 ELSE
516 ttc=zero
517 END IF
518 ELSE
519 ttc=b12/a12-one
520 IF(b23<=zero.AND.b41<=zero)THEN
521 IF(-b23/a12<=alp.AND.-b41/a12<=alp)ssc=zero
522 ELSEIF(b23<=zero)THEN
523 IF(-b23/a12<=alp) THEN
524 ssc=one
525 ELSE
526 ssc=two
527 END IF
528 ELSEIF(b41<=zero)THEN
529 IF(-b41/a12<=alp) THEN
530 ssc=-one
531 ELSE
532 ssc=-two
533 END IF
534 ENDIF
535 ENDIF
536C-------------out of seg
537 IF(abs(ssc)>one+alp.OR.abs(ttc)>one+alp) THEN
538 ier=1
539C------case tria re-compute
540 IF (a34==zero.AND.ttc< one) THEN
541 lb=fourth*(one - ttc)*(one - ssc)
542 lc=fourth*(one - ttc)*(one + ssc)
543 la = one - lb - lc
544 IF (la>=zero) THEN
545 lb= min(one,max(zero,lb))
546 lc= min(one,max(zero,lc))
547 ELSEIF(lc>lb.AND.lc >= one) THEN
548 lc = one
549 lb = zero
550 ELSEIF(lb >= one) THEN
551 lc = zero
552 lb = one
553 ELSE
554 lbs = half*(one+lb-lc)
555 lcs = half*(one-lb+lc)
556 lb= min(one,max(zero,lbs))
557 lc= min(one,max(zero,lcs))
558 ENDIF
559 ssc= (lc-lb)/(lc+lb)
560 ttc= one - two*lb - two*lc
561 END IF
562 IF(abs(ssc)>one)ssc=ssc/abs(ssc)
563 IF(abs(ttc)>one)ttc=ttc/abs(ttc)
564 ELSE
565 ier=0
566 IF(abs(ssc)>one)ssc=ssc/abs(ssc)
567 IF(abs(ttc)>one)ttc=ttc/abs(ttc)
568 ENDIF
569C
570 tp=fourth*(one+ttc)
571 tm=fourth*(one-ttc)
572C
573 sp=one+ssc
574 sm=one-ssc
575 h(1)=tm*sm
576 h(2)=tm*sp
577 h(3)=tp*sp
578 h(4)=tp*sm
579C
580 xc =h(1)*x1+h(2)*x2+h(3)*x3+h(4)*x4
581 yc =h(1)*y1+h(2)*y2+h(3)*y3+h(4)*y4
582 zc =h(1)*z1+h(2)*z2+h(3)*z3+h(4)*z4
583 RETURN
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21