OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
corthini.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!|| corthini ../starter/source/elements/shell/coque/corthini.F
25!||--- called by ------------------------------------------------------
26!|| c3init3 ../starter/source/elements/sh3n/coque3n/c3init3.F
27!|| cinit3 ../starter/source/elements/shell/coque/cinit3.F
28!|| cmaini3 ../starter/source/elements/sh3n/coquedk/cmaini3.F
29!||--- calls -----------------------------------------------------
30!|| ancmsg ../starter/source/output/message/message.F
31!|| fretitl2 ../starter/source/starter/freform.F
32!||--- uses -----------------------------------------------------
33!|| drape_mod ../starter/share/modules1/drape_mod.F
34!|| message_mod ../starter/share/message_module/message_mod.F
35!|| stack_mod ../starter/share/modules1/stack_mod.F
36!||====================================================================
37 SUBROUTINE corthini(
38 1 JFT ,JLT ,NFT ,NLAY ,NUMEL ,
39 2 NSIGSH ,NIX ,IX ,IGEO ,GEO ,
40 3 SKEW ,SIGSH ,PTSH ,PHI1 ,PHI2 ,
41 4 VX ,VY ,VZ ,COOR1 ,COOR2 ,
42 5 COOR3 ,COOR4 ,IORTHLOC,ISUBSTACK, STACK ,
43 6 IREP ,ELBUF_STR,DRAPE ,ANGLE ,X ,
44 7 GEO_STACK,E3X ,E3Y ,E3Z ,
45 8 BETAORTH ,X1 ,X2 ,Y1 ,Y2 ,
46 9 Z1 ,Z2 ,NEL ,G_ADD_NODE,ADD_NODE,
47 A NPT_ALL , IDRAPE ,INDX)
48c---
49C-----------------------------------------------
50C M o d u l e s
51C-----------------------------------------------
52 USE elbufdef_mod
53 USE message_mod
54 USE stack_mod
55 USE drape_mod
56 USE names_and_titles_mod , ONLY : nchartitle
57C-----------------------------------------------
58C I m p l i c i t T y p e s
59C-----------------------------------------------
60#include "implicit_f.inc"
61C-----------------------------------------------
62C G l o b a l P a r a m e t e r s
63C-----------------------------------------------
64#include "mvsiz_p.inc"
65C-----------------------------------------------
66C C o m m o n B l o c k s
67C-----------------------------------------------
68#include "param_c.inc"
69#include "com01_c.inc"
70#include "scr17_c.inc"
71#include "drape_c.inc"
72C-----------------------------------------------
73C D u m m y A r g u m e n t s
74C-----------------------------------------------
75 INTEGER JFT,JLT,NFT,NLAY,IPT,ID,NIX,NUMEL,NSIGSH,
76 . ISUBSTACK,IREP,NPT_ALL,IDRAPE
77 INTEGER IX(NIX,*),IGEO(NPROPGI,*),PTSH(*),IORTHLOC(*)
78 INTEGER, INTENT(IN) :: NEL,G_ADD_NODE,ADD_NODE(G_ADD_NODE*NEL)
79 INTEGER, DIMENSION(*) :: INDX
80 my_real
81 . GEO(NPROPG,*),SKEW(LSKEW,*),SIGSH(NSIGSH,*),VX(*),VY(*),VZ(*),
82 . PHI1(NPT_ALL,*),PHI2(NPT_ALL,*),COOR1(NPT_ALL,MVSIZ),COOR2(NPT_ALL,MVSIZ),
83 . COOR3(NPT_ALL,MVSIZ),COOR4(NPT_ALL,MVSIZ),
84 . ANGLE(*),GEO_STACK(NPROPG,*),X(3,*),BETAORTH(*)
85 my_real, DIMENSION(MVSIZ), INTENT(IN) :: e3x,e3y,e3z,x1,x2,y1,y2,z1,z2
86C------------------------------------------------------
87 TYPE(elbuf_struct_), TARGET :: ELBUF_STR
88 TYPE (STACK_PLY):: STACK
89 TYPE (DRAPE_) , DIMENSION(*), TARGET :: DRAPE
90C------------------------------------------------------
91C L o c a l V a r i a b l e s
92C-----------------------------------------------
93 INTEGER I,II,J,JJ,N,NPT,NPTI,IGTYP,IPID,PID,ISK,IPANG,IPPHI,
94 . IIGEO,IADR,IPTHK,IPPOS,IPDIR,IMAT_LY,ILAW_LY,IPPID,IPMAT,ILAY,
95 . def_orth(mvsiz),n1,n2,irp,pos,nod,il,it,nslice,ipt_all,nptt,
96 . ie, ip,ipid_ply,n3,n4
97 my_real v(mvsiz),e11,e12,e13,ne1,vx0,vy0,vz0,
98 . xc(mvsiz),yc(mvsiz),zc(mvsiz)
99 CHARACTER(LEN=NCHARTITLE)::TITR1
100
101 TYPE (DRAPE_PLY_) , POINTER :: DRAPE_PLY
102C=======================================================================
103 pid = ix(nix-1,1)
104 igtyp = igeo(11,pid)
105 irp = igeo(14,pid)
106 def_orth(1:mvsiz) = nlay
107 ipdir = 0
108C
109 IF (igtyp == 1) THEN
110C non orthotropic property
111 RETURN
112 ELSE
113 ipang = 200
114 ipphi = 500
115 IF (igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52 ) THEN
116 ipang = 1
117 ipthk = ipang + nlay
118 ippos = ipthk + nlay
119 ipdir = ippos + nlay
120 ENDIF
121 SELECT CASE (irp)
122 CASE (0) !
123 isk = igeo(2,pid)
124 DO i=jft,jlt
125 IF (isk == 0) THEN
126 vx(i) = geo(7,pid)
127 vy(i) = geo(8,pid)
128 vz(i) = geo(9,pid)
129 ELSE
130 vx(i) = skew(1,isk)
131 vy(i) = skew(2,isk)
132 vz(i) = skew(3,isk)
133 ENDIF
134 ENDDO
135 CASE (20) ! N1---> N2 (nodes)
136 DO i=jft,jlt
137 n1=ix(2,i)
138 n2=ix(3,i)
139 vx(i) = x(1,n2)-x(1,n1)
140 vy(i) = x(2,n2)-x(2,n1)
141 vz(i) = x(3,n2)-x(3,n1)
142 ENDDO
143 CASE (22) ! Iskew
144 isk = igeo(2,pid) !
145 DO i=jft,jlt
146 vx(i) = skew(1,isk)
147 vy(i) = skew(2,isk)
148 vz(i) = skew(3,isk)
149 ENDDO
150 CASE (23) ! Proj on the element V x normal_eleemt
151 vx0 = geo(7,pid)
152 vy0 = geo(8,pid)
153 vz0 = geo(9,pid)
154 DO i=jft,jlt
155 vx(i) = e3y(i)*vz0 - e3z(i)*vy0
156 vy(i) = e3z(i)*vx0 - e3x(i)*vz0
157 vz(i) = e3x(i)*vy0 - e3y(i)*vx0
158 ENDDO
159 CASE (24)
160C-- seatbelt elements - dir1 defined by N1 and ADD_NODE (can be either N2 or N4)
161 DO i=jft,jlt
162 n1=ix(2,i)
163 nod=add_node(i)
164 vx(i) = x(1,nod)-x(1,n1)
165 vy(i) = x(2,nod)-x(2,n1)
166 vz(i) = x(3,nod)-x(3,n1)
167 ENDDO
168 CASE (25)
169C-- y' of cylintrical sys (using xc,yc,zc)
170 isk = igeo(2,pid)
171 IF (nix > nixtg) THEN
172 DO i=jft,jlt
173 n1=ix(2,i)
174 n2=ix(3,i)
175 n3=ix(4,i)
176 n4=ix(5,i)
177 xc(i) = fourth*(x(1,n1)+x(1,n2)+x(1,n3)+x(1,n4))
178 yc(i) = fourth*(x(2,n1)+x(2,n2)+x(2,n3)+x(2,n4))
179 zc(i) = fourth*(x(3,n1)+x(3,n2)+x(3,n3)+x(3,n4))
180 ENDDO
181 ELSE
182 DO i=jft,jlt
183 n1=ix(2,i)
184 n2=ix(3,i)
185 n3=ix(4,i)
186 xc(i) = third*(x(1,n1)+x(1,n2)+x(1,n3))
187 yc(i) = third*(x(2,n1)+x(2,n2)+x(2,n3))
188 zc(i) = third*(x(3,n1)+x(3,n2)+x(3,n3))
189 ENDDO
190 END IF
191 DO i=jft,jlt
192 e11 = xc(i)-skew(10,isk)
193 e12 = yc(i)-skew(11,isk)
194 e13 = zc(i)-skew(12,isk)
195 vx(i) = skew(8,isk)*e13 - skew(9,isk)*e12
196 vy(i) = skew(9,isk)*e11 - skew(7,isk)*e13
197 vz(i) = skew(7,isk)*e12 - skew(8,isk)*e11
198 ENDDO
199 END SELECT
200C--- read property data
201 IF (igtyp == 9) THEN
202 DO i=jft,jlt
203 phi1(1,i)= geo(10,pid)
204 ENDDO
205 ELSEIF (igtyp == 10) THEN
206 DO i=jft,jlt
207 DO j=1,nlay
208 phi1(j,i)= geo(ipang+j,pid)
209 ENDDO
210 ENDDO
211 ELSEIF (igtyp == 11) THEN
212 DO i=jft,jlt
213 DO j=1,nlay
214 phi1(j,i)= geo(ipang+j,pid)
215 ENDDO
216 ENDDO
217 ELSEIF (igtyp == 17 .AND. irp /= 24) THEN !
218 IF(idrape > 0) THEN
219 DO i=jft,jlt
220 ipang = 1
221 ie = indx(nft + i)
222 IF(ie == 0) THEN
223 DO j=1,nlay
224 ipid_ply = stack%IGEO(2 + j,isubstack)
225 IF(ipid_ply > 0) THEN
226 phi1(j,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang+j,isubstack) ! + stack_angle
227 IF (irep >= 2) phi2(j,i)= stack%GEO(ipdir+j,isubstack)
228 def_orth(i) = def_orth(i) - 1
229 ENDIF
230 ENDDO
231 ELSE ! ie > 0
232 DO j=1,nlay
233 ipid_ply = stack%IGEO(2+j,isubstack)
234 IF(ipid_ply > 0) THEN
235 phi1(j,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang+j,isubstack) ! + stack_angle
236 IF (irep >= 2) phi2(j,i)= stack%GEO(ipdir+j,isubstack)
237 def_orth(i) = def_orth(i) - 1
238 ip = drape(ie)%INDX_PLY(j)
239 IF(ip > 0) THEN
240 drape_ply => drape(ie)%DRAPE_PLY(ip)
241 phi1(j,i) = phi1(j,i) + drape_ply%RDRAPE(1,2)
242 ENDIF
243 ENDIF
244 ENDDO
245 ENDIF
246 ENDDO
247 ELSE ! idrape== 0
248 DO i=jft,jlt
249 ipang = 1
250 DO j=1,nlay
251 ipid_ply = stack%IGEO(2+j,isubstack)
252 IF(ipid_ply > 0) THEN
253 phi1(j,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang+j,isubstack)
254 def_orth(i) = def_orth(i) - 1
255 IF (irep >= 2) phi2(j,i)= stack%GEO(ipdir+j,isubstack)
256 ENDIF
257 ENDDO
258 ENDDO
259 ENDIF ! idrape
260 ELSEIF(igtyp == 51 .AND. irp /= 24 ) THEN !
261 IF(idrape > 0) THEN
262 DO i=jft,jlt
263 ipang = 1
264 ipt_all = 0
265 ie = indx(nft + i)
266 IF(ie > 0) THEN
267 DO il=1,nlay
268 nptt = elbuf_str%BUFLY(il)%NPTT
269 ip = drape(ie)%INDX_PLY(il)
270 ipid_ply = stack%IGEO(2 + il,isubstack)
271 IF(ipid_ply > 0) THEN
272 IF(ip > 0) THEN
273 drape_ply => drape(ie)%DRAPE_PLY(ip)
274 nslice = drape_ply%NSLICE ! NPTT
275 def_orth(i) = def_orth(i) - 1 !
276 IF(irep >= 2) THEN
277 DO it = 1,nptt
278 ipt = ipt_all + it
279 phi1(ipt,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang+il,isubstack)
280 . + drape_ply%RDRAPE(it,2)
281 phi2(ipt,i) = stack%GEO(ipdir + il,isubstack)
282 ENDDO ! NPTT
283 ELSE
284 DO it = 1,nptt
285 ipt = ipt_all + it
286 phi1(ipt,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang+il,isubstack)
287 . + drape_ply%RDRAPE(it,2)
288 ENDDO ! NPTT
289 ENDIF ! IREP
290 ELSE !IP == 0
291 def_orth(i) = def_orth(i) - 1
292 IF(irep >= 2) THEN
293 DO it = 1,nptt
294 ipt = ipt_all + it
295 phi1(ipt,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
296 phi2(ipt,i) = stack%GEO(ipdir+il,isubstack)
297 ENDDO ! NPTT
298 ELSE
299 DO it = 1,nptt
300 ipt = ipt_all + it
301 phi1(ipt,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
302 ENDDO ! NPTT
303 ENDIF
304 ENDIF ! IP
305 ENDIF ! IPID_PLY > 0
306 ipt_all = ipt_all + nptt
307 ENDDO ! NLAY
308 ELSE !IE == 0
309 DO il=1,nlay
310 nptt = elbuf_str%BUFLY(il)%NPTT
311 ipid_ply = stack%IGEO(2 + il,isubstack)
312 IF(ipid_ply > 0) THEN
313 def_orth(i) = def_orth(i) - 1
314 IF(irep >= 2) THEN
315 DO it = 1,nptt
316 ipt = ipt_all + it
317 phi1(ipt,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
318 phi2(ipt,i) = stack%GEO(ipdir+il,isubstack)
319 ENDDO ! NPTT
320 ELSE
321 DO it = 1,nptt
322 ipt = ipt_all + it
323 phi1(ipt,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
324 ENDDO ! NPTT
325 ENDIF
326 ENDIF
327 ipt_all = ipt_all + nptt
328 ENDDO ! NLAY
329 ENDIF !IE
330 ENDDO ! JFT:JLT
331 ELSE ! IDRAPE = 0
332 DO i=jft,jlt
333 ipang = 1
334 DO il=1,nlay
335 ipid_ply = stack%IGEO(2 + il,isubstack)
336 IF(ipid_ply > 0 ) THEN
337 phi1(il,i) = angle(i) + geo(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
338 def_orth(i) = def_orth(i) - 1
339 ENDIF
340 IF (irep >= 2) phi2(il,i)= stack%GEO(ipdir + il,isubstack)
341 ENDDO
342 ENDDO
343 ENDIF ! idrape
344 ELSEIF(igtyp == 52 .AND. irp /= 24 ) THEN
345 IF(idrape > 0) THEN
346 DO i=jft,jlt
347 ipang = 1
348 ipt_all = 0
349 ie = indx(nft + i)
350 IF(ie > 0) THEN
351 DO il=1,nlay
352 nptt = elbuf_str%BUFLY(il)%NPTT
353 ip = drape(ie)%INDX_PLY(il)
354 ipid_ply = stack%IGEO(2+il,isubstack)
355 IF( ipid_ply > 0) THEN
356 IF(ip > 0) THEN !
357 drape_ply => drape(ie)%DRAPE_PLY(ip)
358 nslice = drape_ply%NSLICE ! NPTT
359 def_orth(i) = def_orth(i) - 1
360 IF(irep >= 2) THEN
361 DO it = 1,nptt
362 ipt = ipt_all + it
363 phi1(ipt,i) = angle(i) + geo_stack(2,ipid_ply)
364 . + stack%GEO(ipang + il,isubstack) + drape_ply%RDRAPE(it,2)
365 phi2(ipt,i)= stack%GEO(ipdir+il,isubstack)
366 ENDDO ! NPTT
367 ELSE
368 DO it = 1,nptt
369 ipt = ipt_all + it
370 phi1(ipt,i) = angle(i) + geo_stack(2,ipid_ply)
371 . + stack%GEO(ipang + il,isubstack) + drape_ply%RDRAPE(it,2)
372 ENDDO ! NPTT
373 ENDIF
374 ELSE !IP == 0
375 def_orth(i) = def_orth(i) - 1
376 IF(irep >= 2) THEN
377 DO it = 1,nptt
378 ipt = ipt_all + it
379 phi1(ipt,i) = angle(i) + geo_stack(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
380 phi2(ipt,i) = stack%GEO(ipdir+il,isubstack)
381 ENDDO ! NPTT
382 ELSE
383 DO it = 1,nptt
384 ipt = ipt_all + it
385 phi1(ipt,i) = angle(i) + geo_stack(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
386 ENDDO ! NPTT
387 ENDIF ! IREP
388 ENDIF !IP
389 ENDIF ! IPID_PLY
390 ipt_all = ipt_all + nptt
391 ENDDO ! NLAY
392 ELSE !IE == 0
393 DO il=1,nlay
394 nptt = elbuf_str%BUFLY(il)%NPTT
395 ipid_ply = stack%IGEO(2+il,isubstack)
396 IF(ipid_ply > 0) THEN
397 def_orth(i) = def_orth(i) - 1
398 IF(irep >= 2)THEN
399 DO it = 1,nptt
400 ipt = ipt_all + it
401 phi1(ipt,i) = angle(i) + geo_stack(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
402 phi2(ipt,i)= stack%GEO(ipdir+il,isubstack)
403 ENDDO ! NPTT
404 ELSE
405 DO it = 1,nptt
406 ipt = ipt_all + it
407 phi1(ipt,i) = angle(i) + geo_stack(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
408 ENDDO ! NPT
409 ENDIF ! IREP
410 ENDIF
411 ipt_all = ipt_all + nptt
412 ENDDO ! NLAY
413 ENDIF !IE
414 ENDDO ! JFT:JLT
415 ELSE ! IDRAPE = 0
416 DO i=jft,jlt
417 ipang = 1
418 DO il=1,nlay
419 ipid_ply = stack%IGEO(2+il,isubstack)
420 IF(ipid_ply > 0) THEN
421 def_orth(i) = def_orth(i) - 1
422 phi1(il,i) = angle(i) + geo_stack(2,ipid_ply) + stack%GEO(ipang + il,isubstack)
423 IF(irep >= 2) phi2(il,i)= stack%GEO(ipdir+il,isubstack)
424 ENDIF ! IPID_PLY
425 ENDDO
426 ENDDO
427 ENDIF ! idrape
428 ELSEIF (igtyp == 16) THEN
429 DO i=jft,jlt
430 DO j=1,nlay
431 phi1(j,i)= geo(ipang+j,pid)
432 phi2(j,i)= geo(ipphi+j,pid)
433 ENDDO
434 ENDDO
435 ENDIF
436C--- Overwrite with optional element data
437 IF (iortshel == 1) THEN
438 DO i=jft,jlt
439 IF (abs(isigi) /= 3 .AND. abs(isigi)/=4 .AND. abs(isigi)/=5) THEN
440 !!II = I + NFT
441 id = ix(nix,i)
442 ii = ptsh(i + nft)
443 IF(ii == 0) GOTO 100
444 n = nint(sigsh(1,ii))
445 IF (n == id) THEN
446 CONTINUE
447 ELSE
448 DO j = 1,numel
449 ii = j
450 n = nint(sigsh(1,ii))
451 IF (n == id) GOTO 60
452 IF (n == 0) GOTO 100
453 ENDDO
454 GOTO 100
455 60 CONTINUE
456 ENDIF
457 ELSE
458 jj=nft+i
459 n =ix(nix,i)
460 ii=ptsh(jj)
461 IF (ii == 0) GOTO 100
462 END IF
463 IF(sigsh(nvshell + nushell + 5,ii) == zero) cycle
464C
465 npti = nint(sigsh(nvshell + nushell + 4,ii))
466 IF(igtyp == 9) npti = 1
467 IF (nlay /= npti) THEN
468 ipid = ix(nix-1,i)
469 pid = igeo(1,ipid)
470 CALL fretitl2(titr1,igeo(npropgi-ltitr+1,ipid),ltitr)
471 IF (npti == 0) THEN
472 CALL ancmsg(msgid=355,
473 . msgtype=msgwarning,
474 . anmode=aninfo_blind_1,
475 . i1=n,
476 . i2=pid,
477 . c1=titr1)
478 ELSE
479 CALL ancmsg(msgid=26,
480 . anmode=aninfo,
481 . msgtype=msgerror,
482 . i2=n,
483 . i1=pid,
484 . c1=titr1)
485 ENDIF
486 ENDIF
487C
488 ipt = nvshell + nushell
489 vx(i) = sigsh(ipt+1,ii)
490 vy(i) = sigsh(ipt+2,ii)
491 vz(i) = sigsh(ipt+3,ii)
492 ipt = ipt + 5
493 IF ( igtyp == 9) THEN
494 phi1(1,i) = sigsh(ipt+1,ii)
495 phi2(1,i) = sigsh(ipt+2,ii)
496 ipt = ipt + 2
497 ELSE
498 DO j=1,npti
499 phi1(j,i) = sigsh(ipt+1,ii)
500 phi2(j,i) = sigsh(ipt+2,ii)
501 ipt = ipt + 2
502 ENDDO
503 ENDIF
504 100 CONTINUE
505 ENDDO
506 ENDIF
507C
508C--- Overwrite with optional element data__ ORTH_LOC
509 IF (iortshel == 2) THEN
510 DO i=jft,jlt
511 ie = i + nft
512 IF (abs(isigi) /= 3 .AND. abs(isigi) /= 4 .AND. abs(isigi) /= 5) THEN
513 id = ix(nix,i)
514 ii = ptsh(ie)
515 IF(ii == 0) GOTO 110
516 n = nint(sigsh(1,ii))
517 IF (n == id) THEN
518 CONTINUE
519 ELSE
520 DO j = 1,numel
521 ii = j
522 n = nint(sigsh(1,ii))
523 IF (n == id) GOTO 70
524 IF (n == 0) GOTO 110
525 ENDDO
526 GOTO 110
527 70 CONTINUE
528 ENDIF
529 ELSE
530 jj=nft+i
531 n =ix(nix,i)
532 ii=ptsh(jj)
533 IF (ii == 0) GOTO 110
534 END IF
535 IF(sigsh(nvshell + nushell + 5,ii) == zero) cycle
536 npti = nint(sigsh(nvshell + nushell + 4,ii))
537C
538 npt = nint(geo(6,ix(nix-1,i)))
539 IF(idrape > 0 .AND. (igtyp == 51 .OR. igtyp==52)) THEN
540 npt = npt_all
541 ELSEIF (igtyp == 16 .OR. igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52) THEN
542 npt = nlay
543 ENDIF
544 IF (npt /= npti) THEN
545 ipid = ix(nix-1,i)
546 pid = igeo(1,ipid)
547 CALL fretitl2(titr1,igeo(npropgi-ltitr+1,ipid),ltitr)
548 IF (npti == 0) THEN
549 CALL ancmsg(msgid=355,
550 . msgtype=msgwarning,
551 . anmode=aninfo_blind_1,
552 . i1=n,
553 . i2=pid,
554 . c1=titr1)
555 ELSE
556 CALL ancmsg(msgid=26,
557 . anmode=aninfo,
558 . msgtype=msgerror,
559 . i2=n,
560 . i1=pid,
561 . c1=titr1)
562 ENDIF
563 ENDIF
564C
565 ipt = nvshell + nushell + 5
566 IF (igtyp == 9) THEN
567 coor1(1,i) = sigsh(ipt+1,ii)
568 coor2(1,i) = sigsh(ipt+2,ii)
569 ipt = ipt + 2
570 iorthloc(i) = 1
571 ELSEIF (igtyp == 10 .OR. igtyp == 11 .OR. igtyp == 16 .OR.
572 . igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52) THEN
573 DO j=1,npti
574 ilaw_ly = elbuf_str%BUFLY(j)%ILAW
575 IF (igtyp == 16 .OR.(igtyp == 51 .AND. ilaw_ly == 58)
576 . .OR.(igtyp == 52 .AND. ilaw_ly == 58) ) THEN
577 coor1(j,i) = sigsh(ipt+1,ii)
578 coor2(j,i) = sigsh(ipt+2,ii)
579 coor3(j,i) = sigsh(ipt+3,ii)
580 coor4(j,i) = sigsh(ipt+4,ii)
581 ipt = ipt + 4
582 ELSE
583 coor1(j,i) = sigsh(ipt+1,ii)
584 coor2(j,i) = sigsh(ipt+2,ii)
585 ipt = ipt + 2
586 ENDIF
587 ENDDO
588 iorthloc(i) = 1
589 ENDIF
590 110 CONTINUE
591 ENDDO
592 ENDIF
593C
594C--- Check projection
595 IF(irp /= 26 ) THEN
596 DO i=jft,jlt
597 v(i) =vx(i)*e3x(i)+vy(i)*e3y(i)+vz(i)*e3z(i)
598 vx(i)=vx(i)-v(i)*e3x(i)
599 vy(i)=vy(i)-v(i)*e3y(i)
600 vz(i)=vz(i)-v(i)*e3z(i)
601 v(i) =sqrt(vx(i)*vx(i)+vy(i)*vy(i)+vz(i)*vz(i))
602 ENDDO
603C
604 DO i=jft,jlt
605 IF (v(i) < em3 .AND. iorthloc(i) == 0 .AND.
606 . def_orth(i) /= 0)THEN
607 pid = ix(nix-1,i)
608 v(i)= max(v(i),em20)
609 CALL fretitl2(titr1,igeo(npropgi-ltitr+1,pid),ltitr)
610 CALL ancmsg(msgid=197,
611 . msgtype=msgerror,
612 . anmode=aninfo,
613 . i1=igeo(1,pid),
614 . c1=titr1,
615 . i2=ix(nix,i))
616 ENDIF
617 vx(i)=vx(i)/v(i)
618 vy(i)=vy(i)/v(i)
619 vz(i)=vz(i)/v(i)
620 ENDDO
621 ENDIF ! IRP
622C
623C----Beta angle computation(dyna input format)
624C
625 DO i=jft,jlt
626
627 e11= x2(i)-x1(i)
628 e12= y2(i)-y1(i)
629 e13= z2(i)-z1(i)
630 ne1 = sqrt(e11*e11+e12*e12+e13*e13)
631
632 betaorth(i) = (vx(i)*e11 + vy(i)*e12 +vz(i)*e13 )/max(ne1,em20)
633 ENDDO
634C----
635 ENDIF
636C-----------
637 RETURN
638 END
639
corthini
subroutine corthini(jft, jlt, nft, nlay, numel, nsigsh, nix, ix, igeo, geo, skew, sigsh, ptsh, phi1, phi2, vx, vy, vz, coor1, coor2, coor3, coor4, iorthloc, isubstack, stack, irep, elbuf_str, drape, angle, x, geo_stack, e3x, e3y, e3z, betaorth, x1, x2, y1, y2, z1, z2, nel, g_add_node, add_node, npt_all, idrape, indx)
Definition corthini.F:48
max
#define max(a, b)
Definition macros.h:21
drape_mod
Definition drape_mod.F:54
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
stack_mod
Definition stack_mod.F:72
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
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804