OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
imp_glob_k.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!|| imp_glob_k ../engine/source/implicit/imp_glob_k.F
25!||--- called by ------------------------------------------------------
26!|| imp_k_eig ../engine/stub/imp_k_eig.F
27!||--- calls -----------------------------------------------------
28!|| c3ke3 ../engine/source/elements/sh3n/coque3n/c3ke3.F
29!|| cbake3 ../engine/source/elements/shell/coqueba/cbake3.F
30!|| czke3 ../engine/source/elements/shell/coquez/czke3.F
31!|| initbuf ../engine/share/resol/initbuf.F
32!|| pke3 ../engine/source/elements/beam/pke3.F
33!|| r12ke3 ../engine/source/elements/spring/r12ke3.F
34!|| r13ke3 ../engine/source/elements/spring/r13ke3.F
35!|| r4ke3 ../engine/source/elements/spring/r4ke3.F
36!|| r8ke3 ../engine/source/elements/spring/r8ke3.F
37!|| s10ke3 ../engine/source/elements/solid/solide10/s10ke3.F
38!|| s20ke3 ../engine/source/elements/solid/solide20/s20ke3.F
39!|| s4ke3 ../engine/source/elements/solid/solide4/s4ke3.F
40!|| s6cke3 ../engine/source/elements/thickshell/solide6c/s6cke3.F
41!|| s8cke3 ../engine/source/elements/thickshell/solide8c/s8cke3.F
42!|| s8ske3 ../engine/source/elements/solid/solide8s/s8ske3.F
43!|| s8zke3 ../engine/source/elements/solid/solide8z/s8zke3.F
44!|| startimeg ../engine/source/system/timer.F
45!|| tke3 ../engine/source/elements/truss/tke3.F
46!||--- uses -----------------------------------------------------
47!|| drape_mod ../engine/share/modules/drape_mod.F
48!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
49!|| element_mod ../common_source/modules/elements/element_mod.F90
50!|| initbuf_mod ../engine/share/resol/initbuf.F
51!|| stack_mod ../engine/share/modules/stack_mod.F
52!||====================================================================
53 SUBROUTINE imp_glob_k(
54 1 PM ,GEO ,IPM ,IGEO ,ELBUF ,
55 2 IXS ,IXQ ,IXC ,IXT ,IXP ,
56 3 IXR ,IXTG ,IXTG1 ,IXS10 ,
57 4 IXS20 ,IXS16 ,IPARG ,TF ,NPC ,
58 5 FR_WAVE ,W16 ,BUFMAT ,THKE ,BUFGEO ,
59 6 RBY ,SKEW ,X ,
60 7 WA ,IDDL ,NDOF ,K_DIAG ,K_LT ,
61 8 IADK ,JDIK ,IKGEO ,ETAG ,ELBUF_TAB ,
62 9 STACK ,DRAPE_SH4N, DRAPE_SH3N ,DRAPEG )
63C-----------------------------------------------
64C M o d u l e s
65C-----------------------------------------------
66 USE initbuf_mod
67 USE elbufdef_mod
68 USE stack_mod
69 USE drape_mod
70 use element_mod , only : nixs,nixq,nixc,nixt,nixtg,nixp,nixr
71C----6---------------------------------------------------------------7---------8
72C I m p l i c i t T y p e s
73C-----------------------------------------------
74#include "implicit_f.inc"
75#include "comlock.inc"
76C-----------------------------------------------
77C G l o b a l P a r a m e t e r s
78C-----------------------------------------------
79#include "mvsiz_p.inc"
80C-----------------------------------------------
81C C o m m o n B l o c k s
82C-----------------------------------------------
83#include "com01_c.inc"
84#include "com04_c.inc"
85#include "param_c.inc"
86#include "vect01_c.inc"
87#include "scr14_c.inc"
88#include "task_c.inc"
89#include "units_c.inc"
90#include "impl1_c.inc"
91C-----------------------------------------------------------------
92C D u m m y A r g u m e n t s
93C-----------------------------------------------
94 INTEGER IDDL(*) ,NDOF(*) ,IADK(*) ,JDIK(*) ,
95 . IPM(NPROPMI,*),IGEO(NPROPGI,*),IKGEO
96 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
97 . IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*),
98 . NPC(*), IPARG(NPARG,*),
99 . IXS10(6,*),IXS20(12,*),IXS16(8,*),IXTG1(4,*), ETAG(*)
100C REAL
101 my_real
102 . PM(NPROPM,*),GEO(NPROPG,*),BUFMAT(*) ,TF(*) ,
103 . fr_wave(*) ,elbuf(*) ,thke(*),rby(*),skew(lskew,*),
104 . bufgeo(*),w16(*),x(3,*),wa(*)
105 my_real
106 . k_diag(*) ,k_lt(*)
107 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
108 TYPE (STACK_PLY) :: STACK
109 TYPE (DRAPE_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
110 TYPE (DRAPEG_) :: DRAPEG
111C-----------------------------------------------
112C L o c a l V a r i a b l e s
113C-----------------------------------------------
114 INTEGER I,N, NG, NVC, MLW, JFT, JLT,ISOLNOD,ITHK ,IPLA ,
115 . K1, K2, KAD,IAD2,NF1,IPRI, NELEM, OFFSET, NSGRP, K,
116 . k0, k3, k5, k6, k7, k8, k9, nsg, nel, kfts,iofc, istra,
117 . jj19,npe,nipmax,icnod,nft1,nf2,mpt,
118 . l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,l11,l12,l13,l14,l15,l16,
119 . l17,l18,l19,l20,l21,l22,l23,l24,l25,l26,l27,l28,l29,l30,
120 . sedrape,numel_drape
121 INTEGER INDXOF(MVSIZ),ISH3N,IPRMES_EL(50)
122 INTEGER ICP,ICS,IEXPAN,IETY,IG,ISUBSTACK
123 SAVE
124 . iprmes_el
125 my_real
126 . off(mvsiz)
127C----6---------------------------------------------------------------7-2
128 DO ng = 1, ngroup
129c NG = IGROUC(IG)
130c IF(NGDONE>NGROUP) GOTO 250
131c NGDONE = NG + 1
132C
133 IF(iparg(8,ng)==1)GOTO 250
134 IF (iddw>0) CALL startimeg(ng)
135 IF (ng==1) THEN
136 DO i=1,50
137 iprmes_el(i)=0
138 ENDDO
139 END IF !(NG==1) THEN
140 ity =iparg(5,ng)
141 offset = 0
142 mlw = iparg(1,ng)
143 IF (mlw == 0 .OR. mlw == 13) GOTO 250
144 CALL initbuf(iparg ,ng ,
145 2 mlw ,nel ,nft ,kad ,ity ,
146 3 npt ,jale ,ismstr ,jeul ,jtur ,
147 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
148 5 nvaux ,jpor ,jcvt ,jclose ,ipla ,
149 6 irep ,iint ,igtyp ,israt ,isrot ,
150 7 icsen ,isorth ,isorthg ,ifailure,jsms )
151c
152 icnod = iparg(11,ng)
153 nsg = iparg(10,ng)
154 icp = iparg(10,ng)
155 ics = iparg(17,ng)
156 istra = iparg(44,ng)
157 nvc = iparg(19,ng)
158 ithk = iparg(28,ng)
159 isolnod = iparg(28,ng)
160 kfts = iparg(30,ng)
161 iexpan = iparg(49,ng)
162 ish3n = iparg(23,ng)
163 isubstack=iparg(71,ng)
164 IF(ity==1.OR.ity==2) jplasol=ipla
165 iformdt = 0
166 lft = 1
167 llt = min(nvsiz,nel)
168 mtn = mlw
169 jft=lft
170 jlt=llt
171 nf1 = nft+1
172 iad = kad
173C
174 jsph=0
175C----6---------------------------------------------------------------7---------8
176 IF(ity==1 .AND. jlag==1)THEN
177 igtyp = nint(geo(12,ixs(10,nf1)))
178 IF(isolnod==4)THEN
179 iety=1
180 IF (isrot > 0 .AND. ispmd==0) THEN
181 IF (iprmes_el(iety)==0) THEN
182 WRITE(iout,1005)isrot
183 iprmes_el(iety)=1
184 ENDIF
185 ENDIF
186 CALL s4ke3(
187 1 pm, geo, ixs, x,
188 2 elbuf_tab(ng)%GBUF, etag, iddl,
189 3 ndof, k_diag, k_lt, iadk,
190 4 jdik, nel, ipm, igeo,
191 5 ikgeo, bufmat, nft, mtn,
192 6 ismstr, jhbe, irep, isorth,
193 7 iformdt)
194
195 ELSEIF(isolnod==10)THEN
196 CALL s10ke3(
197 1 pm, geo, ixs, ixs10,
198 2 x, elbuf_tab(ng),etag, iddl,
199 3 ndof, k_diag, k_lt, iadk,
200 4 jdik, nel, ipm, igeo,
201 5 ikgeo, bufmat, nft, mtn,
202 6 npt, ismstr, jhbe, irep,
203 7 isorth, jlag)
204
205 ELSEIF(isolnod==20)THEN
206 CALL s20ke3(
207 1 pm, geo, ixs, ixs20,
208 2 x, elbuf_tab(ng),etag, iddl,
209 3 ndof, k_diag, k_lt, iadk,
210 4 jdik, nel, ipm, igeo,
211 5 ikgeo, bufmat, nft, mtn,
212 6 ismstr, jhbe, irep, igtyp,
213 7 isorth)
214 ELSEIF(isolnod==16)THEN
215 iety=2
216 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
217 WRITE(iout,1001)' S16 SOLID'
218 WRITE(istdo,1001)' S16 SOLID'
219 iprmes_el(iety)=1
220 ENDIF
221 ELSEIF(jhbe==15.AND.isolnod==6)THEN
222 CALL s6cke3(
223 1 pm, geo, ixs, x,
224 2 elbuf_tab(ng),etag, iddl, ndof,
225 3 k_diag, k_lt, iadk, jdik,
226 4 nel, icp, ics, ipm,
227 5 igeo, ikgeo, bufmat, nft,
228 6 mtn, jhbe, isorth, isorthg,
229 7 ismstr)
230C
231 ELSEIF(isolnod==8)THEN
232C NIPMAX = 729
233C L1 = 1
234C L2 = L1 + MVSIZ * NIPMAX
235C L3 = L2 + MVSIZ * NIPMAX
236 IF (jhbe/=14.AND.jhbe/=15.AND.jhbe/=17) THEN
237 IF (ncycle==1.AND.imconv==1)THEN
238 IF(jhbe==24)THEN
239 iety=3
240 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
241 WRITE(iout,1002)jhbe
242 iprmes_el(iety)=1
243 ENDIF
244 ELSEIF(jhbe==12.OR.jhbe==112)THEN
245 iety=4
246 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
247 WRITE(iout,1002)jhbe
248 iprmes_el(iety)=1
249 ENDIF
250 ELSEIF(jhbe==0)THEN
251 iety=5
252 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
253 WRITE(iout,1002)jhbe
254 iprmes_el(iety)=1
255 ENDIF
256 ELSE
257 iety=6
258 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
259 WRITE(iout,1002)jhbe
260 iprmes_el(iety)=1
261 ENDIF
262 ENDIF
263 ENDIF
264 ENDIF
265c
266 IF (jhbe == 14 .AND.
267 . (igtyp == 20 .OR. igtyp == 21 .OR. igtyp == 22)) THEN
268 CALL s8cke3(
269 1 pm, geo, ixs, x,
270 2 elbuf_tab(ng),nel, icp, ics,
271 3 etag, iddl, ndof, k_diag,
272 4 k_lt, iadk, jdik, ipm,
273 5 igeo, ikgeo, bufmat, nft,
274 6 mtn, jhbe, jcvt, igtyp,
275 7 isorth, irep, ismstr)
276 ELSE IF(jhbe == 17 .AND. iparg(36,ng) == 2) THEN
277 mpt = 222
278 CALL s8ske3(
279 1 pm, geo, ixs, x,
280 2 elbuf_tab(ng),nel, icp, ics,
281 3 etag, iddl, ndof, k_diag,
282 4 k_lt, iadk, jdik, mpt,
283 5 ipm, igeo, ikgeo, bufmat,
284 6 nft, mtn, jhbe, jcvt,
285 7 igtyp, isorth)
286 ELSE
287 mpt = 222
288 CALL s8zke3(
289 1 pm, geo, ixs, x,
290 2 elbuf_tab(ng),nel, icp, ics,
291 3 etag, iddl, ndof, k_diag,
292 4 k_lt, iadk, jdik, mpt,
293 5 ipm, igeo, ikgeo, bufmat,
294 6 nft, mtn, ismstr, jhbe,
295 7 jcvt, igtyp, isorth, irep)
296 ENDIF
297
298C OPEN(UNIT=16,FILE='KE_S.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
299C CALL IMPKSOUT( IXS,NFT,NEL,16,
300C 1 K11 ,K12 ,K13 ,K14 ,K15 ,
301C 2 K16 ,K17 ,K18 ,K22 ,K23 ,
302C 3 K24 ,K25 ,K26 ,K27 ,K28 ,
303C 4 K33 ,K34 ,K35 ,K36 ,K37 ,
304C 5 K38 ,K44 ,K45 ,K46 ,K47 ,
305C 6 K48 ,K55 ,K56 ,K57 ,K58 ,
306C 7 K66 ,K67 ,K68 ,K77 ,K78 ,
307C 8 K88 )
308C----6---------------------------------------------------------------7---------8
309 ELSEIF(igtyp>=29)THEN
310 iety=7
311 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
312 WRITE(iout,1001)' USERS '
313 WRITE(istdo,1001)' USERS '
314 iprmes_el(iety)=1
315 ENDIF
316C CALL SUKE3(
317 ELSEIF(npt==1)THEN
318 IF(ng/=ngroup)THEN
319 iad2 = iparg(4,ng+1) - 21 * nel
320 ELSE
321 iad2 = lbufel - 21 * nel + 1
322 ENDIF
323 IF(jhbe==24)THEN
324C------------- It is not likely to enter here for the moment
325C CALL SZKE3(
326C 1 PM ,GEO ,IXS ,X ,ELBUF(KAD),
327C 1 K11 ,K12 ,K13 ,K14 ,K15 ,
328C 2 K16 ,K17 ,K18 ,K22 ,K23 ,
329C 3 K24 ,K25 ,K26 ,K27 ,K28 ,
330C 4 K33 ,K34 ,K35 ,K36 ,K37 ,
331C 5 K38 ,K44 ,K45 ,K46 ,K47 ,
332C 6 K48 ,K55 ,K56 ,K57 ,K58 ,
333C 7 K66 ,K67 ,K68 ,K77 ,K78 ,
334C 8 K88 ,NEL ,LIAD ,ICP ,ICSIG ,
335C 9 OFFSET,ELBUF(IAD2),OFF)
336 iety=8
337 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
338 WRITE(iout,1001)' HEPH SOLID'
339 WRITE(istdo,1001)' HEPH SOLID'
340 iprmes_el(iety)=1
341 ENDIF
342 ELSE
343 iety=9
344 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
345 WRITE(iout,1001)' S8 SOLID'
346 WRITE(istdo,1001)' S8 SOLID'
347 iprmes_el(iety)=1
348 ENDIF
349 ENDIF
350 ELSEIF(npt==8.AND.mtn/=0 .AND. isolnod/=20)THEN
351C CALL S8KE3(
352 iety=10
353 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
354 WRITE(iout,1001)' S8 SOLID'
355 WRITE(istdo,1001)' S8 SOLID'
356 iprmes_el(iety)=1
357 ENDIF
358 ENDIF
359C----6---------------------------------------------------------------7---------8
360 ELSEIF(ity==2.AND.jmult==0.AND.jlag==1)THEN
361 iety=11
362 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
363 WRITE(iout,1001)' QUAD 2D '
364 WRITE(istdo,1001)' QUAD 2D '
365 iprmes_el(iety)=1
366 ENDIF
367C CALL QFORC2(
368 ELSEIF(ity==3)THEN
369 iofc = 0
370 IF(ng/=ngroup)THEN
371 iad2 = iparg(4,ng+1) - 6 * nel
372 ELSE
373 iad2 = lbufel - 6 * nel + 1
374 ENDIF
375 IF (jhbe<11) THEN
376 IF (ncycle==1.AND.imconv==1) THEN
377 IF(jhbe==4)THEN
378 iety=12
379 IF (iprmes_el(iety)==0) THEN
380 WRITE(iout,1003)jhbe
381 iprmes_el(iety)=1
382 ENDIF
383 ELSEIF(jhbe==3)THEN
384 iety=13
385 IF (iprmes_el(iety)==0) THEN
386 WRITE(iout,1003)jhbe
387 iprmes_el(iety)=1
388 ENDIF
389 ELSEIF(jhbe==1)THEN
390 iety=14
391 IF (iprmes_el(iety)==0) THEN
392 WRITE(iout,1003)jhbe
393 iprmes_el(iety)=1
394 ENDIF
395 ELSE
396 iety=15
397 IF (iprmes_el(iety)==0) THEN
398 WRITE(iout,1003)jhbe
399 iprmes_el(iety)=1
400 ENDIF
401 ENDIF
402 ENDIF
403 ENDIF
404 IF(jhbe>=11.AND.jhbe<=19) THEN
405
406 numel_drape = numelc_drape
407 sedrape = scdrape
408 CALL cbake3 (
409 1 jft ,jlt ,nft ,iabs(npt) ,mlw ,
410 2 ithk ,ncycle ,
411 3 istra ,ipla ,pm ,geo ,ixc(1,nf1) ,
412 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
413 1 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
414 7 jhbe ,thke(nf1) ,ismstr ,x ,ikgeo ,
415 8 ipm ,igeo ,iexpan ,iparg(1,ng),isubstack,
416 9 stack ,drape_sh4n ,drapeg%INDX_SH4N, sedrape,numel_drape)
417 ELSE
418C
419
420 numel_drape = numelc_drape
421 sedrape = scdrape
422 CALL czke3 (
423 1 jft ,jlt ,nft ,iabs(npt) ,mlw ,
424 2 ithk ,ncycle ,
425 3 istra ,ipla ,pm ,geo ,ixc(1,nf1) ,
426 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
427 1 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
428 7 jhbe ,thke(nf1) ,ismstr ,x ,ikgeo ,
429 8 ipm ,igeo ,iexpan ,iparg(1,ng),isubstack,
430 9 stack ,drape_sh4n ,drapeg%INDX_SH4N, sedrape,numel_drape)
431CTMP ELSE
432CTMP WRITE(IOUT,1001)' Q4 SHELL'
433CTMP WRITE(ISTDO,1001)' Q4 SHELL'
434C CALL CKE3(
435 ENDIF
436c OPEN(UNIT=13,FILE='KE.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
437c CALL IMPKCOUT( IXC,NFT,NEL,13,
438c 1 KC11 ,KC12 ,KC13 ,KC14 ,KC22 ,
439c 2 KC23 ,KC24 ,KC33 ,KC34 ,KC44 )
440c CALL KELAMDA( IXC,NIXC,NFT,NEL,13,
441c 1 KC11 ,KC12 ,KC13 ,KC14 ,KC22 ,
442c 2 KC23 ,KC24 ,KC33 ,KC34 ,KC44 )
443
444C----6---------------------------------------------------------------7---------8
445 ELSEIF(ity==4)THEN
446
447 CALL tke3( jft ,jlt ,pm ,geo ,ixt(1,nf1) ,
448 2 x ,elbuf_tab(ng) ,nel ,offset ,ikgeo ,
449 3 etag , iddl ,ndof ,k_diag ,k_lt ,
450 4 iadk ,jdik )
451
452C
453C WRITE(IOUT,1001)' TRUSS '
454C WRITE(ISTDO,1001)' TRUSS '
455C----6---------------------------------------------------------------7---------8
456 ELSEIF(ity==5)THEN
457
458 CALL pke3( jft ,jlt ,nel , mtn , ismstr,
459 1 pm ,ixp(1,nf1) ,x , elbuf_tab(ng) , geo ,
460 2 offset ,ikgeo ,etag , iddl , ndof ,
461 3 k_diag ,k_lt ,iadk , jdik )
462
463
464c OPEN(UNIT=16,FILE='KE_P.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
465c CALL IMPKPOUT(NIXPL,IXP,NFT,NEL,16,KC11 ,KC12 , KC22 )
466C----6---------------------------------------------------------------7---------8
467 ELSEIF(ity==6)THEN
468 igtyp = nint(geo(12,ixr(1,nf1)))
469 k1=1 + 6*(numelc+numeltg)*iepsdot + 15*(numelt+numelp+nft)
470
471 IF (igtyp==4)THEN
472 CALL r4ke3(jft ,jlt ,nel ,mtn ,pm ,
473 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
474 2 tf ,skew ,offset,fr_wave,
475 3 ikgeo ,igeo,
476 1 etag , iddl ,ndof ,k_diag ,k_lt ,
477 2 iadk ,jdik )
478
479
480 ELSEIF (igtyp==8)THEN
481 CALL r8ke3(jft ,jlt ,nel ,mtn ,pm ,
482 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
483 2 tf ,skew ,offset,fr_wave,igeo ,
484 1 etag , iddl ,ndof ,k_diag ,k_lt ,
485 2 iadk ,jdik )
486
487 ELSEIF (igtyp==12)THEN
488 CALL r12ke3(jft ,jlt ,nel ,mtn ,pm ,
489 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
490 2 tf ,skew ,offset,fr_wave,igeo ,
491 1 etag , iddl ,ndof ,k_diag ,k_lt ,
492 2 iadk ,jdik )
493
494 ELSEIF (igtyp==13)THEN
495 CALL r13ke3(jft ,jlt ,nel ,mtn ,pm ,
496 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
497 2 tf ,skew ,offset,fr_wave,ikgeo ,igeo ,
498 1 etag , iddl ,ndof ,k_diag ,k_lt ,
499 2 iadk ,jdik )
500
501
502C OPEN(UNIT=16,FILE='KE_SP.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
503C CALL IMPKPOUT( NIXR,IXR,NFT,NEL,16,KC11 ,KC12 , KC22 )
504 ELSE
505 iety=16
506 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
507 WRITE(iout,1001)' THIS SPRING'
508 WRITE(istdo,1001)' THIS SPRING'
509 iprmes_el(iety)=1
510 ENDIF
511 ENDIF
512C----6---------------------------------------------------------------7---------8
513 ELSEIF(ity==7)THEN
514 iofc = 0
515 IF(ng/=ngroup)THEN
516 iad2 = iparg(4,ng+1) - 6 * nel
517 ELSE
518 iad2 = lbufel - 6 * nel + 1
519 ENDIF
520 nf1 = nft + 1
521 IF(icnod==6)THEN
522
523 iety=17
524 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
525 WRITE(iout,1001)' S3N6 SHELL'
526 WRITE(istdo,1001)' S3N6 SHELL'
527 iprmes_el(iety)=1
528 ENDIF
529
530 ELSE
531 IF (ish3n == 30) THEN
532 IF (ncycle==1.AND.imconv==1) THEN
533 iety=18
534 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
535 WRITE(iout,1004)ish3n
536 iprmes_el(iety)=1
537 ENDIF
538 ENDIF
539 ENDIF
540 numel_drape = numeltg_drape
541 sedrape = stdrape
542 CALL c3ke3 (
543 1 jft ,jlt ,nft ,iabs(npt),mtn ,
544 2 ithk ,ncycle ,
545 3 istra ,ipla ,pm ,geo ,ixtg(1,nf1),
546 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
547 5 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
548 6 jhbe ,thke(numelc+nf1),ismstr ,x ,
549 7 ikgeo ,ipm ,igeo ,iexpan ,iparg(1,ng),
550 8 isubstack, stack, drape_sh3n ,drapeg%INDX_SH3N,
551 9 sedrape,numel_drape)
552
553 ENDIF
554C----6---------------------------------------------------------------7---------8
555
556 ENDIF
557 250 CONTINUE
558 END DO
559C----6---------------------------------------------------------------7---------8
560 1001 FORMAT(' *****WARNING : IMPLICITE FORMULATION IS NOT AVAILABLE
561 . WITH '/,2x,a11,' ELEMENT : STIFFNESS IGNORED')
562 1002 FORMAT(' *****WARNING : ELEMENT FORMULATION ISOLID= ',
563 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'
564 . ,'USING GENERIC ONE INSTEAD, POSSIBLE CONVERGING ISSUE.')
565 1003 FORMAT(' *****WARNING : ELEMENT FORMULATION ISHELL= ',
566 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'
567 . ,'USING GENERIC ONE INSTEAD, POSSIBLE CONVERGING ISSUE.')
568 1004 FORMAT(' *****WARNING : ELEMENT FORMULATION ISH3N = ',
569 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'
570 . ,'USING GENERIC ONE INSTEAD, POSSIBLE CONVERGING ISSUE.')
571 1005 FORMAT(' *****WARNING : TETRA ELEMENT FORMULATION W/ ITETRA= ',
572 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'
573 . ,'USING ITETRA=0 INSTEAD, POSSIBLE CONVERGING ISSUE.')
574 RETURN
575 END
576!||====================================================================
577!|| get_kii ../engine/source/implicit/imp_glob_k.F
578!||--- called by ------------------------------------------------------
579!|| bc_updk ../engine/source/constraints/general/bcs/bc_imp0.F
580!|| bc_updk2 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
581!|| i2updk0 ../engine/source/interfaces/interf/i2_imp1.F
582!|| i2updk1 ../engine/source/interfaces/interf/i2_imp1.F
583!|| imp_frks ../engine/source/mpi/implicit/imp_fri.F
584!|| imp_fvkss ../engine/source/mpi/implicit/imp_fri.F
585!|| rbe2_imp1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
586!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
587!|| rbe3_imp1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
588!|| rby_imp1 ../engine/source/constraints/general/rbody/rby_imp0.F
589!|| rm_imp1 ../engine/source/model/remesh/rm_imp0.F
590!|| upd_aspc0 ../engine/source/constraints/general/bcs/bc_imp0.F
591!||====================================================================
592 SUBROUTINE get_kii(NI ,IDDL ,IADK,K_DIAG,K_LT ,KII,ND)
593C-----------------------------------------------
594C I m p l i c i t T y p e s
595C-----------------------------------------------
596#include "implicit_f.inc"
597C-----------------------------------------------
598C C o m m o n B l o c k s
599C-----------------------------------------------
600#include "impl1_c.inc"
601C-----------------------------------------------
602C D u m m y A r g u m e n t s
603C-----------------------------------------------
604 INTEGER ND
605 INTEGER NI,IDDL(*) ,IADK(*)
606C REAL
607 my_real
608 . K_DIAG(*) ,K_LT(*) ,KII(6,6)
609C-----------------------------------------------
610C L o c a l V a r i a b l e s
611C-----------------------------------------------
612 INTEGER K,IK,ID,JD,L
613C----6----------KII is always triag_sup whatever IKPAT------------------------
614 id = iddl(ni)
615 IF (ikpat==0) THEN
616 DO k=1,nd
617 kii(k,k) = k_diag(id+k)
618 jd = iadk(id+k)-1
619 DO l=k+1,nd
620 ik = jd+l-k
621 kii(k,l) = k_lt(ik)
622 ENDDO
623 ENDDO
624 ELSE
625 DO k=1,nd
626 kii(k,k) = k_diag(id+k)
627 jd = iadk(id+k+1)-k
628 DO l=1,k-1
629 ik = jd+l
630 kii(l,k) = k_lt(ik)
631 ENDDO
632 ENDDO
633 ENDIF
634C
635 RETURN
636 END
637!||====================================================================
638!|| put_kii ../engine/source/implicit/imp_glob_k.F
639!||--- called by ------------------------------------------------------
640!|| bc_updk ../engine/source/constraints/general/bcs/bc_imp0.F
641!|| bc_updk2 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
642!|| i2updk0 ../engine/source/interfaces/interf/i2_imp1.F
643!|| i2updk1 ../engine/source/interfaces/interf/i2_imp1.F
644!|| i2updkm0 ../engine/source/interfaces/interf/i2_imp1.F
645!|| i2updkm1 ../engine/source/interfaces/interf/i2_imp1.F
646!|| imp_fvkss ../engine/source/mpi/implicit/imp_fri.F
647!|| ind_sld ../engine/source/mpi/implicit/imp_fri.F
648!|| rbe2_imp1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
649!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
650!|| rbe3_imp1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
651!|| rby_imp1 ../engine/source/constraints/general/rbody/rby_imp0.F
652!|| rm_imp1 ../engine/source/model/remesh/rm_imp0.F
653!||====================================================================
654 SUBROUTINE put_kii(NI ,IDDL ,IADK,K_DIAG,K_LT ,KII,ND)
655C-----------------------------------------------
656C I m p l i c i t T y p e s
657C-----------------------------------------------
658#include "implicit_f.inc"
659C-----------------------------------------------
660C C o m m o n B l o c k s
661C-----------------------------------------------
662#include "impl1_c.inc"
663C-----------------------------------------------
664C D u m m y A r g u m e n t s
665C-----------------------------------------------
666 INTEGER ND
667 INTEGER NI,IDDL(*) ,IADK(*)
668C REAL
669 my_real
670 . K_DIAG(*) ,K_LT(*) ,KII(6,6)
671C-----------------------------------------------
672C L o c a l V a r i a b l e s
673C-----------------------------------------------
674 INTEGER K,IK,ID,JD,L
675C----6----------KII is always triag_sup whatever IKPAT------------------------
676 id = iddl(ni)
677 IF (ikpat==0) THEN
678 DO k=1,nd
679 k_diag(id+k) = k_diag(id+k) + kii(k,k)
680 jd = iadk(id+k)-1
681 DO l=k+1,nd
682 ik = jd+l-k
683 k_lt(ik) = k_lt(ik) + kii(k,l)
684 ENDDO
685 ENDDO
686 ELSE
687 DO k=1,nd
688 k_diag(id+k) = k_diag(id+k) + kii(k,k)
689 jd = iadk(id+k+1)-k
690 DO l=1,k-1
691 ik = jd+l
692 k_lt(ik) = k_lt(ik) + kii(l,k)
693 ENDDO
694 ENDDO
695 ENDIF
696C
697 RETURN
698 END
699!||====================================================================
700!|| get_kij ../engine/source/implicit/imp_glob_k.F
701!||--- called by ------------------------------------------------------
702!|| i2_impm ../engine/source/interfaces/interf/i2_imp1.F
703!|| i2updk0 ../engine/source/interfaces/interf/i2_imp1.F
704!|| i2updk1 ../engine/source/interfaces/interf/i2_imp1.F
705!|| imp_frks ../engine/source/mpi/implicit/imp_fri.F
706!|| rbe2_imp1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
707!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
708!|| rbe3_imp1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
709!|| rby_imp1 ../engine/source/constraints/general/rbody/rby_imp0.F
710!|| rby_impm ../engine/source/constraints/general/rbody/rby_imp0.F
711!|| rm_imp1 ../engine/source/model/remesh/rm_imp0.F
712!||====================================================================
713 SUBROUTINE get_kij( NI ,NJ ,IDDL ,IADK,JDIK,K_LT ,KIJ ,NK,NL ,
714 . IERR)
715C----6---------------------------------------------------------------7---------8
716C I m p l i c i t T y p e s
717C-----------------------------------------------
718#include "implicit_f.inc"
719C-----------------------------------------------
720C C o m m o n B l o c k s
721C-----------------------------------------------
722#include "impl1_c.inc"
723C-----------------------------------------------
724C D u m m y A r g u m e n t s
725C-----------------------------------------------
726 INTEGER NK,NL , IERR
727 INTEGER NI,NJ,IDDL(*) ,IADK(*),JDIK(*)
728C REAL
729 my_real
730 . K_LT(*) ,KIJ(6,6)
731C-----------------------------------------------
732C L o c a l V a r i a b l e s
733C-----------------------------------------------
734 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ
735C----6---------------------------------------------------------------7---------8
736 ierr = 0
737 i = iddl(ni)
738 j = iddl(nj)
739 IF (ikpat==0) THEN
740 id = min(i,j)
741 jd = max(i,j)+1
742 ELSE
743 id = max(i,j)
744 jd = min(i,j)+1
745 ENDIF
746 jdl=0
747 IF (i==id) THEN
748 DO k=1,nk
749 DO jj = iadk(id+k),iadk(id+1+k)-1
750C-------- Find l'Address in LT -----
751 IF (jdik(jj)==jd) THEN
752 jdl = jj-1
753 GOTO 100
754 ENDIF
755 ENDDO
756 IF (jdl==0) THEN
757 ierr = 1
758 DO i=1,nk
759 DO j=1,nl
760 kij(i,j)=zero
761 ENDDO
762 ENDDO
763 RETURN
764 ENDIF
765 100 DO l=1,nl
766 kij(k,l)=k_lt(jdl+l)
767 ENDDO
768 ENDDO
769 ELSE
770 DO k=1,nl
771 DO jj = iadk(id+k),iadk(id+1+k)-1
772 IF (jdik(jj)==jd) THEN
773 jdl = jj-1
774 GOTO 200
775 ENDIF
776 ENDDO
777 IF (jdl==0) THEN
778 ierr = 1
779 DO i=1,nk
780 DO j=1,nl
781 kij(i,j)=zero
782 ENDDO
783 ENDDO
784 RETURN
785 ENDIF
786 200 DO l=1,nk
787 kij(l,k)=k_lt(jdl+l)
788 ENDDO
789 ENDDO
790 ENDIF
791C
792C----6---------------------------------------------------------------7---------8
793 RETURN
794 END
795!||====================================================================
796!|| put_kij ../engine/source/implicit/imp_glob_k.F
797!||--- called by ------------------------------------------------------
798!|| i2updk0 ../engine/source/interfaces/interf/i2_imp1.F
799!|| i2updk1 ../engine/source/interfaces/interf/i2_imp1.F
800!|| i2updkm0 ../engine/source/interfaces/interf/i2_imp1.F
801!|| i2updkm1 ../engine/source/interfaces/interf/i2_imp1.F
802!|| imp_kpres ../engine/source/implicit/imp_glob_k.F
803!|| rbe2_imp1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
804!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
805!|| rbe3_imp1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
806!|| rby_imp1 ../engine/source/constraints/general/rbody/rby_imp0.F
807!|| rby_impm ../engine/source/constraints/general/rbody/rby_imp0.F
808!|| rm_imp1 ../engine/source/model/remesh/rm_imp0.F
809!||====================================================================
810 SUBROUTINE put_kij( NI ,NJ ,IDDL ,IADK,JDIK,K_LT,KIJ,NK,NL ,
811 . IERR)
812C-----------------------------------------------
813C I m p l i c i t T y p e s
814C-----------------------------------------------
815#include "implicit_f.inc"
816C-----------------------------------------------
817C C o m m o n B l o c k s
818C-----------------------------------------------
819#include "impl1_c.inc"
820C-----------------------------------------------
821C D u m m y A r g u m e n t s
822C-----------------------------------------------
823 INTEGER NK,NL ,IERR
824 INTEGER NI,NJ,IDDL(*) ,IADK(*),JDIK(*)
825C REAL
826 my_real
827 . K_LT(*) ,KIJ(6,6)
828C-----------------------------------------------
829C L o c a l V a r i a b l e s
830C-----------------------------------------------
831 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ
832C----6---------------------------------------------------------------7---------8
833 IERR = 0
834 i = iddl(ni)
835 j = iddl(nj)
836 IF (ikpat==0) THEN
837 id = min(i,j)
838 jd = max(i,j)+1
839 ELSE
840 id = max(i,j)
841 jd = min(i,j)+1
842 ENDIF
843 IF (i==id) THEN
844 DO k=1,nk
845 DO jj = iadk(id+k),iadk(id+1+k)-1
846C-------- Find l'Address in LT -----
847 IF (jdik(jj)==jd) THEN
848 jdl = jj-1
849 GOTO 100
850 ENDIF
851 ENDDO
852 ierr = 1
853 RETURN
854 100 DO l=1,nl
855 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l)
856 ENDDO
857 ENDDO
858 ELSE
859 DO k=1,nl
860 DO jj = iadk(id+k),iadk(id+1+k)-1
861 IF (jdik(jj)==jd) THEN
862 jdl = jj-1
863 GOTO 200
864 ENDIF
865 ENDDO
866 ierr = 1
867 RETURN
868 200 DO l=1,nk
869 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k)
870 ENDDO
871 ENDDO
872 ENDIF
873C----6---------------------------------------------------------------7---------8
874 RETURN
875 END
876!||====================================================================
877!|| print_wkij ../engine/source/implicit/imp_glob_k.F
878!||--- called by ------------------------------------------------------
879!|| i2_frk0 ../engine/source/interfaces/interf/i2_imp1.F
880!|| i2_frk1 ../engine/source/interfaces/interf/i2_imp1.F
881!|| i2updk0 ../engine/source/interfaces/interf/i2_imp1.F
882!|| i2updk1 ../engine/source/interfaces/interf/i2_imp1.F
883!|| rbe2_imp1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
884!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
885!|| rbe3_fr1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
886!|| rbe3_imp1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
887!|| rby_imp1 ../engine/source/constraints/general/rbody/rby_imp0.F
888!|| rby_impm ../engine/source/constraints/general/rbody/rby_imp0.F
889!|| rm_imp1 ../engine/source/model/remesh/rm_imp0.F
890!||====================================================================
891 SUBROUTINE print_wkij( NI ,NJ ,IFLAG)
892C-----------------------------------------------
893C I m p l i c i t T y p e s
894C-----------------------------------------------
895#include "implicit_f.inc"
896C-----------------------------------------------
897C C o m m o n B l o c k s
898C-----------------------------------------------
899#include "units_c.inc"
900C-----------------------------------------------
901C D u m m y A r g u m e n t s
902C-----------------------------------------------
903 INTEGER NI ,NJ ,IFLAG
904C REAL
905C-----------------------------------------------
906C L o c a l V a r i a b l e s
907C-----------------------------------------------
908 INTEGER I
909C-----------------------------------------------
910 IF (IFLAG==1) then
911 WRITE(iout,1001)ni,nj
912 WRITE(istdo,1001)ni,nj
913 ELSEIF (iflag==2) THEN
914 WRITE(iout,1002)ni,nj
915 WRITE(istdo,1002)ni,nj
916 ELSEIF (iflag==3) THEN
917 WRITE(iout,1003)ni,nj
918 WRITE(istdo,1003)ni,nj
919 ELSEIF (iflag==4) THEN
920 WRITE(iout,1004)ni,nj
921 WRITE(istdo,1004)ni,nj
922 ELSEIF (iflag==5) THEN
923 WRITE(iout,1005)ni,nj
924 WRITE(istdo,1005)ni,nj
925 ELSE
926 WRITE(iout,1000)ni,nj
927 WRITE(istdo,1000)ni,nj
928 ENDIF
929C----6---------------------------------------------------------------7---------8
930 1000 FORMAT(' *** WARNING : IN OPTION ? :'/,
931 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
932 1001 FORMAT(' *** WARNING : IN RIGID BODY CONDENSATION:'/,
933 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
934 1002 FORMAT(' *** WARNING : IN INTERFACE TYPE 2 CONDENSATION:'/,
935 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
936 1003 FORMAT(' *** WARNING : IN REMESH KINEMATIC CONDENSATION:'/,
937 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
938 1004 FORMAT(' *** WARNING : IN RBE3 CONDENSATION:'/,
939 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
940 1005 FORMAT(' *** WARNING : IN RBE2 CONDENSATION:'/,
941 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
942 RETURN
943 END
944!||====================================================================
945!|| assem_kii ../engine/source/implicit/imp_glob_k.F
946!||--- called by ------------------------------------------------------
947!|| ass_spmd ../engine/source/implicit/assem_int.F
948!|| ass_spmd11 ../engine/source/implicit/assem_int.F
949!|| assem_int ../engine/source/implicit/assem_int.F
950!|| assem_int11 ../engine/source/implicit/assem_int.F
951!|| assem_kij ../engine/source/implicit/imp_glob_k.F
952!|| assem_ksl ../engine/source/mpi/implicit/imp_fri.F
953!|| assem_p ../engine/source/implicit/assem_p.F
954!|| assem_q4 ../engine/source/implicit/assem_q4.F
955!|| assem_r3 ../engine/source/implicit/assem_r3.F
956!|| assem_s10 ../engine/source/implicit/assem_s10.F
957!|| assem_s20 ../engine/source/implicit/assem_s20.F
958!|| assem_s4 ../engine/source/implicit/assem_s4.F
959!|| assem_s6 ../engine/source/implicit/assem_s6.F
960!|| assem_s8 ../engine/source/implicit/assem_s8.F
961!||====================================================================
962 SUBROUTINE assem_kii(NI ,NEL ,IDDL ,IADK ,K_DIAG,
963 1 K_LT ,KII ,ND ,OFF )
964C-----------------------------------------------
965C I m p l i c i t T y p e s
966C-----------------------------------------------
967#include "implicit_f.inc"
968C-----------------------------------------------
969C C o m m o n B l o c k s
970C-----------------------------------------------
971#include "impl1_c.inc"
972#include "comlock.inc"
973C-----------------------------------------------
974C D u m m y A r g u m e n t s
975C-----------------------------------------------
976 INTEGER ND
977 INTEGER NI(*),NEL ,IDDL(*) , IADK(*)
978C REAL
979 my_real
980 . K_DIAG(*) ,K_LT(*) ,KII(ND,ND,*),OFF(*)
981C-----------------------------------------------
982C L o c a l V a r i a b l e s
983C-----------------------------------------------
984 INTEGER N,K,EP,IK,ID,JD,L
985C----6----------KII is always triag_sup whatever IKPAT---------------7--------
986C lock by element too penalizing for performance
987#include "lockon.inc"
988 DO ep = 1,nel
989 IF (off(ep)>zero.AND.ni(ep)>0) THEN
990 n = ni(ep)
991 id = iddl(n)
992 IF (ikpat==0) THEN
993 DO k=1,nd
994c#include "lockon.inc"
995 k_diag(id+k) = k_diag(id+k) + kii(k,k,ep)
996c#include "lockoff.inc"
997 jd = iadk(id+k)-1
998 DO l=k+1,nd
999 ik = jd+l-k
1000c#include "lockon.inc"
1001 k_lt(ik) = k_lt(ik) + kii(k,l,ep)
1002c#include "lockoff.inc"
1003 ENDDO
1004 ENDDO
1005 ELSE
1006 DO k=1,nd
1007c#include "lockon.inc"
1008 k_diag(id+k) = k_diag(id+k) + kii(k,k,ep)
1009c#include "lockoff.inc"
1010 jd = iadk(id+k+1)-k
1011 DO l=1,k-1
1012 ik = jd+l
1013c#include "lockon.inc"
1014 k_lt(ik) = k_lt(ik) + kii(l,k,ep)
1015c#include "lockoff.inc"
1016 ENDDO
1017 ENDDO
1018 ENDIF
1019 ENDIF
1020 ENDDO
1021#include "lockoff.inc"
1022C
1023 RETURN
1024 END
1025!||====================================================================
1026!|| assem_kij ../engine/source/implicit/imp_glob_k.F
1027!||--- called by ------------------------------------------------------
1028!|| assem_int ../engine/source/implicit/assem_int.F
1029!|| assem_int11 ../engine/source/implicit/assem_int.F
1030!|| assem_p ../engine/source/implicit/assem_p.F
1031!|| assem_q4 ../engine/source/implicit/assem_q4.F
1032!|| assem_r3 ../engine/source/implicit/assem_r3.F
1033!|| assem_s10 ../engine/source/implicit/assem_s10.F
1034!|| assem_s20 ../engine/source/implicit/assem_s20.F
1035!|| assem_s4 ../engine/source/implicit/assem_s4.F
1036!|| assem_s6 ../engine/source/implicit/assem_s6.F
1037!|| assem_s8 ../engine/source/implicit/assem_s8.F
1038!||--- calls -----------------------------------------------------
1039!|| assem_kii ../engine/source/implicit/imp_glob_k.F
1040!||====================================================================
1041 SUBROUTINE assem_kij( NI ,NJ ,NEL ,IDDL ,IADK,JDIK,
1042 1 K_DIAG,K_LT ,KIJ ,ND ,OFF )
1043C----6---------------------------------------------------------------7---------8
1044C I m p l i c i t T y p e s
1045C-----------------------------------------------
1046#include "implicit_f.inc"
1047C-----------------------------------------------
1048C G l o b a l P a r a m e t e r s
1049C-----------------------------------------------
1050#include "mvsiz_p.inc"
1051C-----------------------------------------------
1052C C o m m o n B l o c k s
1053C-----------------------------------------------
1054#include "comlock.inc"
1055#include "impl1_c.inc"
1056C-----------------------------------------------------------------
1057C D u m m y A r g u m e n t s
1058C-----------------------------------------------
1059 INTEGER ND
1060 INTEGER NI(*),NJ(*),NEL ,IDDL(*) ,IADK(*),JDIK(*)
1061C REAL
1062 my_real
1063 . K_DIAG(*),K_LT(*) ,KIJ(ND,ND,*),OFF(*)
1064C-----------------------------------------------
1065C L o c a l V a r i a b l e s
1066C-----------------------------------------------
1067 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ,NN(MVSIZ),NELD
1068 my_real
1069 . KIJD(ND,ND,MVSIZ),OFFD(MVSIZ)
1070C---- if there is des elms degeneres--------------
1071 NELD=0
1072 DO ep = 1,nel
1073 IF (ni(ep)==nj(ep).AND.off(ep)>zero.AND.ni(ep)>0) THEN
1074 neld=neld+1
1075 nn(neld)=ni(ep)
1076 offd(neld)=off(ep)
1077 DO i=1,nd
1078 DO j=i,nd
1079 kijd(i,j,neld)=kij(i,j,ep)+kij(j,i,ep)
1080 ENDDO
1081 ENDDO
1082 ENDIF
1083 ENDDO
1084 IF (neld>0)
1085 . CALL assem_kii(nn ,neld ,iddl ,iadk ,k_diag,
1086 . k_lt ,kijd ,nd ,offd )
1087C----6---------------------------------------------------------------7---------8
1088#include "lockon.inc"
1089 IF (ikpat==0) THEN
1090 DO ep = 1,nel
1091 IF (off(ep)>zero.AND.ni(ep)/=nj(ep).AND.
1092 . ni(ep)>0.AND.nj(ep)>0) THEN
1093 i = iddl(ni(ep))
1094 j = iddl(nj(ep))
1095 id = min(i,j)
1096 jd = max(i,j)+1
1097 IF (i==id) THEN
1098 DO k=1,nd
1099 DO jj = iadk(id+k),iadk(id+1+k)-1
1100C-------- Find l'Address in LT -----
1101 IF (jdik(jj)==jd) THEN
1102 jdl = jj-1
1103 GOTO 100
1104 ENDIF
1105 ENDDO
1106 100 DO l=1,nd
1107c#include "lockon.inc"
1108 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l,ep)
1109c#include "lockoff.inc"
1110 ENDDO
1111 ENDDO
1112 ELSE
1113 DO k=1,nd
1114 DO jj = iadk(id+k),iadk(id+1+k)-1
1115 IF (jdik(jj)==jd) THEN
1116 jdl = jj-1
1117 GOTO 200
1118 ENDIF
1119 ENDDO
1120 200 DO l=1,nd
1121c#include "lockon.inc"
1122 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k,ep)
1123c#include "lockoff.inc"
1124 ENDDO
1125 ENDDO
1126 ENDIF
1127 ENDIF
1128 ENDDO
1129 ELSE
1130 DO ep = 1,nel
1131 IF (off(ep)>zero.AND.ni(ep)/=nj(ep).AND.
1132 . ni(ep)>0.AND.nj(ep)>0) THEN
1133 i = iddl(ni(ep))
1134 j = iddl(nj(ep))
1135 id = max(i,j)
1136 jd = min(i,j)+1
1137 IF (i==id) THEN
1138 DO k=1,nd
1139 DO jj = iadk(id+k),iadk(id+1+k)-1
1140C-------- Find l'Address in LT -----
1141 IF (jdik(jj)==jd) THEN
1142 jdl = jj-1
1143 GOTO 300
1144 ENDIF
1145 ENDDO
1146 300 DO l=1,nd
1147c#include "lockon.inc"
1148 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l,ep)
1149c#include "lockoff.inc"
1150 ENDDO
1151 ENDDO
1152 ELSE
1153 DO k=1,nd
1154 DO jj = iadk(id+k),iadk(id+1+k)-1
1155 IF (jdik(jj)==jd) THEN
1156 jdl = jj-1
1157 GOTO 400
1158 ENDIF
1159 ENDDO
1160 400 DO l=1,nd
1161c#include "lockon.inc"
1162 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k,ep)
1163c#include "lockoff.inc"
1164 ENDDO
1165 ENDDO
1166 ENDIF
1167 ENDIF
1168 ENDDO
1169 ENDIF
1170#include "lockoff.inc"
1171C
1172C----6---------------------------------------------------------------7---------8
1173 RETURN
1174 END
1175!||====================================================================
1176!|| put_kmii ../engine/source/implicit/imp_glob_k.F
1177!||--- called by ------------------------------------------------------
1178!|| bc_updfr ../engine/source/constraints/general/bcs/bc_imp0.F
1179!|| bc_updfr2 ../engine/source/constraints/general/bcs/bc_imp0.F
1180!|| i2_frk0 ../engine/source/interfaces/interf/i2_imp1.F
1181!|| i2_frk1 ../engine/source/interfaces/interf/i2_imp1.F
1182!|| rbe2_frk ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1183!|| rbe3_fr1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1184!|| rby_frk ../engine/source/constraints/general/rbody/rby_imp0.F
1185!||====================================================================
1186 SUBROUTINE put_kmii(ID ,IADK ,K_DIAG,K_LT ,KII ,
1187 . ND )
1188C-----------------------------------------------
1189C I m p l i c i t T y p e s
1190C-----------------------------------------------
1191#include "implicit_f.inc"
1192C-----------------------------------------------
1193C C o m m o n B l o c k s
1194C-----------------------------------------------
1195#include "impl1_c.inc"
1196C-----------------------------------------------
1197C D u m m y A r g u m e n t s
1198C-----------------------------------------------
1199 INTEGER ND
1200 INTEGER ID,IADK(*)
1201C REAL
1202 my_real
1203 . K_DIAG(*) ,K_LT(*) ,KII(6,6)
1204C-----------------------------------------------
1205C L o c a l V a r i a b l e s
1206C-----------------------------------------------
1207 INTEGER K,IK,JD,L,IDM
1208C----6----------KII is always triag_sup whatever IKPAT------------------------
1209 IF (IKPAT==0) then
1210 DO k=1,nd
1211 k_diag(id+k) = k_diag(id+k) + kii(k,k)
1212 jd = iadk(id+k)-1
1213 DO l=k+1,nd
1214 ik = jd+l-k
1215 k_lt(ik) = k_lt(ik) + kii(k,l)
1216 ENDDO
1217 ENDDO
1218 ELSE
1219 DO k=1,nd
1220 k_diag(id+k) = k_diag(id+k) + kii(k,k)
1221 jd = iadk(id+k+1)-k
1222 DO l=1,k-1
1223 ik = jd+l
1224 k_lt(ik) = k_lt(ik) + kii(l,k)
1225 ENDDO
1226 ENDDO
1227 ENDIF
1228C
1229 RETURN
1230 END
1231!||====================================================================
1232!|| put_kmij ../engine/source/implicit/imp_glob_k.F
1233!||--- called by ------------------------------------------------------
1234!|| i2_frk0 ../engine/source/interfaces/interf/i2_imp1.F
1235!|| i2_frk1 ../engine/source/interfaces/interf/i2_imp1.F
1236!|| rbe3_fr1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1237!||====================================================================
1238 SUBROUTINE put_kmij(INI ,INJ ,IADK,JDIK,K_LT,
1239 . KIJ ,NK ,NL ,IERR)
1240C-----------------------------------------------
1241C I m p l i c i t T y p e s
1242C-----------------------------------------------
1243#include "implicit_f.inc"
1244C-----------------------------------------------
1245C C o m m o n B l o c k s
1246C-----------------------------------------------
1247#include "impl1_c.inc"
1248C-----------------------------------------------
1249C D u m m y A r g u m e n t s
1250C-----------------------------------------------
1251 INTEGER NK,NL ,IERR
1252 INTEGER INI,INJ,IADK(*),JDIK(*)
1253C REAL
1254 my_real
1255 . k_lt(*) ,kij(6,6)
1256C-----------------------------------------------
1257C L o c a l V a r i a b l e s
1258C-----------------------------------------------
1259 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ
1260C----6---------------------------------------------------------------7---------8
1261 IERR = 0
1262 i = ini
1263 j = inj
1264 IF (ikpat==0) THEN
1265 id = min(i,j)
1266 jd = max(i,j)+1
1267 ELSE
1268 id = max(i,j)
1269 jd = min(i,j)+1
1270 ENDIF
1271 IF (i==id) THEN
1272 DO k=1,nk
1273 DO jj = iadk(id+k),iadk(id+1+k)-1
1274C-------- Find l'Address in LT -----
1275 IF (jdik(jj)==jd) THEN
1276 jdl = jj-1
1277 GOTO 100
1278 ENDIF
1279 ENDDO
1280 ierr = 1
1281 RETURN
1282 100 DO l=1,nl
1283 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l)
1284 ENDDO
1285 ENDDO
1286 ELSE
1287 DO k=1,nl
1288 DO jj = iadk(id+k),iadk(id+1+k)-1
1289 IF (jdik(jj)==jd) THEN
1290 jdl = jj-1
1291 GOTO 200
1292 ENDIF
1293 ENDDO
1294 ierr = 1
1295 RETURN
1296 200 DO l=1,nk
1297 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k)
1298 ENDDO
1299 ENDDO
1300 ENDIF
1301C----6---------------------------------------------------------------7---------8
1302 RETURN
1303 END
1304!||====================================================================
1305!|| impksout ../engine/source/implicit/imp_glob_k.F
1306!||--- calls -----------------------------------------------------
1307!|| writeks ../engine/source/implicit/imp_glob_k.F
1308!||--- uses -----------------------------------------------------
1309!|| element_mod ../common_source/modules/elements/element_mod.F90
1310!||====================================================================
1311 SUBROUTINE impksout( IXS,NFT,NEL,IUGEO,
1312 1 K11 ,K12 ,K13 ,K14 ,K15 ,
1313 2 K16 ,K17 ,K18 ,K22 ,K23 ,
1314 3 K24 ,K25 ,K26 ,K27 ,K28 ,
1315 4 K33 ,K34 ,K35 ,K36 ,K37 ,
1316 5 K38 ,K44 ,K45 ,K46 ,K47 ,
1317 6 K48 ,K55 ,K56 ,K57 ,K58 ,
1318 7 K66 ,K67 ,K68 ,K77 ,K78 ,
1319 8 K88 )
1320 use element_mod , only : nixs
1321C
1322C-----------------------------------------------
1323C I m p l i c i t T y p e s
1324C-----------------------------------------------
1325#include "implicit_f.inc"
1326#include "mvsiz_p.inc"
1327C-----------------------------------------------
1328C D u m m y A r g u m e n t s
1329C-----------------------------------------------
1330 INTEGER IXS(NIXS,*),NFT,NEL,IUGEO
1331C REAL
1332 my_real
1333 . K11(3,3,*),K12(3,3,*),K13(3,3,*) ,K14(3,3,*) ,K15(3,3,*),
1334 . k16(3,3,*),k17(3,3,*),k18(3,3,*) ,k22(3,3,*) ,k23(3,3,*),
1335 . k24(3,3,*),k25(3,3,*),k26(3,3,*) ,k27(3,3,*) ,k28(3,3,*),
1336 . k33(3,3,*),k34(3,3,*),k35(3,3,*) ,k36(3,3,*) ,k37(3,3,*),
1337 . k38(3,3,*),k44(3,3,*),k45(3,3,*) ,k46(3,3,*) ,k47(3,3,*),
1338 . k48(3,3,*),k55(3,3,*),k56(3,3,*) ,k57(3,3,*) ,k58(3,3,*),
1339 . k66(3,3,*),k67(3,3,*),k68(3,3,*) ,k77(3,3,*) ,k78(3,3,*),
1340 . k88(3,3,*)
1341C-----------------------------------------------
1342C L o c a l V a r i a b l e s
1343C-----------------------------------------------
1344 INTEGER I,J,N,NT,IG(MVSIZ)
1345C=======================================================================
1346C SOLID
1347C=======================================================================
1348 DO N= 1,nel
1349 nt=n+nft
1350 ig(n)=ixs(nixs,nt)
1351 ENDDO
1352 CALL writeks(iugeo,nft,nel,ig,'K11',k11)
1353 CALL writeks(iugeo,nft,nel,ig,'K12',k12)
1354 CALL writeks(iugeo,nft,nel,ig,'K13',k13)
1355 CALL writeks(iugeo,nft,nel,ig,'K14',k14)
1356 CALL writeks(iugeo,nft,nel,ig,'K15',k15)
1357 CALL writeks(iugeo,nft,nel,ig,'K16',k16)
1358 CALL writeks(iugeo,nft,nel,ig,'K17',k17)
1359 CALL writeks(iugeo,nft,nel,ig,'K18',k18)
1360 CALL writeks(iugeo,nft,nel,ig,'K22',k22)
1361 CALL writeks(iugeo,nft,nel,ig,'K23',k23)
1362 CALL writeks(iugeo,nft,nel,ig,'K24',k24)
1363 CALL writeks(iugeo,nft,nel,ig,'K25',k25)
1364 CALL writeks(iugeo,nft,nel,ig,'K26',k26)
1365 CALL writeks(iugeo,nft,nel,ig,'K27',k27)
1366 CALL writeks(iugeo,nft,nel,ig,'K28',k28)
1367 CALL writeks(iugeo,nft,nel,ig,'K33',k33)
1368 CALL writeks(iugeo,nft,nel,ig,'K34',k34)
1369 CALL writeks(iugeo,nft,nel,ig,'K35',k35)
1370 CALL writeks(iugeo,nft,nel,ig,'K36',k36)
1371 CALL writeks(iugeo,nft,nel,ig,'K37',k37)
1372 CALL writeks(iugeo,nft,nel,ig,'K38',k38)
1373 CALL writeks(iugeo,nft,nel,ig,'K44',k44)
1374 CALL writeks(iugeo,nft,nel,ig,'K45',k45)
1375 CALL writeks(iugeo,nft,nel,ig,'K46',k46)
1376 CALL writeks(iugeo,nft,nel,ig,'K47',k47)
1377 CALL writeks(iugeo,nft,nel,ig,'K48',k48)
1378 CALL writeks(iugeo,nft,nel,ig,'K55',k55)
1379 CALL writeks(iugeo,nft,nel,ig,'K56',k56)
1380 CALL writeks(iugeo,nft,nel,ig,'K57',k57)
1381 CALL writeks(iugeo,nft,nel,ig,'K58',k58)
1382 CALL writeks(iugeo,nft,nel,ig,'K66',k66)
1383 CALL writeks(iugeo,nft,nel,ig,'K67',k67)
1384 CALL writeks(iugeo,nft,nel,ig,'K68',k68)
1385 CALL writeks(iugeo,nft,nel,ig,'K77',k77)
1386 CALL writeks(iugeo,nft,nel,ig,'K78',k78)
1387 CALL writeks(iugeo,nft,nel,ig,'K88',k88)
1388C
1389 RETURN
1390 END
1391C | --- new routine -----
1392!||====================================================================
1393!|| writeks ../engine/source/implicit/imp_glob_k.F
1394!||--- called by ------------------------------------------------------
1395!|| impksout ../engine/source/implicit/imp_glob_k.F
1396!||====================================================================
1397 SUBROUTINE writeks( IN,NFT,NEL,IG,CH,KIJ)
1398C-----------------------------------------------
1399C I m p l i c i t T y p e s
1400C-----------------------------------------------
1401#include "implicit_f.inc"
1402C-----------------------------------------------
1403C D u m m y A r g u m e n t s
1404C-----------------------------------------------
1405 INTEGER IG(*),NFT,NEL,IN
1406 CHARACTER CH*3
1407C REAL
1408 my_real
1409 . kij(3,3,*)
1410C-----------------------------------------------
1411C L o c a l V a r i a b l e s
1412C-----------------------------------------------
1413 INTEGER I,J,N,NT
1414 CHARACTER KEY*10,KEY1*23
1415C-----------------------------------------------
1416 KEY='/SOLID_'//ch
1417 key1='#3d Solid Elements '//ch
1418 WRITE(in,'(A)') key
1419 WRITE(in,'(A)')key1
1420 WRITE(in,'(A)')
1421 . '#FORMAT: (2I8,1P4E16.9,6(/,1P5E16.9)) '
1422 WRITE(in,'(2A)')'# SYSSOL USRSOL K(I,J) I=1,3;J=1,3'
1423 DO n= 1,nel
1424 nt=n+nft
1425 WRITE(in,'(2I8,1P4E16.9,6(/,1P5E16.9))'
1426 . )nt,ig(n),((kij(i,j,n),i=1,3),j=1,3)
1427 ENDDO
1428 RETURN
1429 END
1430C
1431C | --- new routine -----
1432!||====================================================================
1433!|| impkcout ../engine/source/implicit/imp_glob_k.F
1434!||--- calls -----------------------------------------------------
1435!|| writekc ../engine/source/implicit/imp_glob_k.F
1436!||--- uses -----------------------------------------------------
1437!|| element_mod ../common_source/modules/elements/element_mod.F90
1438!||====================================================================
1439 SUBROUTINE impkcout( IXC,NFT,NEL,IUGEO,
1440 1 KE11 ,KE12 ,KE13 ,KE14 ,KE22 ,
1441 2 KE23 ,KE24 ,KE33 ,KE34 ,KE44 )
1442 use element_mod , only : nixc
1443C
1444C-----------------------------------------------
1445C I m p l i c i t T y p e s
1446C-----------------------------------------------
1447#include "implicit_f.inc"
1448#include "mvsiz_p.inc"
1449C-----------------------------------------------
1450C D u m m y A r g u m e n t s
1451C-----------------------------------------------
1452 INTEGER IXC(NIXC,*),NFT,NEL,IUGEO
1453C REAL
1454 my_real
1455 . ke11(6,6,*),ke22(6,6,*),ke33(6,6,*),ke44(6,6,*),
1456 . ke12(6,6,*),ke13(6,6,*),ke14(6,6,*),ke23(6,6,*),
1457 . ke24(6,6,*),ke34(6,6,*)
1458C-----------------------------------------------
1459C L o c a l V a r i a b l e s
1460C-----------------------------------------------
1461 INTEGER I,J,N,NT,IG(MVSIZ)
1462C=======================================================================
1463C SHELL
1464C=======================================================================
1465 DO n= 1,nel
1466 nt=n+nft
1467 ig(n)=ixc(nixc,nt)
1468 ENDDO
1469 CALL writekc(iugeo,nft,nel,ig,'K11',ke11)
1470 CALL writekc(iugeo,nft,nel,ig,'K12',ke12)
1471 CALL writekc(iugeo,nft,nel,ig,'K13',ke13)
1472 CALL writekc(iugeo,nft,nel,ig,'K14',ke14)
1473 CALL writekc(iugeo,nft,nel,ig,'K22',ke22)
1474 CALL writekc(iugeo,nft,nel,ig,'K23',ke23)
1475 CALL writekc(iugeo,nft,nel,ig,'K24',ke24)
1476 CALL writekc(iugeo,nft,nel,ig,'K33',ke33)
1477 CALL writekc(iugeo,nft,nel,ig,'K34',ke34)
1478 CALL writekc(iugeo,nft,nel,ig,'K44',ke44)
1479C
1480 RETURN
1481 END
1482C | --- new routine -----
1483!||====================================================================
1484!|| writekc ../engine/source/implicit/imp_glob_k.F
1485!||--- called by ------------------------------------------------------
1486!|| impkcout ../engine/source/implicit/imp_glob_k.F
1487!||====================================================================
1488 SUBROUTINE writekc( IN,NFT,NEL,IG,CH,KIJ)
1489C-----------------------------------------------
1490C I m p l i c i t T y p e s
1491C-----------------------------------------------
1492#include "implicit_f.inc"
1493C-----------------------------------------------
1494C D u m m y A r g u m e n t s
1495C-----------------------------------------------
1496 INTEGER IG(*),NFT,NEL,IN
1497 CHARACTER CH*3
1498C REAL
1499 my_real
1500 . kij(6,6,*)
1501C-----------------------------------------------
1502C L o c a l V a r i a b l e s
1503C-----------------------------------------------
1504 INTEGER I,J,N,NT
1505 CHARACTER KEY*10,KEY1*23
1506C-----------------------------------------------
1507 key='/SHELL_'//ch
1508 key1='#3d Shell Elements '//ch
1509 WRITE(in,'(A)') key
1510 WRITE(in,'(A)')key1
1511 WRITE(in,'(A)')
1512 . '#FORMAT: (2I8,1P4E16.9,6(/,1P5E16.9),/,1P2E16.9) '
1513 WRITE(in,'(2A)')'#SYSSHEL USRSHEL K(I,J) I=1,6;J=1,6'
1514 DO n= 1,nel
1515 nt=n+nft
1516 WRITE(in,'(2I8,1P4E16.9,6(/,1P5E16.9),/,1P2E16.9)'
1517 . )nt,ig(n),((kij(i,j,n),i=1,6),j=1,6)
1518 ENDDO
1519 RETURN
1520 END
1521C
1522C | --- new routine -----
1523!||====================================================================
1524!|| impkpout ../engine/source/implicit/imp_glob_k.F
1525!||--- calls -----------------------------------------------------
1526!|| writekp ../engine/source/implicit/imp_glob_k.F
1527!||====================================================================
1528 SUBROUTINE impkpout( NIXPL,IXP,NFT,NEL,IUGEO,KE11,KE12,KE22 )
1529C
1530C-----------------------------------------------
1531C I m p l i c i t T y p e s
1532C-----------------------------------------------
1533#include "implicit_f.inc"
1534#include "mvsiz_p.inc"
1535C-----------------------------------------------
1536C D u m m y A r g u m e n t s
1537C-----------------------------------------------
1538 INTEGER NIXPL
1539 INTEGER IXP(NIXPL,*),NEL,IUGEO,NFT
1540C REAL
1541 my_real
1542 . ke11(6,6,*),ke22(6,6,*),ke12(6,6,*)
1543C-----------------------------------------------
1544C L o c a l V a r i a b l e s
1545C-----------------------------------------------
1546 INTEGER I,J,N,NT,IG(MVSIZ)
1547C=======================================================================
1548C SHELL
1549C=======================================================================
1550 DO N= 1,nel
1551 ig(n)=ixp(nixpl,n)
1552 ENDDO
1553 CALL writekp(iugeo,nft,nel,ig,'K11',ke11)
1554 CALL writekp(iugeo,nft,nel,ig,'K12',ke12)
1555 CALL writekp(iugeo,nft,nel,ig,'K22',ke22)
1556C
1557 RETURN
1558 END
1559C | --- new routine -----
1560!||====================================================================
1561!|| writekp ../engine/source/implicit/imp_glob_k.F
1562!||--- called by ------------------------------------------------------
1563!|| impkpout ../engine/source/implicit/imp_glob_k.F
1564!||====================================================================
1565 SUBROUTINE writekp( IN,NFT,NEL,IG,CH,KIJ)
1566C-----------------------------------------------
1567C I m p l i c i t T y p e s
1568C-----------------------------------------------
1569#include "implicit_f.inc"
1570C-----------------------------------------------
1571C D u m m y A r g u m e n t s
1572C-----------------------------------------------
1573 INTEGER IG(*),NFT,NEL,IN
1574 CHARACTER CH*3
1575C REAL
1576 my_real
1577 . kij(6,6,*)
1578C-----------------------------------------------
1579C L o c a l V a r i a b l e s
1580C-----------------------------------------------
1581 INTEGER I,J,N,NT
1582 CHARACTER KEY*10,KEY1*23
1583C-----------------------------------------------
1584 key='/BEAM_'//ch
1585 key1='#3d Beam Elements '//ch
1586 WRITE(in,'(A)') key
1587 WRITE(in,'(A)')key1
1588 WRITE(in,'(A)')
1589 . '#FORMAT: (2I8,1P4E16.9,6(/,1P5E16.9),/,1P2E16.9) '
1590 WRITE(in,'(2A)')'#SYSSHEL USRSHEL K(I,J) I=1,6;J=1,6'
1591 DO n= 1,nel
1592 nt=n+nft
1593 WRITE(in,'(2I8,1P4E16.9,6(/,1P5E16.9),/,1P2E16.9)'
1594 . )nt,ig(n),((kij(i,j,n),i=1,6),j=1,6)
1595 ENDDO
1596 RETURN
1597 END
1598C
1599C | --- new routine -----
1600!||====================================================================
1601!|| impkiout ../engine/source/implicit/imp_glob_k.F
1602!||--- calls -----------------------------------------------------
1603!|| writeki ../engine/source/implicit/imp_glob_k.F
1604!||====================================================================
1605 SUBROUTINE impkiout( NIXPL,IXP,NFT,NEL,IUGEO,KE11,KE12,KE22 )
1606C
1607C-----------------------------------------------
1608C I m p l i c i t T y p e s
1609C-----------------------------------------------
1610#include "implicit_f.inc"
1611#include "mvsiz_p.inc"
1612C-----------------------------------------------
1613C D u m m y A r g u m e n t s
1614C-----------------------------------------------
1615 INTEGER NIXPL
1616 INTEGER IXP(NIXPL,*),NEL,IUGEO,NFT
1617C REAL
1618 my_real
1619 . ke11(3,3,*),ke22(3,3,*),ke12(3,3,*)
1620C-----------------------------------------------
1621C L o c a l V a r i a b l e s
1622C-----------------------------------------------
1623 INTEGER I,J,N,NT,IG(MVSIZ)
1624C=======================================================================
1625C SHELL
1626C=======================================================================
1627 DO N= 1,nel
1628 ig(n)=ixp(nixpl,n)
1629 ENDDO
1630 CALL writeki(iugeo,nft,nel,ig,'K11',ke11)
1631 CALL writeki(iugeo,nft,nel,ig,'K12',ke12)
1632 CALL writeki(iugeo,nft,nel,ig,'K22',ke22)
1633C
1634 RETURN
1635 END
1636C | --- new routine -----
1637!||====================================================================
1638!|| writeki ../engine/source/implicit/imp_glob_k.f
1639!||--- called by ------------------------------------------------------
1640!|| impkiout ../engine/source/implicit/imp_glob_k.F
1641!||====================================================================
1642 SUBROUTINE writeki( IN,NFT,NEL,IG,CH,KIJ)
1643C-----------------------------------------------
1644C I m p l i c i t T y p e s
1645C-----------------------------------------------
1646#include "implicit_f.inc"
1647C-----------------------------------------------
1648C D u m m y A r g u m e n t s
1649C-----------------------------------------------
1650 INTEGER IG(*),NFT,NEL,IN
1651 CHARACTER CH*3
1652C REAL
1653 my_real
1654 . kij(6,6,*)
1655C-----------------------------------------------
1656C L o c a l V a r i a b l e s
1657C-----------------------------------------------
1658 INTEGER I,J,N,NT
1659 CHARACTER KEY*10,KEY1*23
1660C-----------------------------------------------
1661 key='/TRUSS_'//ch
1662 key1='#3d TRUSS Elements '//ch
1663 WRITE(in,'(A)') key
1664 WRITE(in,'(A)')key1
1665 WRITE(in,'(A)')
1666 . '#FORMAT: (2I8,1P4E16.9,6(/,1P5E16.9)) '
1667 WRITE(in,'(2A)')'#SYSSHEL USRSHEL K(I,J) I=1,3;J=1,3'
1668 DO n= 1,nel
1669 nt=n+nft
1670 WRITE(in,'(2I8,1P4E16.9,6(/,1P5E16.9))'
1671 . )nt,ig(n),((kij(i,j,n),i=1,3),j=1,3)
1672 ENDDO
1673 RETURN
1674 END
1675C
1676C | --- new routine -----
1677!||====================================================================
1678!|| kelamda ../engine/source/implicit/imp_glob_k.F
1679!||--- calls -----------------------------------------------------
1680!|| jacobien ../engine/source/implicit/imp_glob_k.F
1681!||====================================================================
1682 SUBROUTINE kelamda( IXC,NIXCL,NFT,NEL,IUGEO,
1683 1 KE11 ,KE12 ,KE13 ,KE14 ,KE22 ,
1684 2 KE23 ,KE24 ,KE33 ,KE34 ,KE44 )
1685C-----------------------------------------------
1686C I m p l i c i t T y p e s
1687C-----------------------------------------------
1688#include "implicit_f.inc"
1689#include "mvsiz_p.inc"
1690C-----------------------------------------------
1691C D u m m y A r g u m e n t s
1692C-----------------------------------------------
1693 INTEGER NIXCL
1694 INTEGER IXC(NIXCL,*),NFT,NEL,IUGEO
1695C REAL
1696 my_real
1697 . ke11(6,6,*),ke22(6,6,*),ke33(6,6,*),ke44(6,6,*),
1698 . ke12(6,6,*),ke13(6,6,*),ke14(6,6,*),ke23(6,6,*),
1699 . ke24(6,6,*),ke34(6,6,*)
1700C-----------------------------------------------
1701C L o c a l V a r i a b l e s
1702C-----------------------------------------------
1703 INTEGER I,J,N,NT,IG(MVSIZ),I2,I3,I4,J2,J3,J4
1704 my_real
1705 . KE(24,24,MVSIZ),EW(24,MVSIZ),TOL,LAMDA(MVSIZ),
1706 . A,B,C,LAMDAS(MVSIZ),EV(24,24),KTMP(2,2)
1707C
1708 TOL=em5
1709 DO n= 1,nel
1710 nt=n+nft
1711 ig(n)=ixc(nixcl,nt)
1712 ENDDO
1713 DO i=1,6
1714 i2=i+6
1715 i3=i2+6
1716 i4=i3+6
1717 DO j=i,6
1718 j2=j+6
1719 j3=j2+6
1720 j4=j3+6
1721 DO n= 1,nel
1722 ke(i,j,n)=ke11(i,j,n)
1723 ke(i2,j2,n)=ke22(i,j,n)
1724 ke(i3,j3,n)=ke33(i,j,n)
1725 ke(i4,j4,n)=ke44(i,j,n)
1726 ENDDO
1727 ENDDO
1728 ENDDO
1729 DO i=1,6
1730 i2=i+6
1731 i3=i2+6
1732 i4=i3+6
1733 DO j=1,6
1734 j2=j+6
1735 j3=j2+6
1736 j4=j3+6
1737 DO n= 1,nel
1738 ke(i,j2,n)=ke12(i,j,n)
1739 ke(i,j3,n)=ke13(i,j,n)
1740 ke(i,j4,n)=ke14(i,j,n)
1741 ke(i2,j3,n)=ke23(i,j,n)
1742 ke(i2,j4,n)=ke24(i,j,n)
1743 ke(i3,j4,n)=ke34(i,j,n)
1744 ENDDO
1745 ENDDO
1746 ENDDO
1747 DO n= 1,nel
1748 CALL jacobien(ke(1,1,n),24,ew(1,n),ev,tol,lamda(n))
1749 a=half*(ke11(1,1,n)+ke11(2,2,n))
1750 b=half*(ke11(1,1,n)-ke11(2,2,n))
1751 c=a+sqrt(b*b+ke11(1,2,n)*ke11(1,2,n))
1752 lamdas(n)=c
1753 a=half*(ke22(1,1,n)+ke22(2,2,n))
1754 b=half*(ke22(1,1,n)-ke22(2,2,n))
1755 c=a+sqrt(b*b+ke22(1,2,n)*ke22(1,2,n))
1756 IF(c>lamdas(n))lamdas(n)=c
1757 a=half*(ke33(1,1,n)+ke33(2,2,n))
1758 b=half*(ke33(1,1,n)-ke33(2,2,n))
1759 c=a+sqrt(b*b+ke33(1,2,n)*ke33(1,2,n))
1760 IF(c>lamdas(n))lamdas(n)=c
1761 a=half*(ke44(1,1,n)+ke44(2,2,n))
1762 b=half*(ke44(1,1,n)-ke44(2,2,n))
1763 c=a+sqrt(b*b+ke44(1,2,n)*ke44(1,2,n))
1764 IF(c>lamdas(n))lamdas(n)=c
1765 ENDDO
1766 WRITE(iugeo,'(A)') '#SHELL EIGENVALUES'
1767 WRITE(iugeo,'(A)')
1768 . '#FORMAT: (2I8,1P3E16.9,/,4(/,1P5E16.9),/,1P4E16.9) '
1769 WRITE(iugeo,'(2A)')
1770 . '#SYSSHEL USRSHEL LAMDA1,LAMDAS,FAC, LAMDA(I),I=24'
1771 DO n= 1,nel
1772 nt=n+nft
1773 WRITE(iugeo,'(2I8,1P3E16.9,/,4(/,1P5E16.9),/,1P4E16.9)'
1774 . )nt,ig(n),lamda(n),lamdas(n),lamda(n)/lamdas(n),
1775 . (ew(i,n),i=1,24)
1776 ENDDO
1777C
1778 RETURN
1779 END
1780!||====================================================================
1781!|| jacobien ../engine/source/implicit/imp_glob_k.F
1782!||--- called by ------------------------------------------------------
1783!|| kelamda ../engine/source/implicit/imp_glob_k.F
1784!|| minv_k ../engine/source/implicit/imp_solv.F
1785!|| pvp_k ../engine/source/implicit/imp_solv.F
1786!||====================================================================
1787 SUBROUTINE jacobien(A,N,EW,EV,TOL,LAMDA)
1788C-------------------------------------------------------KK141189-
1789C COMPUTATION OF ALL EIGENVALUES AND EIGENVECTORS OF A SYMMETRIC
1790C MATRIX A BY THE JACOBI ALGORITHM
1791C
1792C A(N,N) EIGENWERTPROBLEM
1793C N DIMENSION OF A
1794C EW(N) EIGENVALUES
1795C EV(N,N) EIGENVEKTORS
1796C NROT NUMBER OF ROTATIONS
1797C MAXA MAXIMUM ELEMENT OF A
1798C-----------------------------------------------
1799C I m p l i c i t T y p e s
1800C-----------------------------------------------
1801#include "implicit_f.inc"
1802 INTEGER N
1803 my_real
1804 . a(n,n), ew(n), ev(n,n)
1805 . , b(n), z(n),tol,lamda
1806 INTEGER IZ,IS,ITER,J,NROT
1807 my_real
1808 . SUMRS,EPS,G,H,T,C,S,TAU,THETA,R,LAMDA0
1809C----------------------------------------------------------------
1810 DO 130 IZ=1,n
1811 DO 120 is=1,n
1812 IF(iz<is) a(is,iz) = a(iz,is)
1813 ev(iz,is)=zero
1814 120 CONTINUE
1815 b(iz)=a(iz,iz)
1816 ew(iz)=b(iz)
1817 z(iz)=0.
1818 ev(iz,iz)=one
1819c EV(IZ,IZ)=ZERO
1820 130 CONTINUE
1821
1822 nrot=0
1823 r=ep30
1824 iter =0
1825
1826 sumrs = zero
1827
1828 lamda0=zero
1829
1830C SUM OF THE OFF DIAGONALS
1831 DO 150 iz=1,n-1
1832 DO 140 is=iz+1,n
1833 sumrs=sumrs+abs(a(iz,is))
1834 140 CONTINUE
1835 150 CONTINUE
1836
1837 IF (sumrs ==zero) GOTO 9000
1838 IF (iter > 4) THEN
1839 eps = zero
1840 ELSE
1841 eps = one_fifth*sumrs/n**2
1842 ENDIF
1843C START ITERATION
1844
1845 DO WHILE (r>tol)
1846c DO 240 ITER = 1,50
1847 iter =iter+ 1
1848
1849 DO 220 iz=1,n-1
1850 DO 210 is=iz+1,n
1851 g = 100. * abs(a(iz,is))
1852 IF (iter>4 .AND. abs(ew(iz))+g==abs(ew(iz))
1853 & .AND. abs(ew(is))+g==abs(ew(is))) THEN
1854 a(iz,is)=zero
1855 ELSE IF (abs(a(iz,is)) > eps) THEN
1856 h = ew(is)-ew(iz)
1857 IF (abs(h)+g==abs(h)) THEN
1858 t = a(iz,is)/h
1859 ELSE
1860 theta = half*h/a(iz,is)
1861 t=one/(abs(theta)+sqrt(one+theta**2))
1862 IF (theta < zero) t=-t
1863 ENDIF
1864 c=one/sqrt(one+t**2)
1865 s=t*c
1866 tau=s/(one+c)
1867 h=t*a(iz,is)
1868 z(iz)=z(iz)-h
1869 z(is)=z(is)+h
1870 ew(iz)=ew(iz)-h
1871 ew(is)=ew(is)+h
1872 a(iz,is)=zero
1873 DO 160 j=1,iz-1
1874 g=a(j,iz)
1875 h=a(j,is)
1876 a(j,iz)=g-s*(h+g*tau)
1877 a(j,is)=h+s*(g-h*tau)
1878 160 CONTINUE
1879 DO 170 j=iz+1,is-1
1880 g=a(iz,j)
1881 h=a(j,is)
1882 a(iz,j)=g-s*(h+g*tau)
1883 a(j,is)=h+s*(g-h*tau)
1884 170 CONTINUE
1885 DO 180 j=is+1,n
1886 g=a(iz,j)
1887 h=a(is,j)
1888 a(iz,j)=g-s*(h+g*tau)
1889 a(is,j)=h+s*(g-h*tau)
1890 180 CONTINUE
1891 DO 190 j=1,n
1892 g=ev(j,iz)
1893 h=ev(j,is)
1894 ev(j,iz)=g-s*(h+g*tau)
1895 ev(j,is)=h+s*(g-h*tau)
1896 190 CONTINUE
1897 nrot=nrot+1
1898 ENDIF
1899 210 CONTINUE
1900 220 CONTINUE
1901 DO 230 iz=1,n
1902 b(iz)=b(iz)+z(iz)
1903 IF (b(iz)>lamda)lamda=b(iz)
1904 ew(iz)=b(iz)
1905 z(iz)=zero
1906 230 CONTINUE
1907c R=ABS(LAMDA-LAMDA0)
1908 r=abs(lamda/max(em20,lamda0)-one)
1909 lamda0=lamda
1910c write(*,*)'iter,lamda,R=',iter,lamda,R
1911 lamda=zero
1912c 240 CONTINUE
1913 ENDDO
1914
1915 lamda=lamda0
1916c write(*,*)'n_iter,nrot=',iter,nrot,eps
1917 9000 CONTINUE
1918
1919 RETURN
1920
1921 END
1922!||====================================================================
1923!|| eleoff ../engine/source/implicit/imp_glob_k.f
1924!||--- called by ------------------------------------------------------
1925!|| r12ke3 ../engine/source/elements/spring/r12ke3.F
1926!||====================================================================
1927 SUBROUTINE eleoff(JFT , JLT , IX, NIX ,NN ,ETAG, OFF)
1928C-----------------------------------------------
1929C I m p l i c i t T y p e s
1930C-----------------------------------------------
1931#include "implicit_f.inc"
1932C-----------------------------------------------
1933C C o m m o n B l o c k s
1934C-----------------------------------------------
1935C-----------------------------------------------------------------
1936C D u m m y A r g u m e n t s
1937C-----------------------------------------------
1938 INTEGER NIX
1939 INTEGER JFT, JLT, IX(NIX,*), ETAG(*),NN
1940 my_real
1941 . off(*)
1942C-----------------------------------------------
1943C L o c a l V a r i a b l e s
1944C-----------------------------------------------
1945 INTEGER I, J ,N,N1,NALL,IUN
1946C
1947 iun = 1
1948 DO i=jft,jlt
1949 n1=ix(2,i)
1950 nall=etag(n1)
1951 DO j=3,nn+1
1952 n=ix(j,i)
1953 nall=nall*etag(n)
1954 ENDDO
1955 nall=min(nall,iun)
1956 off(i)=nall
1957 ENDDO
1958C
1959 RETURN
1960 END
1961!||====================================================================
1962!|| imp_kpres ../engine/source/implicit/imp_glob_k.F
1963!||--- called by ------------------------------------------------------
1964!|| imp_buck ../engine/source/implicit/imp_buck.F
1965!|| imp_solv ../engine/source/implicit/imp_solv.F
1966!||--- calls -----------------------------------------------------
1967!|| finter ../engine/source/tools/curve/finter.f
1968!|| kp4_ini ../engine/source/implicit/imp_glob_k.F
1969!|| kpquad ../engine/source/implicit/imp_glob_k.F
1970!|| kptria ../engine/source/implicit/imp_glob_k.F
1971!|| put_kij ../engine/source/implicit/imp_glob_k.F
1972!||--- uses -----------------------------------------------------
1973!|| sensor_mod ../common_source/modules/sensor_mod.F90
1974!||====================================================================
1975 SUBROUTINE imp_kpres(IB ,FAC ,NPC ,TF ,X ,
1976 2 SKEW ,NSENSOR,SENSOR_TAB,WEIGHT,IADC ,
1977 3 IDDL ,NDOF ,IADK ,JDIK ,K_DIAG,
1978 4 K_LT )
1979C-----------------------------------------------
1980C M o d u l e s
1981C-----------------------------------------------
1982 USE sensor_mod
1983C-----------------------------------------------
1984C I m p l i c i t T y p e s
1985C-----------------------------------------------
1986#include "implicit_f.inc"
1987#include "comlock.inc"
1988#include "param_c.inc"
1989C-----------------------------------------------
1990C C o m m o n B l o c k s
1991C-----------------------------------------------
1992#include "com01_c.inc"
1993#include "com04_c.inc"
1994#include "com08_c.inc"
1995C-----------------------------------------------
1996C E x t e r n a l F u n c t i o n s
1997C-----------------------------------------------
1998 INTEGER ,INTENT(IN) :: NSENSOR
1999C-----------------------------------------------,
2000C D u m m y A r g u m e n t s
2001C-----------------------------------------------
2002 INTEGER NPC(*),IB(NIBCLD,*)
2003 INTEGER WEIGHT(*), IADC(4,*)
2004 INTEGER IDDL(*) ,NDOF(*) ,IADK(*) ,JDIK(*)
2005C REAL
2006 my_real
2007 . fac(lfaccld,*), tf(*), x(3,*), skew(lskew,*),
2008 . k_diag(*) ,k_lt(*)
2009 TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) ,INTENT(IN) :: SENSOR_TAB
2010C-----------------------------------------------
2011C L o c a l V a r i a b l e s
2012C-----------------------------------------------
2013 INTEGER NL, N1, ISK, N2, N3, N4, N5, K1, K2, K3, ISENS,K,LL,
2014 . ICODE,IAD,N_OLD,IPRES4,IERR,ND,I,J
2015C REAL
2016 my_real
2017 . AXI, AA, A0, VV, FX, FY, FZ, AX, DYDX, TS,
2018 . SIXTH,X_OLD, F1, F2,XSENS,FCX,FCY,SCALN
2019 my_real
2020 . VKSI(4,4),VETA(4,4),VF4(4,4),
2021 . K11(6,6),K22(6,6),K33(6,6),K44(6,6),K12(6,6),
2022 . K13(6,6),K14(6,6),K23(6,6),K24(6,6),K34(6,6)
2023 my_real FINTER
2024 EXTERNAL FINTER
2025C=======================================================================
2026C-------IPRES4=0:no pressure,1:pressure with 3n; 2: with 4N
2027 IPRES4=0
2028 nd =3
2029 scaln=half
2030C IF (ILINE==0) SCALN=ONEP1
2031C IF (NBUCK>0) SCALN=-ONE
2032 DO nl=1,nconld
2033 n4=ib(4,nl)
2034 isens=0
2035 xsens = one
2036 DO k=1,nsensor
2037 IF(ib(6,nl)==sensor_tab(k)%SENS_ID) isens=k
2038 ENDDO
2039 IF(isens==0)THEN
2040 ts=tt
2041 ELSE
2042 ts = tt-sensor_tab(isens)%TSTART
2043 IF(ts < zero) cycle
2044 ENDIF
2045C
2046 IF(n4==-1)THEN
2047C----------------
2048C FORCE CONCENTREE
2049C----------------
2050 ELSE
2051C----------------
2052C PRESSION
2053C----------------
2054 IF (xsens==zero) cycle
2055C
2056 IF(n2d==0)THEN
2057C ANALYSE 3D
2058 IF(n4/=0)THEN
2059 ipres4=2
2060 GOTO 100
2061 ELSE
2062C true triangles.
2063 ipres4=1
2064 ENDIF
2065 ENDIF
2066 ENDIF
2067 END DO
2068C
2069 100 CONTINUE
2070 IF (ipres4==0) RETURN
2071 IF (ipres4>1) CALL kp4_ini(vksi,veta,vf4)
2072 n_old = 0
2073 x_old = zero
2074 DO 10 nl=1,nconld
2075 n1=ib(1,nl)
2076 n2=ib(2,nl)
2077 n3=ib(3,nl)
2078 n4=ib(4,nl)
2079 n5=ib(5,nl)
2080 fcy = fac(1,nl)
2081 fcx = fac(2,nl)
2082 isens=0
2083 xsens = one
2084 DO k=1,nsensor
2085 IF(ib(6,nl)==sensor_tab(k)%SENS_ID) isens=k
2086 ENDDO
2087 IF(isens==0)THEN
2088 ts=tt
2089 ELSE
2090 ts = tt-sensor_tab(isens)%TSTART
2091 IF(ts < zero) GOTO 10
2092 ENDIF
2093C
2094 IF(n4==-1)THEN
2095C----------------
2096C FORCE CONCENTREE
2097C----------------
2098 ELSE
2099C----------------
2100C PRESSION
2101C----------------
2102 IF(n_old/=n5.OR.x_old/=ts) THEN
2103 f1 = finter(n5,ts*fcx,npc,tf,dydx)
2104 n_old = n5
2105 x_old = ts
2106 ENDIF
2107 aa = -scaln*fcy*f1*xsens
2108 IF (aa==zero) cycle
2109C
2110 IF(n2d==0)THEN
2111C ANALYSE 3D
2112 IF(n4/=0)THEN
2113 CALL kpquad(n1,n2,n3,n4,aa,x,vksi,veta,vf4,
2114 . k11,k22,k33,k44,k12,k13,k14,k23,k24,k34)
2115C-----------add in ind_glob_k in case element has been deleted---
2116c CALL PUT_KII(N1 ,IDDL ,IADK,K_DIAG,K_LT ,K11,ND )
2117c CALL PUT_KII(N2 ,IDDL ,IADK,K_DIAG,K_LT ,K22,ND )
2118c CALL PUT_KII(N3 ,IDDL ,IADK,K_DIAG,K_LT ,K33,ND )
2119c CALL PUT_KII(N4 ,IDDL ,IADK,K_DIAG,K_LT ,K44,ND )
2120C
2121 CALL put_kij(n1 ,n2 ,iddl ,iadk,jdik,k_lt,k12,nd ,nd ,
2122 . ierr)
2123 CALL put_kij(n1 ,n3 ,iddl ,iadk,jdik,k_lt,k13,nd ,nd ,
2124 . ierr)
2125 CALL put_kij(n1 ,n4 ,iddl ,iadk,jdik,k_lt,k14,nd ,nd ,
2126 . ierr)
2127 CALL put_kij(n2 ,n3 ,iddl ,iadk,jdik,k_lt,k23,nd ,nd ,
2128 . ierr)
2129 CALL put_kij(n2 ,n4 ,iddl ,iadk,jdik,k_lt,k24,nd ,nd ,
2130 . ierr)
2131 CALL put_kij(n3 ,n4 ,iddl ,iadk,jdik,k_lt,k34,nd ,nd ,
2132 . ierr)
2133 ELSE
2134C triangles.
2135 CALL kptria(n1,n2,n3,aa,x,
2136 . k11,k22,k33,k12,k13,k23)
2137c CALL PUT_KII(N1 ,IDDL ,IADK,K_DIAG,K_LT ,K11,ND )
2138c CALL PUT_KII(N2 ,IDDL ,IADK,K_DIAG,K_LT ,K22,ND )
2139c CALL PUT_KII(N3 ,IDDL ,IADK,K_DIAG,K_LT ,K33,ND )
2140C
2141 CALL put_kij(n1 ,n2 ,iddl ,iadk,jdik,k_lt,k12,nd ,nd ,
2142 . ierr)
2143 CALL put_kij(n1 ,n3 ,iddl ,iadk,jdik,k_lt,k13,nd ,nd ,
2144 . ierr)
2145 CALL put_kij(n2 ,n3 ,iddl ,iadk,jdik,k_lt,k23,nd ,nd ,
2146 . ierr)
2147 ENDIF
2148 ELSE
2149C ANALYSE 2D
2150 ENDIF
2151 ENDIF
2152 10 CONTINUE
2153C
2154 RETURN
2155 END
2156!||====================================================================
2157!|| kpquad ../engine/source/implicit/imp_glob_k.F
2158!||--- called by ------------------------------------------------------
2159!|| imp_kpres ../engine/source/implicit/imp_glob_k.F
2160!||====================================================================
2161 SUBROUTINE kpquad(N1,N2,N3,N4,P,X,VKSI,VETA,VF4,
2162 . K11,K22,K33,K44,K12,K13,K14,K23,K24,K34)
2163C-----------------------------------------------
2164C I m p l i c i t T y p e s
2165C-----------------------------------------------
2166#include "implicit_f.inc"
2167C-----------------------------------------------
2168C C o m m o n B l o c k s
2169C-----------------------------------------------
2170C-----------------------------------------------------------------
2171C D u m m y A r g u m e n t s
2172C-----------------------------------------------
2173 INTEGER N1,N2,N3,N4
2174 my_real
2175 . p,x(3,*),vksi(4,4),veta(4,4),vf4(4,4),
2176 . k11(6,6),k22(6,6),k33(6,6),k44(6,6),k12(6,6),
2177 . k13(6,6),k14(6,6),k23(6,6),k24(6,6),k34(6,6)
2178C-----------------------------------------------
2179C L o c a l V a r i a b l e s
2180C-----------------------------------------------
2181 INTEGER I, J ,K,NP
2182 my_real
2183 . pg,j0,j1,j2,deta(4),x1,y1,s1,pg2,
2184 . ksix,ksiy,ksiz,etax,etay,etaz,hx,hy,hz,
2185 . g1x(4),g1y(4),g1z(4),g2x(4),g2y(4),g2z(4)
2186 DATA pg/.577350269189626/
2187C
2188 ksix=(-x(1,n1)+x(1,n2)+x(1,n3)-x(1,n4))*fourth
2189 ksiy=(-x(2,n1)+x(2,n2)+x(2,n3)-x(2,n4))*fourth
2190 ksiz=(-x(3,n1)+x(3,n2)+x(3,n3)-x(3,n4))*fourth
2191C
2192 etax=(-x(1,n1)-x(1,n2)+x(1,n3)+x(1,n4))*fourth
2193 etay=(-x(2,n1)-x(2,n2)+x(2,n3)+x(2,n4))*fourth
2194 etaz=(-x(3,n1)-x(3,n2)+x(3,n3)+x(3,n4))*fourth
2195C
2196 hx=(x(1,n1)-x(1,n2)+x(1,n3)-x(1,n4))*fourth
2197 hy=(x(2,n1)-x(2,n2)+x(2,n3)-x(2,n4))*fourth
2198 hz=(x(3,n1)-x(3,n2)+x(3,n3)-x(3,n4))*fourth
2199C
2200 g1x(1)=ksix-pg*hx
2201 g1y(1)=ksiy-pg*hy
2202 g1z(1)=ksiz-pg*hz
2203 g1x(3)=ksix+pg*hx
2204 g1y(3)=ksiy+pg*hy
2205 g1z(3)=ksiz+pg*hz
2206 g1x(2)=g1x(1)
2207 g1y(2)=g1y(1)
2208 g1z(2)=g1z(1)
2209 g1x(4)=g1x(3)
2210 g1y(4)=g1y(3)
2211 g1z(4)=g1z(3)
2212C
2213 g2x(1)=etax-pg*hx
2214 g2y(1)=etay-pg*hy
2215 g2z(1)=etaz-pg*hz
2216 g2x(2)=etax+pg*hx
2217 g2y(2)=etay+pg*hy
2218 g2z(2)=etaz+pg*hz
2219 g2x(3)=g2x(2)
2220 g2y(3)=g2y(2)
2221 g2z(3)=g2z(2)
2222 g2x(4)=g2x(1)
2223 g2y(4)=g2y(1)
2224 g2z(4)=g2z(1)
2225C
2226C DO I =1,4
2227c CALL PRODUITV(G1X,G1Y,G1Z,G2X,G2Y,G2Z,DETA(I))
2228C END DO
2229C
2230 DO j =1,3
2231 DO k =j,3
2232 k11(j,k)=zero
2233 k22(j,k)=zero
2234 k33(j,k)=zero
2235 k44(j,k)=zero
2236 END DO
2237 END DO
2238C
2239 DO j =1,3
2240 DO k =1,3
2241 k12(j,k)=zero
2242 k13(j,k)=zero
2243 k14(j,k)=zero
2244 k23(j,k)=zero
2245 k24(j,k)=zero
2246 k34(j,k)=zero
2247 END DO
2248 END DO
2249C
2250 s1=half*p
2251 DO np =1,4
2252c K11(1,2)=K11(1,2) + S1*VF4(1,NP)*
2253c . (VETA(1,NP)*G2Z(NP)-VKSI(1,NP)*G1Z(NP))
2254c K11(1,3)=K11(1,3) - S1*VF4(1,NP)*
2255c . (VETA(1,NP)*G2Y(NP)-VKSI(1,NP)*G1Y(NP))
2256c K11(2,3)=K11(2,3) + S1*VF4(1,NP)*
2257c . (VETA(1,NP)*G2X(NP)-VKSI(1,NP)*G1X(NP))
2258c K22(1,2)=K22(1,2) + S1*VF4(2,NP)*
2259c . (VETA(2,NP)*G2Z(NP)-VKSI(2,NP)*G1Z(NP))
2260c K22(1,3)=K22(1,3) - S1*VF4(2,NP)*
2261c . (VETA(2,NP)*G2Y(NP)-VKSI(2,NP)*G1Y(NP))
2262c K22(2,3)=K22(2,3) + S1*VF4(2,NP)*
2263c . (VETA(2,NP)*G2X(NP)-VKSI(2,NP)*G1X(NP))
2264c K33(1,2)=K33(1,2) + S1*VF4(3,NP)*
2265c . (VETA(3,NP)*G2Z(NP)-VKSI(3,NP)*G1Z(NP))
2266c K33(1,3)=K33(1,3) - S1*VF4(3,NP)*
2267c . (VETA(3,NP)*G2Y(NP)-VKSI(3,NP)*G1Y(NP))
2268c K33(2,3)=K33(2,3) + S1*VF4(3,NP)*
2269c . (VETA(3,NP)*G2X(NP)-VKSI(3,NP)*G1X(NP))
2270c K44(1,2)=K44(1,2) + S1*VF4(4,NP)*
2271c . (VETA(4,NP)*G2Z(NP)-VKSI(4,NP)*G1Z(NP))
2272c K44(1,3)=K44(1,3) - S1*VF4(4,NP)*
2273c . (VETA(4,NP)*G2Y(NP)-VKSI(4,NP)*G1Y(NP))
2274c K44(2,3)=K44(2,3) + S1*VF4(4,NP)*
2275c . (VETA(4,NP)*G2X(NP)-VKSI(4,NP)*G1X(NP))
2276C
2277 k12(1,2)=k12(1,2) + s1*vf4(1,np)*
2278 . (vksi(2,np)*g2z(np)-veta(2,np)*g1z(np))
2279 k12(1,3)=k12(1,3) - s1*vf4(1,np)*
2280 . (vksi(2,np)*g2y(np)-veta(2,np)*g1y(np))
2281 k12(2,3)=k12(2,3) + s1*vf4(1,np)*
2282 . (vksi(2,np)*g2x(np)-veta(2,np)*g1x(np))
2283 k13(1,2)=k13(1,2) + s1*vf4(1,np)*
2284 . (vksi(3,np)*g2z(np)-veta(3,np)*g1z(np))
2285 k13(1,3)=k13(1,3) - s1*vf4(1,np)*
2286 . (vksi(3,np)*g2y(np)-veta(3,np)*g1y(np))
2287 k13(2,3)=k13(2,3) + s1*vf4(1,np)*
2288 . (vksi(3,np)*g2x(np)-veta(3,np)*g1x(np))
2289 k14(1,2)=k14(1,2) + s1*vf4(1,np)*
2290 . (vksi(4,np)*g2z(np)-veta(4,np)*g1z(np))
2291 k14(1,3)=k14(1,3) - s1*vf4(1,np)*
2292 . (vksi(4,np)*g2y(np)-veta(4,np)*g1y(np))
2293 k14(2,3)=k14(2,3) + s1*vf4(1,np)*
2294 . (vksi(4,np)*g2x(np)-veta(4,np)*g1x(np))
2295 k23(1,2)=k23(1,2) + s1*vf4(2,np)*
2296 . (vksi(3,np)*g2z(np)-veta(3,np)*g1z(np))
2297 k23(1,3)=k23(1,3) - s1*vf4(2,np)*
2298 . (vksi(3,np)*g2y(np)-veta(3,np)*g1y(np))
2299 k23(2,3)=k23(2,3) + s1*vf4(2,np)*
2300 . (vksi(3,np)*g2x(np)-veta(3,np)*g1x(np))
2301 k24(1,2)=k24(1,2) + s1*vf4(2,np)*
2302 . (vksi(4,np)*g2z(np)-veta(4,np)*g1z(np))
2303 k24(1,3)=k24(1,3) - s1*vf4(2,np)*
2304 . (vksi(4,np)*g2y(np)-veta(4,np)*g1y(np))
2305 k24(2,3)=k24(2,3) + s1*vf4(2,np)*
2306 . (vksi(4,np)*g2x(np)-veta(4,np)*g1x(np))
2307 k34(1,2)=k34(1,2) + s1*vf4(3,np)*
2308 . (vksi(4,np)*g2z(np)-veta(4,np)*g1z(np))
2309 k34(1,3)=k34(1,3) - s1*vf4(3,np)*
2310 . (vksi(4,np)*g2y(np)-veta(4,np)*g1y(np))
2311 k34(2,3)=k34(2,3) + s1*vf4(3,np)*
2312 . (vksi(4,np)*g2x(np)-veta(4,np)*g1x(np))
2313 END DO
2314C
2315 DO np =1,4
2316 k12(1,2)=k12(1,2) - s1*vf4(2,np)*
2317 . (vksi(1,np)*g2z(np)-veta(1,np)*g1z(np))
2318 k12(1,3)=k12(1,3) + s1*vf4(2,np)*
2319 . (vksi(1,np)*g2y(np)-veta(1,np)*g1y(np))
2320 k12(2,3)=k12(2,3) - s1*vf4(2,np)*
2321 . (vksi(1,np)*g2x(np)-veta(1,np)*g1x(np))
2322 k13(1,2)=k13(1,2) - s1*vf4(3,np)*
2323 . (vksi(1,np)*g2z(np)-veta(1,np)*g1z(np))
2324 k13(1,3)=k13(1,3) + s1*vf4(3,np)*
2325 . (vksi(1,np)*g2y(np)-veta(1,np)*g1y(np))
2326 k13(2,3)=k13(2,3) - s1*vf4(3,np)*
2327 . (vksi(1,np)*g2x(np)-veta(1,np)*g1x(np))
2328 k14(1,2)=k14(1,2) - s1*vf4(4,np)*
2329 . (vksi(1,np)*g2z(np)-veta(1,np)*g1z(np))
2330 k14(1,3)=k14(1,3) + s1*vf4(4,np)*
2331 . (vksi(1,np)*g2y(np)-veta(1,np)*g1y(np))
2332 k14(2,3)=k14(2,3) - s1*vf4(4,np)*
2333 . (vksi(1,np)*g2x(np)-veta(1,np)*g1x(np))
2334 k23(1,2)=k23(1,2) - s1*vf4(3,np)*
2335 . (vksi(2,np)*g2z(np)-veta(2,np)*g1z(np))
2336 k23(1,3)=k23(1,3) + s1*vf4(3,np)*
2337 . (vksi(2,np)*g2y(np)-veta(2,np)*g1y(np))
2338 k23(2,3)=k23(2,3) - s1*vf4(3,np)*
2339 . (vksi(2,np)*g2x(np)-veta(2,np)*g1x(np))
2340 k24(1,2)=k24(1,2) - s1*vf4(4,np)*
2341 . (vksi(2,np)*g2z(np)-veta(2,np)*g1z(np))
2342 k24(1,3)=k24(1,3) + s1*vf4(4,np)*
2343 . (vksi(2,np)*g2y(np)-veta(2,np)*g1y(np))
2344 k24(2,3)=k24(2,3) - s1*vf4(4,np)*
2345 . (vksi(2,np)*g2x(np)-veta(2,np)*g1x(np))
2346 k34(1,2)=k34(1,2) - s1*vf4(4,np)*
2347 . (vksi(3,np)*g2z(np)-veta(3,np)*g1z(np))
2348 k34(1,3)=k34(1,3) + s1*vf4(4,np)*
2349 . (vksi(3,np)*g2y(np)-veta(3,np)*g1y(np))
2350 k34(2,3)=k34(2,3) - s1*vf4(4,np)*
2351 . (vksi(3,np)*g2x(np)-veta(3,np)*g1x(np))
2352 END DO
2353 k12(2,1)=-k12(1,2)
2354 k12(3,1)=-k12(1,3)
2355 k12(3,2)=-k12(2,3)
2356 k13(2,1)=-k13(1,2)
2357 k13(3,1)=-k13(1,3)
2358 k13(3,2)=-k13(2,3)
2359 k14(2,1)=-k14(1,2)
2360 k14(3,1)=-k14(1,3)
2361 k14(3,2)=-k14(2,3)
2362 k23(2,1)=-k23(1,2)
2363 k23(3,1)=-k23(1,3)
2364 k23(3,2)=-k23(2,3)
2365 k24(2,1)=-k24(1,2)
2366 k24(3,1)=-k24(1,3)
2367 k24(3,2)=-k24(2,3)
2368 k34(2,1)=-k34(1,2)
2369 k34(3,1)=-k34(1,3)
2370 k34(3,2)=-k34(2,3)
2371C
2372 RETURN
2373 END
2374!||====================================================================
2375!|| produitv ../engine/source/implicit/imp_glob_k.F
2376!||====================================================================
2377 SUBROUTINE produitv(RX, RY, RZ, SX, SY, SZ,DET)
2378C-----------------------------------------------
2379C I m p l i c i t T y p e s
2380C-----------------------------------------------
2381#include "implicit_f.inc"
2382C-----------------------------------------------
2383C D u m m y A r g u m e n t s
2384C-----------------------------------------------
2385C REAL
2386 my_real
2387 . rx , ry , rz,sx , sy, sz, det
2388C-----------------------------------------------
2389C L o c a l V a r i a b l e s
2390C-----------------------------------------------
2391 INTEGER I
2392C REAL
2393C 12
2394 my_real
2395 . e3x,e3y,e3z
2396 e3x = ry * sz - rz * sy
2397 e3y = rz * sx - rx * sz
2398 e3z = rx * sy - ry * sx
2399 det= sqrt(e3x*e3x + e3y*e3y + e3z*e3z)
2400C
2401 RETURN
2402 END
2403!||====================================================================
2404!|| kp4_ini ../engine/source/implicit/imp_glob_k.F
2405!||--- called by ------------------------------------------------------
2406!|| imp_kpres ../engine/source/implicit/imp_glob_k.F
2407!||====================================================================
2408 SUBROUTINE kp4_ini(VKSI,VETA,VF4)
2409C-----------------------------------------------
2410C I m p l i c i t T y p e s
2411C-----------------------------------------------
2412#include "implicit_f.inc"
2413C-----------------------------------------------
2414C C o m m o n B l o c k s
2415C-----------------------------------------------
2416C-----------------------------------------------------------------
2417C D u m m y A r g u m e n t s
2418C-----------------------------------------------
2419 my_real
2420 . vksi(4,4),veta(4,4),vf4(4,4)
2421C-----------------------------------------------
2422C L o c a l V a r i a b l e s
2423C-----------------------------------------------
2424 INTEGER I, J ,K
2425 my_real
2426 . pg,pg2
2427 DATA pg/.577350269189626/
2428C------------NI,ksi=VKSI,NI,eta=VETA--------------------------------
2429 vksi(1,1)=-fourth*(one+pg)
2430 vksi(2,1)=-vksi(1,1)
2431 vksi(3,1)= fourth*(one-pg)
2432 vksi(4,1)=-vksi(3,1)
2433 veta(1,1)=-fourth*(one+pg)
2434 veta(2,1)=-fourth*(one-pg)
2435 veta(3,1)=-veta(2,1)
2436 veta(4,1)=-veta(1,1)
2437 vksi(1,2)= vksi(1,1)
2438 vksi(2,2)=-vksi(1,2)
2439 vksi(3,2)= vksi(3,1)
2440 vksi(4,2)=-vksi(3,2)
2441 veta(1,2)= veta(2,1)
2442 veta(2,2)= veta(1,1)
2443 veta(3,2)=-veta(2,2)
2444 veta(4,2)=-veta(1,2)
2445 vksi(1,3)=-vksi(3,1)
2446 vksi(2,3)=-vksi(1,3)
2447 vksi(3,3)=-vksi(1,1)
2448 vksi(4,3)=-vksi(3,3)
2449 veta(1,3)= veta(1,2)
2450 veta(2,3)= veta(2,2)
2451 veta(3,3)=-veta(2,3)
2452 veta(4,3)=-veta(1,3)
2453 vksi(1,4)= vksi(1,3)
2454 vksi(2,4)=-vksi(1,4)
2455 vksi(3,4)= vksi(3,3)
2456 vksi(4,4)=-vksi(3,4)
2457 veta(1,4)= veta(1,1)
2458 veta(2,4)= veta(2,1)
2459 veta(3,4)=-veta(2,4)
2460 veta(4,4)=-veta(1,4)
2461 pg2=fourth*pg*pg
2462 DO i =1,4
2463 vf4(i,1)=fourth+(-vksi(i,1)-veta(i,1))*pg
2464 vf4(i,2)=fourth+(vksi(i,2)-veta(i,2))*pg
2465 vf4(i,3)=fourth+(vksi(i,3)+veta(i,3))*pg
2466 vf4(i,4)=fourth+(-vksi(i,4)+veta(i,4))*pg
2467 END DO
2468 vf4(1,1)=vf4(1,1)-pg2
2469 vf4(2,1)=vf4(2,1)+pg2
2470 vf4(3,1)=vf4(3,1)-pg2
2471 vf4(4,1)=vf4(4,1)+pg2
2472 vf4(1,2)=vf4(1,2)+pg2
2473 vf4(2,2)=vf4(2,2)-pg2
2474 vf4(3,2)=vf4(3,2)+pg2
2475 vf4(4,2)=vf4(4,2)-pg2
2476 vf4(1,3)=vf4(1,3)-pg2
2477 vf4(2,3)=vf4(2,3)+pg2
2478 vf4(3,3)=vf4(3,3)-pg2
2479 vf4(4,3)=vf4(4,3)+pg2
2480 vf4(1,4)=vf4(1,4)+pg2
2481 vf4(2,4)=vf4(2,4)-pg2
2482 vf4(3,4)=vf4(3,4)+pg2
2483 vf4(4,4)=vf4(4,4)-pg2
2484 RETURN
2485 END
2486!||====================================================================
2487!|| kptria ../engine/source/implicit/imp_glob_k.F
2488!||--- called by ------------------------------------------------------
2489!|| imp_kpres ../engine/source/implicit/imp_glob_k.F
2490!||====================================================================
2491 SUBROUTINE kptria(N1,N2,N3,P,X,
2492 . K11,K22,K33,K12,K13,K23)
2493C-----------------------------------------------
2494C I m p l i c i t T y p e s
2495C-----------------------------------------------
2496#include "implicit_f.inc"
2497C-----------------------------------------------
2498C C o m m o n B l o c k s
2499C-----------------------------------------------
2500C-----------------------------------------------------------------
2501C D u m m y A r g u m e n t s
2502C-----------------------------------------------
2503 INTEGER N1,N2,N3
2504 my_real
2505 . p,x(3,*),
2506 . k11(6,6),k22(6,6),k33(6,6),k12(6,6),
2507 . k13(6,6),k23(6,6)
2508C-----------------------------------------------
2509C L o c a l V a r i a b l e s
2510C-----------------------------------------------
2511 INTEGER I, J ,K
2512 my_real
2513 . x21,y21,z21,x31,y31,z31,s1,g1x,g1y,g1z,g2x,g2y,g2z
2514C
2515 x21=x(1,n2)-x(1,n1)
2516 y21=x(2,n2)-x(2,n1)
2517 z21=x(3,n2)-x(3,n1)
2518 x31=x(1,n3)-x(1,n1)
2519 y31=x(2,n3)-x(2,n1)
2520 z31=x(3,n3)-x(3,n1)
2521C
2522 g1x=x21
2523 g1y=y21
2524 g1z=z21
2525 g2x=x31
2526 g2y=y31
2527 g2z=z31
2528C CALL PRODUITV(G1X,G1Y,G1Z,G2X,G2Y,G2Z,DETA2)
2529 DO k =1,3
2530 k11(k,k)=zero
2531 k22(k,k)=zero
2532 k33(k,k)=zero
2533 k12(k,k)=zero
2534 k13(k,k)=zero
2535 k23(k,k)=zero
2536 END DO
2537C
2538 s1 = one_over_6*p*half
2539C K11(1,2)=-S1*(G2Z-G1Z)
2540C K11(1,3)=S1*(G2Y-G1Y)
2541C K11(2,3)=-S1*(G2X-G1X)
2542C K22(1,2)=S1*G2Z
2543C K22(1,3)=-S1*G2Y
2544C K22(2,3)=S1*G2X
2545C K33(1,2)=-S1*G1Z
2546C K33(1,3)=S1*G1Y
2547C K33(2,3)=-S1*G1X
2548 k11(1,2)=zero
2549 k11(1,3)=zero
2550 k11(2,3)=zero
2551 k22(1,2)=zero
2552 k22(1,3)=zero
2553 k22(2,3)=zero
2554 k33(1,2)=zero
2555 k33(1,3)=zero
2556 k33(2,3)=zero
2557C----------Kij(1,2) =0.5(Kij(1,2)+Kji(2,1))
2558 k12(1,2)=s1*(g2z+g2z-g1z)
2559 k12(1,3)=-s1*(g2y+g2y-g1y)
2560 k12(2,3)=s1*(g2x+g2x-g1x)
2561 k13(1,2)=-s1*(g1z-g2z+g1z)
2562 k13(1,3)=s1*(g1y-g2y+g1y)
2563 k13(2,3)=-s1*(g1x-g2x+g1x)
2564 k23(1,2)=-s1*(g1z+g2z)
2565 k23(1,3)=s1*(g1y+g2y)
2566 k23(2,3)=-s1*(g1x+g2x)
2567C
2568 k12(2,1)=-k12(1,2)
2569 k12(3,1)=-k12(1,3)
2570 k12(3,2)=-k12(2,3)
2571 k13(2,1)=-k13(1,2)
2572 k13(3,1)=-k13(1,3)
2573 k13(3,2)=-k13(2,3)
2574 k23(2,1)=-k23(1,2)
2575 k23(3,1)=-k23(1,3)
2576 k23(3,2)=-k23(2,3)
2577C
2578 RETURN
2579 END
2580!||====================================================================
2581!|| assemc_kii ../engine/source/implicit/imp_glob_k.F
2582!||--- called by ------------------------------------------------------
2583!|| assem_c3 ../engine/source/implicit/assem_c3.F
2584!|| assem_c4 ../engine/source/implicit/assem_c4.F
2585!|| assemc_kij ../engine/source/implicit/imp_glob_k.F
2586!||====================================================================
2587 SUBROUTINE assemc_kii(NI ,NEL ,IDDL ,IADK ,K_DIAG,
2588 1 K_LT ,KII ,ND ,OFF ,NDOF )
2589C----6---------------------------------------------------------------7---------8
2590C I m p l i c i t T y p e s
2591C-----------------------------------------------
2592#include "implicit_f.inc"
2593C-----------------------------------------------
2594C C o m m o n B l o c k s
2595C-----------------------------------------------
2596#include "impl1_c.inc"
2597#include "comlock.inc"
2598C-----------------------------------------------------------------
2599C D u m m y A r g u m e n t s
2600C-----------------------------------------------
2601 INTEGER ND
2602 INTEGER NI(*),NEL ,IDDL(*) , IADK(*),NDOF(*)
2603C REAL
2604 my_real
2605 . k_diag(*) ,k_lt(*) ,kii(nd,nd,*),off(*)
2606C-----------------------------------------------
2607C L o c a l V a r i a b l e s
2608C-----------------------------------------------
2609C----6---used only for shell due to npt=1 -> NDOF=3-------
2610 INTEGER N,K,EP,IK,ID,JD,L
2611C----6----------KII is always triag_sup whatever IKPAT---------------7--------
2612C lock by element too penalizing for performance
2613#include "lockon.inc"
2614 DO ep = 1,nel
2615 IF (off(ep)>zero.AND.ni(ep)>0) THEN
2616 n = ni(ep)
2617 id = iddl(n)
2618 IF (ikpat==0) THEN
2619 DO k=1,ndof(n)
2620c#include "lockon.inc"
2621 k_diag(id+k) = k_diag(id+k) + kii(k,k,ep)
2622c#include "lockoff.inc"
2623 jd = iadk(id+k)-1
2624 DO l=k+1,ndof(n)
2625 ik = jd+l-k
2626c#include "lockon.inc"
2627 k_lt(ik) = k_lt(ik) + kii(k,l,ep)
2628c#include "lockoff.inc"
2629 ENDDO
2630 ENDDO
2631 ELSE
2632 DO k=1,ndof(n)
2633c#include "lockon.inc"
2634 k_diag(id+k) = k_diag(id+k) + kii(k,k,ep)
2635c#include "lockoff.inc"
2636 jd = iadk(id+k+1)-k
2637 DO l=1,k-1
2638 ik = jd+l
2639c#include "lockon.inc"
2640 k_lt(ik) = k_lt(ik) + kii(l,k,ep)
2641c#include "lockoff.inc"
2642 ENDDO
2643 ENDDO
2644 ENDIF
2645 ENDIF
2646 ENDDO
2647#include "lockoff.inc"
2648C
2649 RETURN
2650 END
2651!||====================================================================
2652!|| assemc_kij ../engine/source/implicit/imp_glob_k.F
2653!||--- called by ------------------------------------------------------
2654!|| assem_c3 ../engine/source/implicit/assem_c3.F
2655!|| assem_c4 ../engine/source/implicit/assem_c4.F
2656!||--- calls -----------------------------------------------------
2657!|| assemc_kii ../engine/source/implicit/imp_glob_k.F
2658!||====================================================================
2659 SUBROUTINE assemc_kij( NI ,NJ ,NEL ,IDDL ,IADK,JDIK,
2660 1 K_DIAG,K_LT ,KIJ ,ND ,OFF ,
2661 2 NDOF )
2662C----6---------------------------------------------------------------7---------8
2663C I m p l i c i t T y p e s
2664C-----------------------------------------------
2665#include "implicit_f.inc"
2666C-----------------------------------------------
2667C G l o b a l P a r a m e t e r s
2668C-----------------------------------------------
2669#include "mvsiz_p.inc"
2670C-----------------------------------------------
2671C C o m m o n B l o c k s
2672C-----------------------------------------------
2673#include "comlock.inc"
2674#include "impl1_c.inc"
2675C-----------------------------------------------------------------
2676C D u m m y A r g u m e n t s
2677C-----------------------------------------------
2678 INTEGER ND
2679 INTEGER NI(*),NJ(*),NEL ,IDDL(*) ,IADK(*),JDIK(*) ,NDOF(*)
2680C REAL
2681 my_real
2682 . k_diag(*),k_lt(*) ,kij(nd,nd,*),off(*)
2683C-----------------------------------------------
2684C L o c a l V a r i a b l e s
2685C-----------------------------------------------
2686 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ,NN(MVSIZ),NELD,N,N1,N2
2687 my_real
2688 . KIJD(ND,ND,MVSIZ),OFFD(MVSIZ)
2689C---- if there is des elms degeneres--------------
2690 NELD=0
2691 do ep = 1,nel
2692 IF (ni(ep)==nj(ep).AND.off(ep)>zero.AND.ni(ep)>0) THEN
2693 neld=neld+1
2694 n=ni(ep)
2695 nn(neld)=n
2696 offd(neld)=off(ep)
2697 DO i=1,ndof(n)
2698 DO j=i,ndof(n)
2699 kijd(i,j,neld)=kij(i,j,ep)+kij(j,i,ep)
2700 ENDDO
2701 ENDDO
2702 ENDIF
2703 ENDDO
2704 IF (neld>0)
2705 . CALL assemc_kii(nn ,neld ,iddl ,iadk ,k_diag,
2706 . k_lt ,kijd ,nd ,offd ,ndof )
2707C----6---------------------------------------------------------------7---------8
2708C lock by element too penalizing for performance
2709#include "lockon.inc"
2710 IF (ikpat==0) THEN
2711 DO ep = 1,nel
2712 IF (off(ep)>zero.AND.ni(ep)/=nj(ep).AND.
2713 . ni(ep)>0.AND.nj(ep)>0) THEN
2714 n1=ni(ep)
2715 n2=nj(ep)
2716 i = iddl(n1)
2717 j = iddl(n2)
2718 id = min(i,j)
2719 jd = max(i,j)+1
2720 IF (i==id) THEN
2721 DO k=1,ndof(n1)
2722 DO jj = iadk(id+k),iadk(id+1+k)-1
2723C-------- Find l'Address in LT -----
2724 IF (jdik(jj)==jd) THEN
2725 jdl = jj-1
2726 GOTO 100
2727 ENDIF
2728 ENDDO
2729 100 DO l=1,ndof(n1)
2730c#include "lockon.inc"
2731 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l,ep)
2732c#include "lockoff.inc"
2733 ENDDO
2734 ENDDO
2735 ELSE
2736 DO k=1,ndof(n2)
2737 DO jj = iadk(id+k),iadk(id+1+k)-1
2738 IF (jdik(jj)==jd) THEN
2739 jdl = jj-1
2740 GOTO 200
2741 ENDIF
2742 ENDDO
2743 200 DO l=1,ndof(n2)
2744c#include "lockon.inc"
2745 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k,ep)
2746c#include "lockoff.inc"
2747 ENDDO
2748 ENDDO
2749 ENDIF
2750 ENDIF
2751 ENDDO
2752 ELSE
2753 DO ep = 1,nel
2754 IF (off(ep)>zero.AND.ni(ep)/=nj(ep).AND.
2755 . ni(ep)>0.AND.nj(ep)>0) THEN
2756 n1=ni(ep)
2757 n2=nj(ep)
2758 i = iddl(n1)
2759 j = iddl(n2)
2760 id = max(i,j)
2761 jd = min(i,j)+1
2762 IF (i==id) THEN
2763 DO k=1,ndof(n1)
2764 DO jj = iadk(id+k),iadk(id+1+k)-1
2765C-------- Find l'Address in LT -----
2766 IF (jdik(jj)==jd) THEN
2767 jdl = jj-1
2768 GOTO 300
2769 ENDIF
2770 ENDDO
2771 300 DO l=1,ndof(n1)
2772c#include "lockon.inc"
2773 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l,ep)
2774c#include "lockoff.inc"
2775 ENDDO
2776 ENDDO
2777 ELSE
2778 DO k=1,ndof(n2)
2779 DO jj = iadk(id+k),iadk(id+1+k)-1
2780 IF (jdik(jj)==jd) THEN
2781 jdl = jj-1
2782 GOTO 400
2783 ENDIF
2784 ENDDO
2785 400 DO l=1,ndof(n2)
2786c#include "lockon.inc"
2787 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k,ep)
2788c#include "lockoff.inc"
2789 ENDDO
2790 ENDDO
2791 ENDIF
2792 ENDIF
2793 ENDDO
2794 ENDIF
2795#include "lockoff.inc"
2796C
2797C----6---------------------------------------------------------------7---------8
2798 RETURN
2799 END
2800C-----------------------------------------------
2801!||====================================================================
2802!|| grpreorder ../engine/source/implicit/imp_glob_k.F
2803!||--- called by ------------------------------------------------------
2804!|| etfac_ini ../engine/source/implicit/imp_init.F
2805!|| imp_glob_khp ../engine/source/implicit/imp_glob_k.F
2806!|| ktbuf_ini ../engine/source/implicit/imp_init.F
2807!||====================================================================
2808 SUBROUTINE grpreorder(IPARG, IGROUC)
2809C----6---------------------------------------------------------------7---------8
2810C I m p l i c i t T y p e s
2811C-----------------------------------------------
2812#include "implicit_f.inc"
2813C-----------------------------------------------
2814C C o m m o n B l o c k s
2815C-----------------------------------------------
2816#include "com01_c.inc"
2817#include "param_c.inc"
2818C-----------------------------------------------------------------
2819C D u m m y A r g u m e n t s
2820C-----------------------------------------------
2821 INTEGER IPARG(NPARG,*),IGROUC(*)
2822C-----------------------------------------------
2823C L o c a l V a r i a b l e s
2824C-----------------------------------------------
2825 INTEGER NG, ITY, NGROUC
2826C-----------------------------------------------
2827C-------------first shell+ other
2828 ngrouc = 0
2829 DO ng = 1, ngroup
2830 ity =iparg(5,ng)
2831 IF(ity==3.OR.ity==7)THEN
2832 ngrouc = ngrouc + 1
2833 igrouc(ngrouc)=ng
2834 END IF
2835 END DO
2836 DO ng = 1, ngroup
2837 ity =iparg(5,ng)
2838 IF(ity==3.OR.ity==7)THEN
2839 ELSE
2840 ngrouc = ngrouc + 1
2841 igrouc(ngrouc)=ng
2842 END IF
2843 END DO
2844C
2845 RETURN
2846 END
2847C
2848!||====================================================================
2849!|| imp_glob_khp ../engine/source/implicit/imp_glob_k.F
2850!||--- called by ------------------------------------------------------
2851!|| imp_buck ../engine/source/implicit/imp_buck.F
2852!|| imp_chkm ../engine/source/implicit/imp_solv.F
2853!|| imp_solv ../engine/source/implicit/imp_solv.F
2854!||--- calls -----------------------------------------------------
2855!|| grpreorder ../engine/source/implicit/imp_glob_k.F
2856!|| imp_glob_k0 ../engine/source/implicit/imp_glob_k.F
2857!|| omp_get_thread_num ../engine/source/engine/openmp_stub.F90
2858!|| spmd_max_i ../engine/source/mpi/implicit/imp_spmd.F
2859!||--- uses -----------------------------------------------------
2860!|| drape_mod ../engine/share/modules/drape_mod.F
2861!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
2862!|| element_mod ../common_source/modules/elements/element_mod.F90
2863!|| initbuf_mod ../engine/share/resol/initbuf.F
2864!|| stack_mod ../engine/share/modules/stack_mod.F
2865!||====================================================================
2866 SUBROUTINE imp_glob_khp(
2867 1 PM ,GEO ,IPM ,IGEO ,ELBUF ,
2868 2 IXS ,IXQ ,IXC ,IXT ,IXP ,
2869 3 IXR ,IXTG ,IXTG1 ,IXS10 ,
2870 4 IXS20 ,IXS16 ,IPARG ,TF ,NPC ,
2871 5 FR_WAVE ,W16 ,BUFMAT ,THKE ,BUFGEO ,
2872 6 RBY ,SKEW ,X ,
2873 7 WA ,IDDL ,NDOF ,K_DIAG ,K_LT ,
2874 8 IADK ,JDIK ,IKGEO ,ETAG ,ITASK0 ,
2875 9 ELBUF_TAB ,STACK ,DRAPE_SH4N, DRAPE_SH3N ,DRAPEG )
2876C-----------------------------------------------
2877C M o d u l e s
2878C-----------------------------------------------
2879 USE initbuf_mod
2880 USE elbufdef_mod
2881 USE stack_mod
2882 USE drape_mod
2883 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
2884C-----------------------------------------------
2885C I m p l i c i t T y p e s
2886C-----------------------------------------------
2887#include "implicit_f.inc"
2888#include "comlock.inc"
2889C-----------------------------------------------
2890C C o m m o n B l o c k s
2891C-----------------------------------------------
2892#include "com01_c.inc"
2893#include "param_c.inc"
2894#include "task_c.inc"
2895#include "units_c.inc"
2896#include "impl1_c.inc"
2897C-----------------------------------------------------------------
2898C D u m m y A r g u m e n t s
2899C-----------------------------------------------
2900 INTEGER IDDL(*) ,NDOF(*) ,IADK(*) ,JDIK(*) ,
2901 . IPM(NPROPMI,*),IGEO(NPROPGI,*),IKGEO,ITASK0
2902 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
2903 . IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*),
2904 . NPC(*), IPARG(NPARG,*),
2905 . IXS10(6,*),IXS20(12,*),IXS16(8,*),IXTG1(4,*), ETAG(*)
2906C REAL
2907 my_real
2908 . PM(NPROPM,*),GEO(NPROPG,*),BUFMAT(*) ,TF(*) ,
2909 . FR_WAVE(*) ,ELBUF(*) ,THKE(*),RBY(*),SKEW(LSKEW,*),
2910 . bufgeo(*),w16(*),x(3,*),wa(*)
2911 my_real
2912 . k_diag(*) ,k_lt(*)
2913 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
2914 TYPE (STACK_PLY) :: STACK
2915 TYPE (DRAPE_), TARGET :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
2916 TYPE (DRAPEG_) :: DRAPEG
2917C-----------------------------------------------
2918C L o c a l V a r i a b l e s
2919C-----------------------------------------------
2920 INTEGER I,N,ITASK
2921 INTEGER IGROUC(NGROUP),IPRMES_EL(40)
2922C
2923 INTEGER OMP_GET_THREAD_NUM
2924 EXTERNAL omp_get_thread_num
2925C----6---------------------------------------------------------------7-2
2926 IF (ncycle==1.AND.inconv==1) THEN
2927 DO i=1,40
2928 iprmes_el(i)=0
2929 ENDDO
2930C /---------------/
2931 END IF
2932 CALL grpreorder(iparg, igrouc)
2933!$OMP PARALLEL PRIVATE(ITASK)
2934 itask = omp_get_thread_num()
2935
2936c
2937 CALL imp_glob_k0(
2938 1 pm ,geo ,ipm ,igeo ,elbuf ,
2939 2 ixs ,ixq ,ixc ,ixt ,ixp ,
2940 3 ixr ,ixtg ,ixtg1 ,ixs10 ,
2941 4 ixs20 ,ixs16 ,iparg ,tf ,npc ,
2942 5 fr_wave ,w16 ,bufmat ,thke ,bufgeo ,
2943 6 rby ,skew ,x ,
2944 7 wa ,iddl ,ndof ,k_diag ,k_lt ,
2945 8 iadk ,jdik ,ikgeo ,etag ,itask ,
2946 9 elbuf_tab ,igrouc ,iprmes_el ,stack ,drape_sh4n, drape_sh3n ,
2947 a drapeg )
2948C
2949!$OMP END PARALLEL
2950 IF (ncycle==1.AND.inconv==1) THEN
2951 IF (nspmd>1) THEN
2952 DO i=1,19
2953 CALL spmd_max_i(iprmes_el(i))
2954 ENDDO
2955 ENDIF
2956 IF (ispmd == 0 ) THEN
2957 DO i=1,19
2958 IF (iprmes_el(i)>0) THEN
2959 SELECT CASE (i)
2960C
2961 CASE(1)
2962 WRITE(iout,1006)
2963 WRITE(istdo,1006)
2964 CASE(2)
2965 WRITE(iout,1001)' S16 SOLID'
2966 WRITE(istdo,1001)' S16 SOLID'
2967 CASE(3)
2968 n = 24
2969 WRITE(iout,1002) n
2970 CASE(4)
2971 n = 12
2972 WRITE(iout,1002) n
2973 CASE(5)
2974 n = 0
2975 WRITE(iout,1002) n
2976 CASE(6)
2977 n = iprmes_el(i)
2978 WRITE(iout,1002) n
2979 CASE(7)
2980 WRITE(iout,1001)' USERS '
2981 WRITE(istdo,1001)' USERS '
2982 CASE(8)
2983 WRITE(iout,1001)' HEPH SOLID'
2984 CASE(9,10)
2985 WRITE(iout,1001)' S8 SOLID'
2986 CASE(11)
2987 WRITE(iout,1001)' QUAD 2D '
2988 WRITE(istdo,1001)' QUAD 2D '
2989 CASE(12)
2990 n = 4
2991 WRITE(iout,1003) n
2992 CASE(13)
2993 n = 3
2994 WRITE(iout,1003) n
2995 CASE(14)
2996 n = 1
2997 WRITE(iout,1003) n
2998 CASE(15)
2999 n = iprmes_el(i)
3000 WRITE(iout,1003) n
3001 CASE(16)
3002 n = iprmes_el(i)
3003 WRITE(iout,1005) n
3004 WRITE(istdo,1005) n
3005 CASE(17)
3006 WRITE(iout,1001)' S3N6 SHELL'
3007 WRITE(istdo,1001)' S3N6 SHELL'
3008 CASE(18)
3009 n = iprmes_el(i)
3010 WRITE(iout,1004) n
3011 CASE(19)
3012 WRITE(iout,1001)'USER-SPRING'
3013 WRITE(istdo,1001)'USER-SPRING'
3014 END SELECT
3015 ENDIF
3016 ENDDO
3017 ENDIF
3018 END IF !(NCYCLE==1.AND.INCONV==1) THEN
3019C----6---------------------------------------------------------------7---------8
3020 1001 FORMAT(' ***** WARNING : IMPLICIT FORMULATION IS NOT AVAILABLE
3021 . WITH '/,2x,a11,' ELEMENT : STIFFNESS IGNORED *****')
3022 1002 FORMAT(' ***** WARNING : ELEMENT FORMULATION ISOLID= ',
3023 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING,'
3024 . ,' USING GENERIC ONE INSTEAD'/
3025 . ,5x,' POSSIBLE CONVERGING ISSUE. *****')
3026 1003 FORMAT(' ***** WARNING : ELEMENT FORMULATION ISHELL= ',
3027 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING,'
3028 . ,' USING GENERIC ONE INSTEAD'/
3029 . ,5x,' POSSIBLE CONVERGING ISSUE. *****')
3030 1004 FORMAT(' ***** WARNING : ELEMENT FORMULATION ISH3N = ',
3031 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING,'
3032 . ,' USING GENERIC ONE INSTEAD'/
3033 . ,5x,' POSSIBLE CONVERGING ISSUE. *****')
3034 1005 FORMAT(' ***** WARNING : SPRING ELEMENT PROP.TYPE = ',
3035 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING,'
3036 . ,' STIFFNESS IGNORED *****')
3037 1006 FORMAT(' *****WARNING : TETRA ELEMENT FORMULATION W/ ITETRA>0 '/,
3038 . 5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'/,
3039 . 5x,'USING ITETRA=0 INSTEAD, POSSIBLE CONVERGING ISSUE.')
3040 RETURN
3041 END
3042!||====================================================================
3043!|| imp_glob_k0 ../engine/source/implicit/imp_glob_k.F
3044!||--- called by ------------------------------------------------------
3045!|| imp_glob_khp ../engine/source/implicit/imp_glob_k.F
3046!||--- calls -----------------------------------------------------
3047!|| c3ke3 ../engine/source/elements/sh3n/coque3n/c3ke3.F
3048!|| cbake3 ../engine/source/elements/shell/coqueba/cbake3.F
3049!|| czke3 ../engine/source/elements/shell/coquez/czke3.F
3050!|| initbuf ../engine/share/resol/initbuf.F
3051!|| pke3 ../engine/source/elements/beam/pke3.F
3052!|| q4ke2 ../engine/source/elements/solid_2d/quad4/q4ke2.F
3053!|| r12ke3 ../engine/source/elements/spring/r12ke3.F
3054!|| r13ke3 ../engine/source/elements/spring/r13ke3.F
3055!|| r4ke3 ../engine/source/elements/spring/r4ke3.F
3056!|| r8ke3 ../engine/source/elements/spring/r8ke3.F
3057!|| ruser32ke3 ../engine/source/elements/spring/ruser32ke3.F
3058!|| s10ke3 ../engine/source/elements/solid/solide10/s10ke3.F
3059!|| s20ke3 ../engine/source/elements/solid/solide20/s20ke3.F
3060!|| s4ke3 ../engine/source/elements/solid/solide4/s4ke3.F
3061!|| s6cke3 ../engine/source/elements/thickshell/solide6c/s6cke3.F
3062!|| s8cke3 ../engine/source/elements/thickshell/solide8c/s8cke3.F
3063!|| s8ske3 ../engine/source/elements/solid/solide8s/s8ske3.F
3064!|| s8zke3 ../engine/source/elements/solid/solide8z/s8zke3.F
3065!|| startimeg ../engine/source/system/timer.F
3066!|| tke3 ../engine/source/elements/truss/tke3.F
3067!||--- uses -----------------------------------------------------
3068!|| drape_mod ../engine/share/modules/drape_mod.F
3069!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
3070!|| element_mod ../common_source/modules/elements/element_mod.F90
3071!|| initbuf_mod ../engine/share/resol/initbuf.F
3072!|| stack_mod ../engine/share/modules/stack_mod.F
3073!||====================================================================
3074 SUBROUTINE imp_glob_k0(
3075 1 PM ,GEO ,IPM ,IGEO ,ELBUF ,
3076 2 IXS ,IXQ ,IXC ,IXT ,IXP ,
3077 3 IXR ,IXTG ,IXTG1 ,IXS10 ,
3078 4 IXS20 ,IXS16 ,IPARG ,TF ,NPC ,
3079 5 FR_WAVE ,W16 ,BUFMAT ,THKE ,BUFGEO ,
3080 6 RBY ,SKEW ,X ,
3081 7 WA ,IDDL ,NDOF ,K_DIAG ,K_LT ,
3082 8 IADK ,JDIK ,IKGEO ,ETAG ,ITASK ,
3083 9 ELBUF_TAB ,IGROUC ,IPRMES_EL ,STACK ,DRAPE_SH4N, DRAPE_SH3N ,
3084 A DRAPEG )
3085C-----------------------------------------------
3086C M o d u l e s
3087C-----------------------------------------------
3088 USE initbuf_mod
3089 USE elbufdef_mod
3090 USE stack_mod
3091 USE drape_mod
3092 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
3093C----6---------------------------------------------------------------7---------8
3094C I m p l i c i t T y p e s
3095C-----------------------------------------------
3096#include "implicit_f.inc"
3097#include "comlock.inc"
3098C-----------------------------------------------
3099C G l o b a l P a r a m e t e r s
3100C-----------------------------------------------
3101#include "mvsiz_p.inc"
3102C-----------------------------------------------
3103C C o m m o n B l o c k s
3104C-----------------------------------------------
3105#include "com01_c.inc"
3106#include "com04_c.inc"
3107#include "param_c.inc"
3108#include "vect01_c.inc"
3109#include "scr14_c.inc"
3110#include "task_c.inc"
3111#include "impl1_c.inc"
3112C-----------------------------------------------------------------
3113C D u m m y A r g u m e n t s
3114C-----------------------------------------------
3115 INTEGER IDDL(*) ,NDOF(*) ,IADK(*) ,JDIK(*) ,
3116 . IPM(NPROPMI,*),IGEO(NPROPGI,*),IKGEO,ITASK,IGROUC(NGROUP)
3117 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
3118 . IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*),
3119 . NPC(*), IPARG(NPARG,*),
3120 . IXS10(6,*),IXS20(12,*),IXS16(8,*),IXTG1(4,*), ETAG(*),
3121 . IPRMES_EL(*)
3122C REAL
3123 my_real
3124 . PM(NPROPM,*),GEO(NPROPG,*),BUFMAT(*) ,TF(*) ,
3125 . FR_WAVE(*) ,ELBUF(*) ,THKE(*),RBY(*),SKEW(LSKEW,*),
3126 . BUFGEO(*),W16(*),X(3,*),WA(*)
3127 my_real
3128 . k_diag(*) ,k_lt(*)
3129 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
3130 TYPE (STACK_PLY) :: STACK
3131 TYPE (DRAPE_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
3132 TYPE (DRAPEG_) :: DRAPEG
3133C-----------------------------------------------
3134C L o c a l V a r i a b l e s
3135C-----------------------------------------------
3136 INTEGER I,N, NG, NVC, MLW, JFT, JLT,ISOLNOD,ITHK ,IPLA ,
3137 . K1, K2, KAD,IAD2,NF1,IPRI, NELEM, OFFSET, NSGRP, K,
3138 . K0, K3, K5, K6, K7, K8, K9, NSG, NEL, KFTS,IOFC, ISTRA,
3139 . JJ19,NPE,NIPMAX,ICNOD,NFT1,LIAD,INPT,NF2,MPT,
3140 . L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,
3141 . L17,L18,L19,L20,L21,L22,L23,L24,L25,L26,L27,L28,L29,L30,
3142 . sedrape, numel_drape
3143 INTEGER INDXOF(MVSIZ),ISH3N
3144 INTEGER ICP,ICS,IEXPAN,IETY,IG,ISUBSTACK
3145 my_real
3146 . off(mvsiz)
3147C----6---------------------------------------------------------------7-2
3148C SMP dynamic parallel loop
3149C
3150!$OMP DO SCHEDULE(DYNAMIC,1)
3151 DO ig = 1, ngroup
3152 ng = igrouc(ig)
3153C---------temporarily used to avoid pass KTBUF_STR everywhere
3154 ng_imp = ng
3155c IF(NGDONE>NGROUP) GOTO 250
3156c NGDONE = NG + 1
3157C
3158 IF(iparg(8,ng)==1)GOTO 250
3159 IF (iddw>0) CALL startimeg(ng)
3160 ity =iparg(5,ng)
3161 offset = 0
3162 mlw = iparg(1,ng)
3163C
3164 IF (mlw == 0 .OR. mlw == 13) GOTO 250
3165 CALL initbuf(iparg ,ng ,
3166 2 mlw ,nel ,nft ,kad ,ity ,
3167 3 npt ,jale ,ismstr ,jeul ,jtur ,
3168 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
3169 5 nvaux ,jpor ,jcvt ,jclose ,ipla ,
3170 6 irep ,iint ,igtyp ,israt ,isrot ,
3171 7 icsen ,isorth ,isorthg ,ifailure,jsms )
3172 icnod = iparg(11,ng)
3173 nsg = iparg(10,ng)
3174 icp = iparg(10,ng)
3175 ics = iparg(17,ng)
3176 istra = iparg(44,ng)
3177 nvc = iparg(19,ng)
3178 ithk = iparg(28,ng)
3179 isolnod = iparg(28,ng)
3180 kfts = iparg(30,ng)
3181 iexpan = iparg(49,ng)
3182 ish3n = iparg(23,ng)
3183 isubstack=iparg(71,ng)
3184 IF(ity==1) THEN
3185 liad = nvaux
3186 ENDIF
3187 IF(ity==1.OR.ity==2) jplasol=ipla
3188 iformdt = 0
3189 lft = 1
3190 llt = min(nvsiz,nel)
3191 mtn = mlw
3192 jft=lft
3193 jlt=llt
3194 nf1 = nft+1
3195 iad = kad
3196C
3197 jsph=0
3198C----6---------------------------------------------------------------7---------8
3199 IF(ity==1 .AND. jlag==1)THEN
3200 igtyp = nint(geo(12,ixs(10,nf1)))
3201 IF(isolnod==4)THEN
3202 iety=1
3203 IF (isrot > 0 .AND. ispmd==0) THEN
3204 IF (iprmes_el(iety)==0) THEN
3205 iprmes_el(iety)=1
3206 ENDIF
3207 ENDIF
3208 CALL s4ke3(
3209 1 pm, geo, ixs, x,
3210 2 elbuf_tab(ng)%GBUF, etag, iddl,
3211 3 ndof, k_diag, k_lt, iadk,
3212 4 jdik, nel, ipm, igeo,
3213 5 ikgeo, bufmat, nft, mtn,
3214 6 ismstr, jhbe, irep, isorth,
3215 7 iformdt)
3216 ELSEIF(isolnod==10)THEN
3217 nf2=nf1-numels8
3218 CALL s10ke3(
3219 1 pm, geo, ixs, ixs10,
3220 2 x, elbuf_tab(ng),etag, iddl,
3221 3 ndof, k_diag, k_lt, iadk,
3222 4 jdik, nel, ipm, igeo,
3223 5 ikgeo, bufmat, nft, mtn,
3224 6 npt, ismstr, jhbe, irep,
3225 7 isorth, jlag)
3226
3227 ELSEIF(isolnod==20)THEN
3228 CALL s20ke3(
3229 1 pm, geo, ixs, ixs20,
3230 2 x, elbuf_tab(ng),etag, iddl,
3231 3 ndof, k_diag, k_lt, iadk,
3232 4 jdik, nel, ipm, igeo,
3233 5 ikgeo, bufmat, nft, mtn,
3234 6 ismstr, jhbe, irep, igtyp,
3235 7 isorth)
3236
3237
3238 ELSEIF(isolnod==16)THEN
3239 iety=2
3240 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3241 ELSEIF(jhbe==15.AND.isolnod==6)THEN
3242 CALL s6cke3(
3243 1 pm, geo, ixs, x,
3244 2 elbuf_tab(ng),etag, iddl, ndof,
3245 3 k_diag, k_lt, iadk, jdik,
3246 4 nel, icp, ics, ipm,
3247 5 igeo, ikgeo, bufmat, nft,
3248 6 mtn, jhbe, isorth, isorthg,
3249 7 ismstr)
3250C
3251 ELSEIF(isolnod==8)THEN
3252 IF (jhbe/=14.AND.jhbe/=15.AND.jhbe/=17) THEN
3253 IF (ncycle==1.AND.imconv==1)THEN
3254 IF(jhbe==24)THEN
3255 iety=3
3256 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3257 ELSEIF(jhbe==12.OR.jhbe==112)THEN
3258 iety=4
3259 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3260 ELSEIF(jhbe==0)THEN
3261 iety=5
3262 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3263 ELSE
3264 iety=6
3265 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=jhbe
3266 ENDIF
3267 ENDIF
3268 ENDIF
3269c
3270 IF (jhbe == 14 .AND.
3271 . (igtyp == 20 .OR. igtyp == 21 .OR. igtyp == 22)) THEN
3272 CALL s8cke3(
3273 1 pm, geo, ixs, x,
3274 2 elbuf_tab(ng),nel, icp, ics,
3275 3 etag, iddl, ndof, k_diag,
3276 4 k_lt, iadk, jdik, ipm,
3277 5 igeo, ikgeo, bufmat, nft,
3278 6 mtn, jhbe, jcvt, igtyp,
3279 7 isorth, irep, ismstr)
3280 ELSE IF(jhbe == 17 .AND. iparg(36,ng) == 3) THEN
3281 mpt = 222
3282 CALL s8ske3(
3283 1 pm, geo, ixs, x,
3284 2 elbuf_tab(ng),nel, icp, ics,
3285 3 etag, iddl, ndof, k_diag,
3286 4 k_lt, iadk, jdik, mpt,
3287 5 ipm, igeo, ikgeo, bufmat,
3288 6 nft, mtn, jhbe, jcvt,
3289 7 igtyp, isorth)
3290 ELSE
3291 mpt = 222
3292 CALL s8zke3(
3293 1 pm, geo, ixs, x,
3294 2 elbuf_tab(ng),nel, icp, ics,
3295 3 etag, iddl, ndof, k_diag,
3296 4 k_lt, iadk, jdik, mpt,
3297 5 ipm, igeo, ikgeo, bufmat,
3298 6 nft, mtn, ismstr, jhbe,
3299 7 jcvt, igtyp, isorth, irep)
3300 ENDIF
3301c
3302C OPEN(UNIT=16,FILE='KE_S.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
3303C CALL IMPKSOUT( IXS,NFT,NEL,16,
3304C 1 K11 ,K12 ,K13 ,K14 ,K15 ,
3305C 2 K16 ,K17 ,K18 ,K22 ,K23 ,
3306C 3 K24 ,K25 ,K26 ,K27 ,K28 ,
3307C 4 K33 ,K34 ,K35 ,K36 ,K37 ,
3308C 5 K38 ,K44 ,K45 ,K46 ,K47 ,
3309C 6 K48 ,K55 ,K56 ,K57 ,K58 ,
3310C 7 K66 ,K67 ,K68 ,K77 ,K78 ,
3311C 8 K88 )
3312C----6---------------------------------------------------------------7---------8
3313 ELSEIF(igtyp>=29)THEN
3314 iety=7
3315 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3316C CALL SUKE3(
3317 ELSEIF(npt==1)THEN
3318 IF(jhbe==24)THEN
3319C------------- It is not likely to enter here for the moment
3320C CALL SZKE3(
3321C 1 PM ,GEO ,IXS ,X ,ELBUF(KAD),
3322C 1 K11 ,K12 ,K13 ,K14 ,K15 ,
3323C 2 K16 ,K17 ,K18 ,K22 ,K23 ,
3324C 3 K24 ,K25 ,K26 ,K27 ,K28 ,
3325C 4 K33 ,K34 ,K35 ,K36 ,K37 ,
3326C 5 K38 ,K44 ,K45 ,K46 ,K47 ,
3327C 6 K48 ,K55 ,K56 ,K57 ,K58 ,
3328C 7 K66 ,K67 ,K68 ,K77 ,K78 ,
3329C 8 K88 ,NEL ,LIAD ,ICP ,ICSIG ,
3330C 9 OFFSET,ELBUF(IAD2),OFF)
3331 iety=8
3332 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3333 ELSE
3334 iety=9
3335 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3336 ENDIF
3337 ELSEIF(npt==8.AND.mtn/=0 .AND. isolnod/=20)THEN
3338C CALL S8KE3(
3339 iety=10
3340 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3341 ENDIF
3342C----6---------------------------------------------------------------7---------8
3343 ELSEIF(ity==2.AND.jmult==0.AND.jlag==1)THEN
3344 IF ((n2d==2.AND.jhbe==17) .OR.
3345 . (n2d==1.AND.jhbe==22)) THEN
3346 inpt = iabs(npt)
3347 icp = iparg(10,ng)
3348 CALL q4ke2(
3349 1 pm, geo, ixq, x,
3350 2 elbuf_tab(ng),nel, liad, icp,
3351 3 ics, etag, iddl, ndof,
3352 4 k_diag, k_lt, iadk, jdik,
3353 5 inpt, ipm, igeo, ikgeo,
3354 6 bufmat, nft, mtn, jmult,
3355 7 jhbe, jcvt, igtyp, isorth,
3356 8 ismstr)
3357 ELSE
3358 iety=11
3359 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3360C CALL QFORC2(
3361 ENDIF
3362C----6---------------------------------------------------------------7---------8
3363 ELSEIF(ity==3)THEN
3364 iofc = 0
3365 IF(ng/=ngroup)THEN
3366 iad2 = iparg(4,ng+1) - 6 * nel
3367 ELSE
3368 iad2 = lbufel - 6 * nel + 1
3369 ENDIF
3370 IF (jhbe<11) THEN
3371 IF (ncycle==1.AND.imconv==1) THEN
3372 IF(jhbe==4)THEN
3373 iety=12
3374 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3375 ELSEIF(jhbe==3)THEN
3376 iety=13
3377 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3378 ELSEIF(jhbe==1)THEN
3379 iety=14
3380 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3381 ELSE
3382 iety=15
3383 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=jhbe
3384 ENDIF
3385 ENDIF
3386 ENDIF
3387
3388 IF(jhbe>=11.AND.jhbe<=19) THEN
3389 numel_drape = numelc_drape
3390 sedrape = scdrape
3391 CALL cbake3 (
3392 1 jft ,jlt ,nft ,iabs(npt) ,mlw ,
3393 2 ithk ,ncycle ,
3394 3 istra ,ipla ,pm ,geo ,ixc(1,nf1) ,
3395 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
3396 1 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
3397 7 jhbe ,thke(nf1) ,ismstr ,x ,ikgeo ,
3398 8 ipm ,igeo ,iexpan ,iparg(1,ng),isubstack ,
3399 9 stack ,drape_sh4n ,drapeg%INDX_SH4N, sedrape, numel_drape)
3400 ELSE
3401C
3402
3403 numel_drape = numelc_drape
3404 sedrape = scdrape
3405 CALL czke3 (
3406 1 jft ,jlt ,nft ,iabs(npt) ,mlw ,
3407 2 ithk ,ncycle ,
3408 3 istra ,ipla ,pm ,geo ,ixc(1,nf1) ,
3409 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
3410 1 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
3411 7 jhbe ,thke(nf1) ,ismstr ,x ,ikgeo ,
3412 8 ipm ,igeo ,iexpan ,iparg(1,ng),isubstack ,
3413 9 stack ,drape_sh4n ,drapeg%INDX_SH4N , sedrape, numel_drape)
3414C CALL CKE3(
3415 ENDIF
3416c OPEN(UNIT=13,FILE='KE.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
3417c CALL IMPKCOUT( IXC,NFT,NEL,13,
3418c 1 KC11 ,KC12 ,KC13 ,KC14 ,KC22 ,
3419c 2 KC23 ,KC24 ,KC33 ,KC34 ,KC44 )
3420c CALL KELAMDA( IXC,NIXC,NFT,NEL,13,
3421c 1 KC11 ,KC12 ,KC13 ,KC14 ,KC22 ,
3422c 2 KC23 ,KC24 ,KC33 ,KC34 ,KC44 )
3423
3424C----6---------------------------------------------------------------7---------8
3425 ELSEIF(ity==4)THEN
3426 CALL tke3(
3427 1 jft ,jlt ,pm ,geo ,ixt(1,nf1) ,
3428 2 x ,elbuf_tab(ng) ,nel ,offset ,ikgeo,
3429 3 etag , iddl ,ndof ,k_diag ,k_lt ,
3430 4 iadk ,jdik )
3431
3432
3433C----6---------------------------------------------------------------7---------8
3434 ELSEIF(ity==5)THEN
3435 CALL pke3(jft ,jlt ,nel ,mtn ,ismstr,
3436 1 pm ,ixp(1,nf1),x ,elbuf_tab(ng),
3437 2 geo ,offset , ikgeo,
3438 3 etag , iddl ,ndof ,k_diag ,k_lt ,
3439 4 iadk ,jdik )
3440
3441
3442c OPEN(UNIT=16,FILE='KE_P.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
3443c CALL IMPKPOUT(NIXPL,IXP,NFT,NEL,16,KC11 ,KC12 , KC22 )
3444C----6---------------------------------------------------------------7---------8
3445 ELSEIF(ity==6)THEN
3446 igtyp = nint(geo(12,ixr(1,nf1)))
3447 k1=1 + 6*(numelc+numeltg)*iepsdot + 15*(numelt+numelp+nft)
3448 IF (igtyp==4)THEN
3449 CALL r4ke3 (jft ,jlt ,nel ,mtn ,pm ,
3450 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3451 2 tf ,skew ,offset,fr_wave,
3452 3 ikgeo ,igeo,
3453 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3454 2 iadk ,jdik )
3455
3456 ELSEIF (igtyp==32)THEN
3457 CALL ruser32ke3 (jft ,jlt ,nel ,mtn ,pm ,
3458 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3459 2 tf ,skew ,offset,fr_wave,
3460 3 ikgeo ,igeo,
3461 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3462 2 iadk ,jdik )
3463
3464 ELSEIF (igtyp==8)THEN
3465 CALL r8ke3(jft ,jlt ,nel ,mtn ,pm ,
3466 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3467 2 tf ,skew ,offset,fr_wave,igeo ,
3468 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3469 2 iadk ,jdik )
3470
3471 ELSEIF (igtyp==12)THEN
3472 CALL r12ke3(jft ,jlt ,nel ,mtn ,pm ,
3473 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3474 2 tf ,skew ,offset,fr_wave,igeo ,
3475 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3476 2 iadk ,jdik )
3477
3478 ELSEIF (igtyp==13)THEN
3479 CALL r13ke3 (jft ,jlt ,nel ,mtn ,pm ,
3480 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3481 2 tf ,skew ,offset,fr_wave,ikgeo ,igeo ,
3482 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3483 2 iadk ,jdik )
3484
3485
3486C OPEN(UNIT=16,FILE='KE_SP.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
3487C CALL IMPKPOUT( NIXR,IXR,NFT,NEL,16,KC11 ,KC12 , KC22 )
3488 ELSE
3489 iety=16
3490 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=igtyp
3491 ENDIF
3492C----6---------------------------------------------------------------7---------8
3493 ELSEIF(ity==7)THEN
3494 iofc = 0
3495 IF(ng/=ngroup)THEN
3496 iad2 = iparg(4,ng+1) - 6 * nel
3497 ELSE
3498 iad2 = lbufel - 6 * nel + 1
3499 ENDIF
3500 nf1 = nft + 1
3501 IF(icnod==6)THEN
3502 iety=17
3503 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3504 ELSE
3505 IF (ish3n >= 30) THEN
3506 iety=18
3507 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=ish3n
3508 ENDIF
3509 numel_drape = numeltg_drape
3510 sedrape = stdrape
3511 CALL c3ke3 (
3512 1 jft ,jlt ,nft ,iabs(npt),mtn ,
3513 2 ithk ,ncycle ,
3514 3 istra ,ipla ,pm ,geo ,ixtg(1,nf1),
3515 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
3516 5 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
3517 6 jhbe ,thke(numelc+nf1),ismstr ,x ,
3518 7 ikgeo ,ipm ,igeo ,iexpan ,iparg(1,ng),
3519 8 isubstack , stack , drape_sh3n, drapeg%INDX_SH3N,
3520 9 sedrape, numel_drape )
3521
3522 ENDIF
3523C----6---------------------------------------------------------------7---------8
3524 ELSEIF(ity==50)THEN
3525 iety=19
3526 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3527 ENDIF
3528 250 CONTINUE
3529 END DO
3530!$OMP END DO
3531C----6---------------------------------------------------------------7---------8
3532 RETURN
3533 END
c3ke3
subroutine c3ke3(jft, jlt, nft, npt, mtn, ithk, ncycle, istrain, ipla, pm, geo, ixtg, elbuf_str, bufmat, offset, indxof, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, ihbe, thke, ismstr, x, ikgeo, ipm, igeo, iexpan, iparg, isubstack, stack, drape_sh3n, indx_drape, sedrape, numel_drape)
Definition c3ke3.F:55
cbake3
subroutine cbake3(jft, jlt, nft, npt, mtn, ithk, ncycle, istrain, ipla, pm, geo, ixc, elbuf_str, bufmat, offset, indxof, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, ihbe, thke, ismstr, x, ikgeo, ipm, igeo, iexpan, iparg, isubstack, stack, drape_sh4n, indx_drape, sedrape, numel_drape)
Definition cbake3.F:58
my_real
#define my_real
Definition cppsort.cpp:32
czke3
subroutine czke3(jft, jlt, nft, npt, mtn, ithk, ncycle, istrain, ipla, pm, geo, ixc, elbuf_str, bufmat, offset, indxof, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, ihbe, thke, ismstr, x, ikgeo, ipm, igeo, iexpan, iparg, isubstack, stack, drape_sh4n, indx_drape, sedrape, numel_drape)
Definition czke3.F:59
startimeg
subroutine startimeg(ng)
Definition timer.F:1371
imp_glob_khp
subroutine imp_glob_khp(pm, geo, ipm, igeo, elbuf, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, ixs10, ixs20, ixs16, iparg, tf, npc, fr_wave, w16, bufmat, thke, bufgeo, rby, skew, x, wa, iddl, ndof, k_diag, k_lt, iadk, jdik, ikgeo, etag, itask0, elbuf_tab, stack, drape_sh4n, drape_sh3n, drapeg)
Definition imp_glob_k.F:2876
print_wkij
subroutine print_wkij(ni, nj, iflag)
Definition imp_glob_k.F:892
impkpout
subroutine impkpout(nixpl, ixp, nft, nel, iugeo, ke11, ke12, ke22)
Definition imp_glob_k.F:1529
impkcout
subroutine impkcout(ixc, nft, nel, iugeo, ke11, ke12, ke13, ke14, ke22, ke23, ke24, ke33, ke34, ke44)
Definition imp_glob_k.F:1442
grpreorder
subroutine grpreorder(iparg, igrouc)
Definition imp_glob_k.F:2809
eleoff
subroutine eleoff(jft, jlt, ix, nix, nn, etag, off)
Definition imp_glob_k.F:1928
kptria
subroutine kptria(n1, n2, n3, p, x, k11, k22, k33, k12, k13, k23)
Definition imp_glob_k.F:2493
writeks
subroutine writeks(in, nft, nel, ig, ch, kij)
Definition imp_glob_k.F:1398
put_kmii
subroutine put_kmii(id, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:1188
put_kii
subroutine put_kii(ni, iddl, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:655
jacobien
subroutine jacobien(a, n, ew, ev, tol, lamda)
Definition imp_glob_k.F:1788
kelamda
subroutine kelamda(ixc, nixcl, nft, nel, iugeo, ke11, ke12, ke13, ke14, ke22, ke23, ke24, ke33, ke34, ke44)
Definition imp_glob_k.F:1685
impksout
subroutine impksout(ixs, nft, nel, iugeo, k11, k12, k13, k14, k15, k16, k17, k18, k22, k23, k24, k25, k26, k27, k28, k33, k34, k35, k36, k37, k38, k44, k45, k46, k47, k48, k55, k56, k57, k58, k66, k67, k68, k77, k78, k88)
Definition imp_glob_k.F:1320
impkiout
subroutine impkiout(nixpl, ixp, nft, nel, iugeo, ke11, ke12, ke22)
Definition imp_glob_k.F:1606
writekp
subroutine writekp(in, nft, nel, ig, ch, kij)
Definition imp_glob_k.F:1566
kp4_ini
subroutine kp4_ini(vksi, veta, vf4)
Definition imp_glob_k.F:2409
assem_kii
subroutine assem_kii(ni, nel, iddl, iadk, k_diag, k_lt, kii, nd, off)
Definition imp_glob_k.F:964
put_kij
subroutine put_kij(ni, nj, iddl, iadk, jdik, k_lt, kij, nk, nl, ierr)
Definition imp_glob_k.F:812
assemc_kij
subroutine assemc_kij(ni, nj, nel, iddl, iadk, jdik, k_diag, k_lt, kij, nd, off, ndof)
Definition imp_glob_k.F:2662
kpquad
subroutine kpquad(n1, n2, n3, n4, p, x, vksi, veta, vf4, k11, k22, k33, k44, k12, k13, k14, k23, k24, k34)
Definition imp_glob_k.F:2163
assem_kij
subroutine assem_kij(ni, nj, nel, iddl, iadk, jdik, k_diag, k_lt, kij, nd, off)
Definition imp_glob_k.F:1043
get_kii
subroutine get_kii(ni, iddl, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:593
produitv
subroutine produitv(rx, ry, rz, sx, sy, sz, det)
Definition imp_glob_k.F:2378
writekc
subroutine writekc(in, nft, nel, ig, ch, kij)
Definition imp_glob_k.F:1489
put_kmij
subroutine put_kmij(ini, inj, iadk, jdik, k_lt, kij, nk, nl, ierr)
Definition imp_glob_k.F:1240
imp_kpres
subroutine imp_kpres(ib, fac, npc, tf, x, skew, nsensor, sensor_tab, weight, iadc, iddl, ndof, iadk, jdik, k_diag, k_lt)
Definition imp_glob_k.F:1979
imp_glob_k
subroutine imp_glob_k(pm, geo, ipm, igeo, elbuf, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, ixs10, ixs20, ixs16, iparg, tf, npc, fr_wave, w16, bufmat, thke, bufgeo, rby, skew, x, wa, iddl, ndof, k_diag, k_lt, iadk, jdik, ikgeo, etag, elbuf_tab, stack, drape_sh4n, drape_sh3n, drapeg)
Definition imp_glob_k.F:63
assemc_kii
subroutine assemc_kii(ni, nel, iddl, iadk, k_diag, k_lt, kii, nd, off, ndof)
Definition imp_glob_k.F:2589
get_kij
subroutine get_kij(ni, nj, iddl, iadk, jdik, k_lt, kij, nk, nl, ierr)
Definition imp_glob_k.F:715
imp_glob_k0
subroutine imp_glob_k0(pm, geo, ipm, igeo, elbuf, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, ixs10, ixs20, ixs16, iparg, tf, npc, fr_wave, w16, bufmat, thke, bufgeo, rby, skew, x, wa, iddl, ndof, k_diag, k_lt, iadk, jdik, ikgeo, etag, itask, elbuf_tab, igrouc, iprmes_el, stack, drape_sh4n, drape_sh3n, drapeg)
Definition imp_glob_k.F:3085
writeki
subroutine writeki(in, nft, nel, ig, ch, kij)
Definition imp_glob_k.F:1643
spmd_max_i
subroutine spmd_max_i(n)
Definition imp_spmd.F:1362
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
drape_mod
Definition drape_mod.F:54
drape_mod::scdrape
integer scdrape
Definition drape_mod.F:92
drape_mod::stdrape
integer stdrape
Definition drape_mod.F:92
initbuf_mod
Definition initbuf.F:160
initbuf_mod::initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, mid, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure, jsms)
Definition initbuf.F:261
stack_mod
Definition stack_mod.F:75
pke3
subroutine pke3(jft, jlt, nel, mtn, ismstr, pm, ncc, x, elbuf_tab, geo, offset, ikgeo, etag, iddl, ndof, k_diag, k_lt, iadk, jdik)
Definition pke3.F:44
q4ke2
subroutine q4ke2(pm, geo, ixq, x, elbuf_str, nel, liad, icp, icsig, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, npg, ipm, igeo, ikgeo, bufmat, nft, mtn, jmult, jhbe, jcvt, igtyp, isorth, ismstr)
Definition q4ke2.F:55
r12ke3
subroutine r12ke3(jft, jlt, nel, mtn, pm, geo, ixr, x, elbuf_tab, npf, tf, skew, offset, fr_wave, igeo, etag, iddl, ndof, k_diag, k_lt, iadk, jdik)
Definition r12ke3.F:43
r13ke3
subroutine r13ke3(jft, jlt, nel, mtn, pm, geo, ixr, x, elbuf_tab, npf, tf, skew, offset, fr_wave, ikgeo, igeo, etag, iddl, ndof, k_diag, k_lt, iadk, jdik)
Definition r13ke3.F:44
r4ke3
subroutine r4ke3(jft, jlt, nel, mtn, pm, geo, ixr, x, elbuf_tab, npf, tf, skew, offset, fr_wave, ikgeo, igeo, etag, iddl, ndof, k_diag, k_lt, iadk, jdik)
Definition r4ke3.F:45
r8ke3
subroutine r8ke3(jft, jlt, nel, mtn, pm, geo, ixr, x, elbuf_tab, npf, tf, skew, offset, fr_wave, igeo, etag, iddl, ndof, k_diag, k_lt, iadk, jdik)
Definition r8ke3.F:44
ruser32ke3
subroutine ruser32ke3(jft, jlt, nel, mtn, pm, geo, ixr, x, elbuf_tab, npf, tf, skew, offset, fr_wave, ikgeo, igeo, etag, iddl, ndof, k_diag, k_lt, iadk, jdik)
Definition ruser32ke3.F:44
s10ke3
subroutine s10ke3(pm, geo, ixs, ixs10, x, elbuf_str, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, nel, ipm, igeo, ikgeo, bufmat, nft, mtn, npt, ismstr, jhbe, irep, isorth, jlag)
Definition s10ke3.F:52
s20ke3
subroutine s20ke3(pm, geo, ixs, ixs20, x, elbuf_str, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, nel, ipm, igeo, ikgeo, bufmat, nft, mtn, ismstr, jhbe, irep, igtyp, isorth)
Definition s20ke3.F:52
s4ke3
subroutine s4ke3(pm, geo, ixs, x, gbuf, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, nel, ipm, igeo, ikgeo, bufmat, nft, mtn, ismstr, jhbe, irep, isorth, iformdt)
Definition s4ke3.F:51
s6cke3
subroutine s6cke3(pm, geo, ixs, x, elbuf_str, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, nel, icp, icsig, ipm, igeo, ikgeo, bufmat, nft, mtn, jhbe, isorth, isorthg, ismstr)
Definition s6cke3.F:51
s8cke3
subroutine s8cke3(pm, geo, ixs, x, elbuf_str, nel, icp, icsig, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, ipm, igeo, ikgeo, bufmat, nft, mtn, jhbe, jcvt, igtyp, isorth, irep, ismstr)
Definition s8cke3.F:55
s8ske3
subroutine s8ske3(pm, geo, ixs, x, elbuf_str, nel, icp, icsig, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, mpt, ipm, igeo, ikgeo, bufmat, nft, mtn, jhbe, jcvt, igtyp, isorth)
Definition s8ske3.F:48
s8zke3
subroutine s8zke3(pm, geo, ixs, x, elbuf_str, nel, icp, icsig, etag, iddl, ndof, k_diag, k_lt, iadk, jdik, mpt, ipm, igeo, ikgeo, bufmat, nft, mtn, ismstr, jhbe, jcvt, igtyp, isorth, irep)
Definition s8zke3.F:55
tke3
subroutine tke3(jft, jlt, pm, geo, nct, x, elbuf_tab, nel, offset, ikgeo, etag, iddl, ndof, k_diag, k_lt, iadk, jdik)
Definition tke3.F:43