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
57 use element_mod , only : nixtg
58C-----------------------------------------------
59C I m p l i c i t T y p e s
60C-----------------------------------------------
61#include "implicit_f.inc"
62C-----------------------------------------------
63C G l o b a l P a r a m e t e r s
64C-----------------------------------------------
65#include "mvsiz_p.inc"
66C-----------------------------------------------
67C C o m m o n B l o c k s
68C-----------------------------------------------
69#include "param_c.inc"
70#include "com01_c.inc"
71#include "scr17_c.inc"
72#include "drape_c.inc"
73C-----------------------------------------------
74C D u m m y A r g u m e n t s
75C-----------------------------------------------
76 INTEGER JFT,JLT,NFT,NLAY,IPT,ID,NIX,NUMEL,NSIGSH,
77 . ISUBSTACK,IREP,NPT_ALL,IDRAPE
78 INTEGER IX(NIX,*),IGEO(NPROPGI,*),PTSH(*),IORTHLOC(*)
79 INTEGER, INTENT(IN) :: NEL,G_ADD_NODE,ADD_NODE(G_ADD_NODE*NEL)
80 INTEGER, DIMENSION(*) :: INDX
81 my_real
82 . GEO(NPROPG,*),SKEW(LSKEW,*),SIGSH(NSIGSH,*),VX(*),VY(*),VZ(*),
83 . PHI1(NPT_ALL,*),PHI2(NPT_ALL,*),COOR1(NPT_ALL,MVSIZ),COOR2(NPT_ALL,MVSIZ),
84 . COOR3(NPT_ALL,MVSIZ),COOR4(NPT_ALL,MVSIZ),
85 . ANGLE(*),GEO_STACK(NPROPG,*),X(3,*),BETAORTH(*)
86 my_real, DIMENSION(MVSIZ), INTENT(IN) :: E3X,E3Y,E3Z,X1,X2,Y1,Y2,Z1,Z2
87C------------------------------------------------------
88 TYPE(ELBUF_STRUCT_), TARGET :: ELBUF_STR
89 TYPE (STACK_PLY):: STACK
90 TYPE (DRAPE_) , DIMENSION(*), TARGET :: DRAPE
91C------------------------------------------------------
92C L o c a l V a r i a b l e s
93C-----------------------------------------------
94 INTEGER I,II,J,JJ,N,NPT,NPTI,IGTYP,IPID,PID,ISK,IPANG,IPPHI,
95 . IPTHK,IPPOS,IPDIR,ILAW_LY,
96 . DEF_ORTH(MVSIZ),N1,N2,IRP,NOD,IL,IT,NSLICE,IPT_ALL,NPTT,
97 . IE, IP,IPID_PLY,N3,N4
98 my_real V(MVSIZ),E11,E12,E13,NE1,VX0,VY0,VZ0,
99 . XC(MVSIZ),YC(MVSIZ),ZC(MVSIZ)
100 CHARACTER(LEN=NCHARTITLE)::TITR1
101
102 TYPE (DRAPE_PLY_) , POINTER :: DRAPE_PLY
103C=======================================================================
104 PID = IX(NIX-1,1)
105 IGTYP = IGEO(11,PID)
106 IRP = IGEO(14,PID)
107 DEF_ORTH(1:MVSIZ) = NLAY
108 IPDIR = 0
109C
110 IF (IGTYP == 1) THEN
111C non orthotropic property
112 RETURN
113 ELSE
114 IPANG = 200
115 IPPHI = 500
116.OR..OR. IF (IGTYP == 17 IGTYP == 51 IGTYP == 52 ) THEN
117 IPANG = 1
118 IPTHK = IPANG + NLAY
119 IPPOS = IPTHK + NLAY
120 IPDIR = IPPOS + NLAY
121 ENDIF
122 SELECT CASE (IRP)
123 CASE (0) !
124 ISK = IGEO(2,PID)
125 DO I=JFT,JLT
126 IF (ISK == 0) THEN
127 VX(I) = GEO(7,PID)
128 VY(I) = GEO(8,PID)
129 VZ(I) = GEO(9,PID)
130 ELSE
131 VX(I) = SKEW(1,ISK)
132 VY(I) = SKEW(2,ISK)
133 VZ(I) = SKEW(3,ISK)
134 ENDIF
135 ENDDO
136 CASE (20) ! N1---> N2 (nodes)
137 DO I=JFT,JLT
138 N1=IX(2,I)
139 N2=IX(3,I)
140 VX(I) = X(1,N2)-X(1,N1)
141 VY(I) = X(2,N2)-X(2,N1)
142 VZ(I) = X(3,N2)-X(3,N1)
143 ENDDO
144 CASE (22) ! Iskew
145 ISK = IGEO(2,PID) !
146 DO I=JFT,JLT
147 VX(I) = SKEW(1,ISK)
148 VY(I) = SKEW(2,ISK)
149 VZ(I) = SKEW(3,ISK)
150 ENDDO
151 CASE (23) ! Proj on the element V x normal_eleemt
152 VX0 = GEO(7,PID)
153 VY0 = GEO(8,PID)
154 VZ0 = GEO(9,PID)
155 DO I=JFT,JLT
156 VX(I) = E3Y(I)*VZ0 - E3Z(I)*VY0
157 VY(I) = E3Z(I)*VX0 - E3X(I)*VZ0
158 VZ(I) = E3X(I)*VY0 - E3Y(I)*VX0
159 ENDDO
160 CASE (24)
161C-- seatbelt elements - dir1 defined by N1 and ADD_NODE (can be either N2 or N4)
162 DO I=JFT,JLT
163 N1=IX(2,I)
164 NOD=ADD_NODE(I)
165 VX(I) = X(1,NOD)-X(1,N1)
166 VY(I) = X(2,NOD)-X(2,N1)
167 VZ(I) = X(3,NOD)-X(3,N1)
168 ENDDO
169 CASE (25)
170C-- y' of cylintrical sys (using xc,yc,zc)
171 ISK = IGEO(2,PID)
172 IF (NIX > NIXTG) THEN
173 DO I=JFT,JLT
174 N1=IX(2,I)
175 N2=IX(3,I)
176 N3=IX(4,I)
177 N4=IX(5,I)
178 XC(I) = FOURTH*(X(1,N1)+X(1,N2)+X(1,N3)+X(1,N4))
179 YC(I) = FOURTH*(X(2,N1)+X(2,N2)+X(2,N3)+X(2,N4))
180 ZC(I) = FOURTH*(X(3,N1)+X(3,N2)+X(3,N3)+X(3,N4))
181 ENDDO
182 ELSE
183 DO I=JFT,JLT
184 N1=IX(2,I)
185 N2=IX(3,I)
186 N3=IX(4,I)
187 XC(I) = THIRD*(X(1,N1)+X(1,N2)+X(1,N3))
188 YC(I) = THIRD*(X(2,N1)+X(2,N2)+X(2,N3))
189 ZC(I) = THIRD*(X(3,N1)+X(3,N2)+X(3,N3))
190 ENDDO
191 END IF
192 DO I=JFT,JLT
193 E11 = XC(I)-SKEW(10,ISK)
194 E12 = YC(I)-SKEW(11,ISK)
195 E13 = ZC(I)-SKEW(12,ISK)
196 VX(I) = SKEW(8,ISK)*E13 - SKEW(9,ISK)*E12
197 VY(I) = SKEW(9,ISK)*E11 - SKEW(7,ISK)*E13
198 VZ(I) = SKEW(7,ISK)*E12 - SKEW(8,ISK)*E11
199 ENDDO
200 END SELECT
201C--- read property data
202 IF (IGTYP == 9) THEN
203 DO I=JFT,JLT
204 PHI1(1,I)= GEO(10,PID)
205 ENDDO
206 ELSEIF (IGTYP == 10) THEN
207 DO I=JFT,JLT
208 DO J=1,NLAY
209 PHI1(J,I)= GEO(IPANG+J,PID)
210 ENDDO
211 ENDDO
212 ELSEIF (IGTYP == 11) THEN
213 DO I=JFT,JLT
214 DO J=1,NLAY
215 PHI1(J,I)= GEO(IPANG+J,PID)
216 ENDDO
217 ENDDO
218.AND. ELSEIF (IGTYP == 17 IRP /= 24) THEN !
219 IF(IDRAPE > 0) THEN
220 DO I=JFT,JLT
221 IPANG = 1
222 IE = INDX(NFT + I)
223 IF(IE == 0) THEN
224 DO J=1,NLAY
225 IPID_PLY = STACK%IGEO(2 + J,ISUBSTACK)
226 IF(IPID_PLY > 0) THEN
227 PHI1(J,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG+J,ISUBSTACK) ! + stack_angle
228 IF (IREP >= 2) PHI2(J,I)= STACK%GEO(IPDIR+J,ISUBSTACK)
229 DEF_ORTH(I) = DEF_ORTH(I) - 1
230 ENDIF
231 ENDDO
232 ELSE ! ie > 0
233 DO J=1,NLAY
234 IPID_PLY = STACK%IGEO(2+J,ISUBSTACK)
235 IF(IPID_PLY > 0) THEN
236 PHI1(J,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG+J,ISUBSTACK) ! + stack_angle
237 IF (IREP >= 2) PHI2(J,I)= STACK%GEO(IPDIR+J,ISUBSTACK)
238 DEF_ORTH(I) = DEF_ORTH(I) - 1
239 IP = DRAPE(IE)%INDX_PLY(J)
240 IF(IP > 0) THEN
241 DRAPE_PLY => DRAPE(IE)%DRAPE_PLY(IP)
242 PHI1(J,I) = PHI1(J,I) + DRAPE_PLY%RDRAPE(1,2)
243 ENDIF
244 ENDIF
245 ENDDO
246 ENDIF
247 ENDDO
248 ELSE ! idrape== 0
249 DO I=JFT,JLT
250 IPANG = 1
251 DO J=1,NLAY
252 IPID_PLY = STACK%IGEO(2+J,ISUBSTACK)
253 IF(IPID_PLY > 0) THEN
254 PHI1(J,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG+J,ISUBSTACK)
255 DEF_ORTH(I) = DEF_ORTH(I) - 1
256 IF (IREP >= 2) PHI2(J,I)= STACK%GEO(IPDIR+J,ISUBSTACK)
257 ENDIF
258 ENDDO
259 ENDDO
260 ENDIF ! idrape
261.AND. ELSEIF(IGTYP == 51 IRP /= 24 ) THEN !
262 IF(IDRAPE > 0) THEN
263 DO I=JFT,JLT
264 IPANG = 1
265 IPT_ALL = 0
266 IE = INDX(NFT + I)
267 IF(IE > 0) THEN
268 DO IL=1,NLAY
269 NPTT = ELBUF_STR%BUFLY(IL)%NPTT
270 IP = DRAPE(IE)%INDX_PLY(IL)
271 IPID_PLY = STACK%IGEO(2 + IL,ISUBSTACK)
272 IF(IPID_PLY > 0) THEN
273 IF(IP > 0) THEN
274 DRAPE_PLY => DRAPE(IE)%DRAPE_PLY(IP)
275 NSLICE = DRAPE_PLY%NSLICE ! NPTT
276 DEF_ORTH(I) = DEF_ORTH(I) - 1 !
277 IF(IREP >= 2) THEN
278 DO IT = 1,NPTT
279 IPT = IPT_ALL + IT
280 PHI1(IPT,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG+IL,ISUBSTACK)
281 . + DRAPE_PLY%RDRAPE(IT,2)
282 PHI2(IPT,I) = STACK%GEO(IPDIR + IL,ISUBSTACK)
283 ENDDO ! NPTT
284 ELSE
285 DO IT = 1,NPTT
286 IPT = IPT_ALL + IT
287 PHI1(IPT,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG+IL,ISUBSTACK)
288 . + DRAPE_PLY%RDRAPE(IT,2)
289 ENDDO ! NPTT
290 ENDIF ! IREP
291 ELSE !IP == 0
292 DEF_ORTH(I) = DEF_ORTH(I) - 1
293 IF(IREP >= 2) THEN
294 DO IT = 1,NPTT
295 IPT = IPT_ALL + IT
296 PHI1(IPT,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
297 PHI2(IPT,I) = STACK%GEO(IPDIR+IL,ISUBSTACK)
298 ENDDO ! NPTT
299 ELSE
300 DO IT = 1,NPTT
301 IPT = IPT_ALL + IT
302 PHI1(IPT,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
303 ENDDO ! NPTT
304 ENDIF
305 ENDIF ! IP
306 ENDIF ! IPID_PLY > 0
307 IPT_ALL = IPT_ALL + NPTT
308 ENDDO ! NLAY
309 ELSE !IE == 0
310 DO IL=1,NLAY
311 NPTT = ELBUF_STR%BUFLY(IL)%NPTT
312 IPID_PLY = STACK%IGEO(2 + IL,ISUBSTACK)
313 IF(IPID_PLY > 0) THEN
314 DEF_ORTH(I) = DEF_ORTH(I) - 1
315 IF(IREP >= 2) THEN
316 DO IT = 1,NPTT
317 IPT = IPT_ALL + IT
318 PHI1(IPT,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
319 PHI2(IPT,I) = STACK%GEO(IPDIR+IL,ISUBSTACK)
320 ENDDO ! NPTT
321 ELSE
322 DO IT = 1,NPTT
323 IPT = IPT_ALL + IT
324 PHI1(IPT,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
325 ENDDO ! NPTT
326 ENDIF
327 ENDIF
328 IPT_ALL = IPT_ALL + NPTT
329 ENDDO ! NLAY
330 ENDIF !IE
331 ENDDO ! JFT:JLT
332 ELSE ! IDRAPE = 0
333 DO I=JFT,JLT
334 IPANG = 1
335 DO IL=1,NLAY
336 IPID_PLY = STACK%IGEO(2 + IL,ISUBSTACK)
337 IF(IPID_PLY > 0 ) THEN
338 PHI1(IL,I) = ANGLE(I) + GEO(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
339 DEF_ORTH(I) = DEF_ORTH(I) - 1
340 ENDIF
341 IF (IREP >= 2) PHI2(IL,I)= STACK%GEO(IPDIR + IL,ISUBSTACK)
342 ENDDO
343 ENDDO
344 ENDIF ! idrape
345.AND. ELSEIF(IGTYP == 52 IRP /= 24 ) THEN
346 IF(IDRAPE > 0) THEN
347 DO I=JFT,JLT
348 IPANG = 1
349 IPT_ALL = 0
350 IE = INDX(NFT + I)
351 IF(IE > 0) THEN
352 DO IL=1,NLAY
353 NPTT = ELBUF_STR%BUFLY(IL)%NPTT
354 IP = DRAPE(IE)%INDX_PLY(IL)
355 IPID_PLY = STACK%IGEO(2+IL,ISUBSTACK)
356 IF( IPID_PLY > 0) THEN
357 IF(IP > 0) THEN !
358 DRAPE_PLY => DRAPE(IE)%DRAPE_PLY(IP)
359 NSLICE = DRAPE_PLY%NSLICE ! NPTT
360 DEF_ORTH(I) = DEF_ORTH(I) - 1
361 IF(IREP >= 2) THEN
362 DO IT = 1,NPTT
363 IPT = IPT_ALL + IT
364 PHI1(IPT,I) = ANGLE(I) + GEO_STACK(2,IPID_PLY)
365 . + STACK%GEO(IPANG + IL,ISUBSTACK) + DRAPE_PLY%RDRAPE(IT,2)
366 PHI2(IPT,I)= STACK%GEO(IPDIR+IL,ISUBSTACK)
367 ENDDO ! NPTT
368 ELSE
369 DO IT = 1,NPTT
370 IPT = IPT_ALL + IT
371 PHI1(IPT,I) = ANGLE(I) + GEO_STACK(2,IPID_PLY)
372 . + STACK%GEO(IPANG + IL,ISUBSTACK) + DRAPE_PLY%RDRAPE(IT,2)
373 ENDDO ! NPTT
374 ENDIF
375 ELSE !IP == 0
376 DEF_ORTH(I) = DEF_ORTH(I) - 1
377 IF(IREP >= 2) THEN
378 DO IT = 1,NPTT
379 IPT = IPT_ALL + IT
380 PHI1(IPT,I) = ANGLE(I) + GEO_STACK(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
381 PHI2(IPT,I) = STACK%GEO(IPDIR+IL,ISUBSTACK)
382 ENDDO ! NPTT
383 ELSE
384 DO IT = 1,NPTT
385 IPT = IPT_ALL + IT
386 PHI1(IPT,I) = ANGLE(I) + GEO_STACK(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
387 ENDDO ! NPTT
388 ENDIF ! IREP
389 ENDIF !IP
390 ENDIF ! IPID_PLY
391 IPT_ALL = IPT_ALL + NPTT
392 ENDDO ! NLAY
393 ELSE !IE == 0
394 DO IL=1,NLAY
395 NPTT = ELBUF_STR%BUFLY(IL)%NPTT
396 IPID_PLY = STACK%IGEO(2+IL,ISUBSTACK)
397 IF(IPID_PLY > 0) THEN
398 DEF_ORTH(I) = DEF_ORTH(I) - 1
399 IF(IREP >= 2)THEN
400 DO IT = 1,NPTT
401 IPT = IPT_ALL + IT
402 PHI1(IPT,I) = ANGLE(I) + GEO_STACK(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
403 PHI2(IPT,I)= STACK%GEO(IPDIR+IL,ISUBSTACK)
404 ENDDO ! NPTT
405 ELSE
406 DO IT = 1,NPTT
407 IPT = IPT_ALL + IT
408 PHI1(IPT,I) = ANGLE(I) + GEO_STACK(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
409 ENDDO ! NPT
410 ENDIF ! IREP
411 ENDIF
412 IPT_ALL = IPT_ALL + NPTT
413 ENDDO ! NLAY
414 ENDIF !IE
415 ENDDO ! JFT:JLT
416 ELSE ! IDRAPE = 0
417 DO I=JFT,JLT
418 IPANG = 1
419 DO IL=1,NLAY
420 IPID_PLY = STACK%IGEO(2+IL,ISUBSTACK)
421 IF(IPID_PLY > 0) THEN
422 DEF_ORTH(I) = DEF_ORTH(I) - 1
423 PHI1(IL,I) = ANGLE(I) + GEO_STACK(2,IPID_PLY) + STACK%GEO(IPANG + IL,ISUBSTACK)
424 IF(IREP >= 2) PHI2(IL,I)= STACK%GEO(IPDIR+IL,ISUBSTACK)
425 ENDIF ! IPID_PLY
426 ENDDO
427 ENDDO
428 ENDIF ! idrape
429 ELSEIF (IGTYP == 16) THEN
430 DO I=JFT,JLT
431 DO J=1,NLAY
432 PHI1(J,I)= GEO(IPANG+J,PID)
433 PHI2(J,I)= GEO(IPPHI+J,PID)
434 ENDDO
435 ENDDO
436 ENDIF
437C--- Overwrite with optional element data
438 IF (IORTSHEL == 1) THEN
439 DO I=JFT,JLT
440.AND..AND. IF (ABS(ISIGI) /= 3 ABS(ISIGI)/=4 ABS(ISIGI)/=5) THEN
441 !!II = I + NFT
442 ID = IX(NIX,I)
443 II = PTSH(I + NFT)
444 IF(II == 0) GOTO 100
445 N = NINT(SIGSH(1,II))
446 IF (N == ID) THEN
447 CONTINUE
448 ELSE
449 DO J = 1,NUMEL
450 II = J
451 N = NINT(SIGSH(1,II))
452 IF (N == ID) GOTO 60
453 IF (N == 0) GOTO 100
454 ENDDO
455 GOTO 100
456 60 CONTINUE
457 ENDIF
458 ELSE
459 JJ=NFT+I
460 N =IX(NIX,I)
461 II=PTSH(JJ)
462 IF (II == 0) GOTO 100
463 END IF
464 IF(SIGSH(NVSHELL + NUSHELL + 5,II) == ZERO) CYCLE
465C
466 NPTI = NINT(SIGSH(NVSHELL + NUSHELL + 4,II))
467 IF(IGTYP == 9) NPTI = 1
468 IF (NLAY /= NPTI) THEN
469 IPID = IX(NIX-1,I)
470 PID = IGEO(1,IPID)
471 CALL FRETITL2(TITR1,IGEO(NPROPGI-LTITR+1,IPID),LTITR)
472 IF (NPTI == 0) THEN
473 CALL ANCMSG(MSGID=355,
474 . MSGTYPE=MSGWARNING,
475 . ANMODE=ANINFO_BLIND_1,
476 . I1=N,
477 . I2=PID,
478 . C1=TITR1)
479 ELSE
480 CALL ANCMSG(MSGID=26,
481 . ANMODE=ANINFO,
482 . MSGTYPE=MSGERROR,
483 . I2=N,
484 . I1=PID,
485 . C1=TITR1)
486 ENDIF
487 ENDIF
488C
489 IPT = NVSHELL + NUSHELL
490 VX(I) = SIGSH(IPT+1,II)
491 VY(I) = SIGSH(IPT+2,II)
492 VZ(I) = SIGSH(IPT+3,II)
493 IPT = IPT + 5
494 IF ( IGTYP == 9) THEN
495 PHI1(1,I) = SIGSH(IPT+1,II)
496 PHI2(1,I) = SIGSH(IPT+2,II)
497 IPT = IPT + 2
498 ELSE
499 DO J=1,NPTI
500 PHI1(J,I) = SIGSH(IPT+1,II)
501 PHI2(J,I) = SIGSH(IPT+2,II)
502 IPT = IPT + 2
503 ENDDO
504 ENDIF
505 100 CONTINUE
506 ENDDO
507 ENDIF
508C
509C--- Overwrite with optional element data__ ORTH_LOC
510 IF (IORTSHEL == 2) THEN
511 DO I=JFT,JLT
512 IE = I + NFT
513.AND..AND. IF (ABS(ISIGI) /= 3 ABS(ISIGI) /= 4 ABS(ISIGI) /= 5) THEN
514 ID = IX(NIX,I)
515 II = PTSH(IE)
516 IF(II == 0) GOTO 110
517 N = NINT(SIGSH(1,II))
518 IF (N == ID) THEN
519 CONTINUE
520 ELSE
521 DO J = 1,NUMEL
522 II = J
523 N = NINT(SIGSH(1,II))
524 IF (N == ID) GOTO 70
525 IF (N == 0) GOTO 110
526 ENDDO
527 GOTO 110
528 70 CONTINUE
529 ENDIF
530 ELSE
531 JJ=NFT+I
532 N =IX(NIX,I)
533 II=PTSH(JJ)
534 IF (II == 0) GOTO 110
535 END IF
536 IF(SIGSH(NVSHELL + NUSHELL + 5,II) == ZERO) CYCLE
537 NPTI = NINT(SIGSH(NVSHELL + NUSHELL + 4,II))
538C
539 NPT = NINT(GEO(6,IX(NIX-1,I)))
540.AND..OR. IF(IDRAPE > 0 (IGTYP == 51 IGTYP==52)) THEN
541 NPT = NPT_ALL
542.OR..OR..OR. ELSEIF (IGTYP == 16 IGTYP == 17 IGTYP == 51 IGTYP == 52) THEN
543 NPT = NLAY
544 ENDIF
545 IF (NPT /= NPTI) THEN
546 IPID = IX(NIX-1,I)
547 PID = IGEO(1,IPID)
548 CALL FRETITL2(TITR1,IGEO(NPROPGI-LTITR+1,IPID),LTITR)
549 IF (NPTI == 0) THEN
550 CALL ANCMSG(MSGID=355,
551 . MSGTYPE=MSGWARNING,
552 . ANMODE=ANINFO_BLIND_1,
553 . I1=N,
554 . I2=PID,
555 . C1=TITR1)
556 ELSE
557 CALL ANCMSG(MSGID=26,
558 . ANMODE=ANINFO,
559 . MSGTYPE=MSGERROR,
560 . I2=N,
561 . I1=PID,
562 . C1=TITR1)
563 ENDIF
564 ENDIF
565C
566 IPT = NVSHELL + NUSHELL + 5
567 IF (IGTYP == 9) THEN
568 COOR1(1,I) = SIGSH(IPT+1,II)
569 COOR2(1,I) = SIGSH(IPT+2,II)
570 IPT = IPT + 2
571 IORTHLOC(I) = 1
572.OR..OR..OR. ELSEIF (IGTYP == 10 IGTYP == 11 IGTYP == 16
573.OR..OR. . IGTYP == 17 IGTYP == 51 IGTYP == 52) THEN
574 DO J=1,NPTI
575 ILAW_LY = ELBUF_STR%BUFLY(J)%ILAW
576.OR..AND. IF (IGTYP == 16 (IGTYP == 51 ILAW_LY == 58)
577.OR..AND. . (IGTYP == 52 ILAW_LY == 58) ) THEN
578 COOR1(J,I) = SIGSH(IPT+1,II)
579 COOR2(J,I) = SIGSH(IPT+2,II)
580 COOR3(J,I) = SIGSH(IPT+3,II)
581 COOR4(J,I) = SIGSH(IPT+4,II)
582 IPT = IPT + 4
583 ELSE
584 COOR1(J,I) = SIGSH(IPT+1,II)
585 COOR2(J,I) = SIGSH(IPT+2,II)
586 IPT = IPT + 2
587 ENDIF
588 ENDDO
589 IORTHLOC(I) = 1
590 ENDIF
591 110 CONTINUE
592 ENDDO
593 ENDIF
594C
595C--- Check projection
596 IF(IRP /= 26 ) THEN
597 DO I=JFT,JLT
598 V(I) =VX(I)*E3X(I)+VY(I)*E3Y(I)+VZ(I)*E3Z(I)
599 VX(I)=VX(I)-V(I)*E3X(I)
600 VY(I)=VY(I)-V(I)*E3Y(I)
601 VZ(I)=VZ(I)-V(I)*E3Z(I)
602 V(I) =SQRT(VX(I)*VX(I)+VY(I)*VY(I)+VZ(I)*VZ(I))
603 ENDDO
604C
605 DO I=JFT,JLT
606.AND..AND. IF (V(I) < EM3 IORTHLOC(I) == 0
607 . DEF_ORTH(I) /= 0)THEN
608 PID = IX(NIX-1,I)
609 V(I)= MAX(V(I),EM20)
610 CALL FRETITL2(TITR1,IGEO(NPROPGI-LTITR+1,PID),LTITR)
611 CALL ANCMSG(MSGID=197,
612 . MSGTYPE=MSGERROR,
613 . ANMODE=ANINFO,
614 . I1=IGEO(1,PID),
615 . C1=TITR1,
616 . I2=IX(NIX,I))
617 ENDIF
618 VX(I)=VX(I)/V(I)
619 VY(I)=VY(I)/V(I)
620 VZ(I)=VZ(I)/V(I)
621 ENDDO
622 ENDIF ! IRP
623C
624C----Beta angle computation(dyna input format)
625C
626 DO I=JFT,JLT
627
628 E11= X2(I)-X1(I)
629 E12= Y2(I)-Y1(I)
630 E13= Z2(I)-Z1(I)
631 NE1 = SQRT(E11*E11+E12*E12+E13*E13)
632
633 BETAORTH(I) = (VX(I)*E11 + VY(I)*E12 +VZ(I)*E13 )/MAX(NE1,EM20)
634 ENDDO
635C----
636 ENDIF
637C-----------
638 RETURN
639 END
640
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
drape_mod
Definition drape_mod.F:54
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
stack_mod
Definition stack_mod.F:75
starter
program starter
Definition starter.F:39