OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
imp_glob_k.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "mvsiz_p.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "vect01_c.inc"
#include "scr14_c.inc"
#include "task_c.inc"
#include "units_c.inc"
#include "impl1_c.inc"
#include "lockon.inc"
#include "lockoff.inc"

Go to the source code of this file.

Functions/Subroutines

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)
subroutine get_kii (ni, iddl, iadk, k_diag, k_lt, kii, nd)
subroutine put_kii (ni, iddl, iadk, k_diag, k_lt, kii, nd)
subroutine get_kij (ni, nj, iddl, iadk, jdik, k_lt, kij, nk, nl, ierr)
subroutine put_kij (ni, nj, iddl, iadk, jdik, k_lt, kij, nk, nl, ierr)
subroutine print_wkij (ni, nj, iflag)
subroutine assem_kii (ni, nel, iddl, iadk, k_diag, k_lt, kii, nd, off)
subroutine assem_kij (ni, nj, nel, iddl, iadk, jdik, k_diag, k_lt, kij, nd, off)
subroutine put_kmii (id, iadk, k_diag, k_lt, kii, nd)
subroutine put_kmij (ini, inj, iadk, jdik, k_lt, kij, nk, nl, ierr)
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)
subroutine writeks (in, nft, nel, ig, ch, kij)
subroutine impkcout (ixc, nft, nel, iugeo, ke11, ke12, ke13, ke14, ke22, ke23, ke24, ke33, ke34, ke44)
subroutine writekc (in, nft, nel, ig, ch, kij)
subroutine impkpout (nixpl, ixp, nft, nel, iugeo, ke11, ke12, ke22)
subroutine writekp (in, nft, nel, ig, ch, kij)
subroutine impkiout (nixpl, ixp, nft, nel, iugeo, ke11, ke12, ke22)
subroutine writeki (in, nft, nel, ig, ch, kij)
subroutine kelamda (ixc, nixcl, nft, nel, iugeo, ke11, ke12, ke13, ke14, ke22, ke23, ke24, ke33, ke34, ke44)
subroutine jacobien (a, n, ew, ev, tol, lamda)
subroutine eleoff (jft, jlt, ix, nix, nn, etag, off)
subroutine imp_kpres (ib, fac, npc, tf, x, skew, nsensor, sensor_tab, weight, iadc, iddl, ndof, iadk, jdik, k_diag, k_lt)
subroutine kpquad (n1, n2, n3, n4, p, x, vksi, veta, vf4, k11, k22, k33, k44, k12, k13, k14, k23, k24, k34)
subroutine produitv (rx, ry, rz, sx, sy, sz, det)
subroutine kp4_ini (vksi, veta, vf4)
subroutine kptria (n1, n2, n3, p, x, k11, k22, k33, k12, k13, k23)
subroutine assemc_kii (ni, nel, iddl, iadk, k_diag, k_lt, kii, nd, off, ndof)
subroutine assemc_kij (ni, nj, nel, iddl, iadk, jdik, k_diag, k_lt, kij, nd, off, ndof)
subroutine grpreorder (iparg, igrouc)
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)
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)

Function/Subroutine Documentation

◆ assem_kii()

subroutine assem_kii ( integer, dimension(*) ni,
integer nel,
integer, dimension(*) iddl,
integer, dimension(*) iadk,
k_diag,
k_lt,
kii,
integer nd,
off )

Definition at line 960 of file imp_glob_k.F.

962C-----------------------------------------------
963C I m p l i c i t T y p e s
964C-----------------------------------------------
965#include "implicit_f.inc"
966C-----------------------------------------------
967C C o m m o n B l o c k s
968C-----------------------------------------------
969#include "impl1_c.inc"
970#include "comlock.inc"
971C-----------------------------------------------
972C D u m m y A r g u m e n t s
973C-----------------------------------------------
974 INTEGER ND
975 INTEGER NI(*),NEL ,IDDL(*) , IADK(*)
976C REAL
977 my_real
978 . K_DIAG(*) ,K_LT(*) ,KII(ND,ND,*),OFF(*)
979C-----------------------------------------------
980C L o c a l V a r i a b l e s
981C-----------------------------------------------
982 INTEGER N,K,EP,IK,ID,JD,L
983C----6----------KII is always triag_sup whatever IKPAT---------------7--------
984C lock par element trop penalisant pour perf
985#include "lockon.inc"
986 DO EP = 1,NEL
987.AND. IF (OFF(EP)>ZERONI(EP)>0) THEN
988 N = NI(EP)
989 ID = IDDL(N)
990 IF (IKPAT==0) THEN
991 DO K=1,ND
992c#include "lockon.inc"
993 K_DIAG(ID+K) = K_DIAG(ID+K) + KII(K,K,EP)
994c#include "lockoff.inc"
995 JD = IADK(ID+K)-1
996 DO L=K+1,ND
997 IK = JD+L-K
998c#include "lockon.inc"
999 K_LT(IK) = K_LT(IK) + KII(K,L,EP)
1000c#include "lockoff.inc"
1001 ENDDO
1002 ENDDO
1003 ELSE
1004 DO K=1,ND
1005c#include "lockon.inc"
1006 K_DIAG(ID+K) = K_DIAG(ID+K) + KII(K,K,EP)
1007c#include "lockoff.inc"
1008 JD = IADK(ID+K+1)-K
1009 DO L=1,K-1
1010 IK = JD+L
1011c#include "lockon.inc"
1012 K_LT(IK) = K_LT(IK) + KII(L,K,EP)
1013c#include "lockoff.inc"
1014 ENDDO
1015 ENDDO
1016 ENDIF
1017 ENDIF
1018 ENDDO
1019#include "lockoff.inc"
1020C
1021 RETURN

◆ assem_kij()

subroutine assem_kij ( integer, dimension(*) ni,
integer, dimension(*) nj,
integer nel,
integer, dimension(*) iddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
k_diag,
k_lt,
kij,
integer nd,
off )

Definition at line 1039 of file imp_glob_k.F.

1041C----6---------------------------------------------------------------7---------8
1042C I m p l i c i t T y p e s
1043C-----------------------------------------------
1044#include "implicit_f.inc"
1045C-----------------------------------------------
1046C G l o b a l P a r a m e t e r s
1047C-----------------------------------------------
1048#include "mvsiz_p.inc"
1049C-----------------------------------------------
1050C C o m m o n B l o c k s
1051C-----------------------------------------------
1052#include "comlock.inc"
1053#include "impl1_c.inc"
1054C-----------------------------------------------------------------
1055C D u m m y A r g u m e n t s
1056C-----------------------------------------------
1057 INTEGER ND
1058 INTEGER NI(*),NJ(*),NEL ,IDDL(*) ,IADK(*),JDIK(*)
1059C REAL
1060 my_real
1061 . k_diag(*),k_lt(*) ,kij(nd,nd,*),off(*)
1062C-----------------------------------------------
1063C L o c a l V a r i a b l e s
1064C-----------------------------------------------
1065 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ,NN(MVSIZ),NELD
1066 my_real
1067 . kijd(nd,nd,mvsiz),offd(mvsiz)
1068C---- s'il y a des elms degeneres--------------
1069 neld=0
1070 DO ep = 1,nel
1071 IF (ni(ep)==nj(ep).AND.off(ep)>zero.AND.ni(ep)>0) THEN
1072 neld=neld+1
1073 nn(neld)=ni(ep)
1074 offd(neld)=off(ep)
1075 DO i=1,nd
1076 DO j=i,nd
1077 kijd(i,j,neld)=kij(i,j,ep)+kij(j,i,ep)
1078 ENDDO
1079 ENDDO
1080 ENDIF
1081 ENDDO
1082 IF (neld>0)
1083 . CALL assem_kii(nn ,neld ,iddl ,iadk ,k_diag,
1084 . k_lt ,kijd ,nd ,offd )
1085C----6---------------------------------------------------------------7---------8
1086#include "lockon.inc"
1087 IF (ikpat==0) THEN
1088 DO ep = 1,nel
1089 IF (off(ep)>zero.AND.ni(ep)/=nj(ep).AND.
1090 . ni(ep)>0.AND.nj(ep)>0) THEN
1091 i = iddl(ni(ep))
1092 j = iddl(nj(ep))
1093 id = min(i,j)
1094 jd = max(i,j)+1
1095 IF (i==id) THEN
1096 DO k=1,nd
1097 DO jj = iadk(id+k),iadk(id+1+k)-1
1098C---------find l'adress dans LT-----
1099 IF (jdik(jj)==jd) THEN
1100 jdl = jj-1
1101 GOTO 100
1102 ENDIF
1103 ENDDO
1104 100 DO l=1,nd
1105c#include "lockon.inc"
1106 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l,ep)
1107c#include "lockoff.inc"
1108 ENDDO
1109 ENDDO
1110 ELSE
1111 DO k=1,nd
1112 DO jj = iadk(id+k),iadk(id+1+k)-1
1113 IF (jdik(jj)==jd) THEN
1114 jdl = jj-1
1115 GOTO 200
1116 ENDIF
1117 ENDDO
1118 200 DO l=1,nd
1119c#include "lockon.inc"
1120 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k,ep)
1121c#include "lockoff.inc"
1122 ENDDO
1123 ENDDO
1124 ENDIF
1125 ENDIF
1126 ENDDO
1127 ELSE
1128 DO ep = 1,nel
1129 IF (off(ep)>zero.AND.ni(ep)/=nj(ep).AND.
1130 . ni(ep)>0.AND.nj(ep)>0) THEN
1131 i = iddl(ni(ep))
1132 j = iddl(nj(ep))
1133 id = max(i,j)
1134 jd = min(i,j)+1
1135 IF (i==id) THEN
1136 DO k=1,nd
1137 DO jj = iadk(id+k),iadk(id+1+k)-1
1138C---------find l'adress dans LT-----
1139 IF (jdik(jj)==jd) THEN
1140 jdl = jj-1
1141 GOTO 300
1142 ENDIF
1143 ENDDO
1144 300 DO l=1,nd
1145c#include "lockon.inc"
1146 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l,ep)
1147c#include "lockoff.inc"
1148 ENDDO
1149 ENDDO
1150 ELSE
1151 DO k=1,nd
1152 DO jj = iadk(id+k),iadk(id+1+k)-1
1153 IF (jdik(jj)==jd) THEN
1154 jdl = jj-1
1155 GOTO 400
1156 ENDIF
1157 ENDDO
1158 400 DO l=1,nd
1159c#include "lockon.inc"
1160 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k,ep)
1161c#include "lockoff.inc"
1162 ENDDO
1163 ENDDO
1164 ENDIF
1165 ENDIF
1166 ENDDO
1167 ENDIF
1168#include "lockoff.inc"
1169C
1170C----6---------------------------------------------------------------7---------8
1171 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
assem_kii
subroutine assem_kii(ni, nel, iddl, iadk, k_diag, k_lt, kii, nd, off)
Definition imp_glob_k.F:962
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4

◆ assemc_kii()

subroutine assemc_kii ( integer, dimension(*) ni,
integer nel,
integer, dimension(*) iddl,
integer, dimension(*) iadk,
k_diag,
k_lt,
kii,
integer nd,
off,
integer, dimension(*) ndof )

Definition at line 2579 of file imp_glob_k.F.

2581C----6---------------------------------------------------------------7---------8
2582C I m p l i c i t T y p e s
2583C-----------------------------------------------
2584#include "implicit_f.inc"
2585C-----------------------------------------------
2586C C o m m o n B l o c k s
2587C-----------------------------------------------
2588#include "impl1_c.inc"
2589#include "comlock.inc"
2590C-----------------------------------------------------------------
2591C D u m m y A r g u m e n t s
2592C-----------------------------------------------
2593 INTEGER ND
2594 INTEGER NI(*),NEL ,IDDL(*) , IADK(*),NDOF(*)
2595C REAL
2596 my_real
2597 . k_diag(*) ,k_lt(*) ,kii(nd,nd,*),off(*)
2598C-----------------------------------------------
2599C L o c a l V a r i a b l e s
2600C-----------------------------------------------
2601C----6---used only for shell due to npt=1 -> NDOF=3-------
2602 INTEGER N,K,EP,IK,ID,JD,L
2603C----6----------KII is always triag_sup whatever IKPAT---------------7--------
2604C lock par element trop penalisant pour perf
2605#include "lockon.inc"
2606 DO ep = 1,nel
2607 IF (off(ep)>zero.AND.ni(ep)>0) THEN
2608 n = ni(ep)
2609 id = iddl(n)
2610 IF (ikpat==0) THEN
2611 DO k=1,ndof(n)
2612c#include "lockon.inc"
2613 k_diag(id+k) = k_diag(id+k) + kii(k,k,ep)
2614c#include "lockoff.inc"
2615 jd = iadk(id+k)-1
2616 DO l=k+1,ndof(n)
2617 ik = jd+l-k
2618c#include "lockon.inc"
2619 k_lt(ik) = k_lt(ik) + kii(k,l,ep)
2620c#include "lockoff.inc"
2621 ENDDO
2622 ENDDO
2623 ELSE
2624 DO k=1,ndof(n)
2625c#include "lockon.inc"
2626 k_diag(id+k) = k_diag(id+k) + kii(k,k,ep)
2627c#include "lockoff.inc"
2628 jd = iadk(id+k+1)-k
2629 DO l=1,k-1
2630 ik = jd+l
2631c#include "lockon.inc"
2632 k_lt(ik) = k_lt(ik) + kii(l,k,ep)
2633c#include "lockoff.inc"
2634 ENDDO
2635 ENDDO
2636 ENDIF
2637 ENDIF
2638 ENDDO
2639#include "lockoff.inc"
2640C
2641 RETURN

◆ assemc_kij()

subroutine assemc_kij ( integer, dimension(*) ni,
integer, dimension(*) nj,
integer nel,
integer, dimension(*) iddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
k_diag,
k_lt,
kij,
integer nd,
off,
integer, dimension(*) ndof )

Definition at line 2651 of file imp_glob_k.F.

2654C----6---------------------------------------------------------------7---------8
2655C I m p l i c i t T y p e s
2656C-----------------------------------------------
2657#include "implicit_f.inc"
2658C-----------------------------------------------
2659C G l o b a l P a r a m e t e r s
2660C-----------------------------------------------
2661#include "mvsiz_p.inc"
2662C-----------------------------------------------
2663C C o m m o n B l o c k s
2664C-----------------------------------------------
2665#include "comlock.inc"
2666#include "impl1_c.inc"
2667C-----------------------------------------------------------------
2668C D u m m y A r g u m e n t s
2669C-----------------------------------------------
2670 INTEGER ND
2671 INTEGER NI(*),NJ(*),NEL ,IDDL(*) ,IADK(*),JDIK(*) ,NDOF(*)
2672C REAL
2673 my_real
2674 . k_diag(*),k_lt(*) ,kij(nd,nd,*),off(*)
2675C-----------------------------------------------
2676C L o c a l V a r i a b l e s
2677C-----------------------------------------------
2678 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ,NN(MVSIZ),NELD,N,N1,N2
2679 my_real
2680 . kijd(nd,nd,mvsiz),offd(mvsiz)
2681C---- s'il y a des elms degeneres--------------
2682 neld=0
2683 DO ep = 1,nel
2684 IF (ni(ep)==nj(ep).AND.off(ep)>zero.AND.ni(ep)>0) THEN
2685 neld=neld+1
2686 n=ni(ep)
2687 nn(neld)=n
2688 offd(neld)=off(ep)
2689 DO i=1,ndof(n)
2690 DO j=i,ndof(n)
2691 kijd(i,j,neld)=kij(i,j,ep)+kij(j,i,ep)
2692 ENDDO
2693 ENDDO
2694 ENDIF
2695 ENDDO
2696 IF (neld>0)
2697 . CALL assemc_kii(nn ,neld ,iddl ,iadk ,k_diag,
2698 . k_lt ,kijd ,nd ,offd ,ndof )
2699C----6---------------------------------------------------------------7---------8
2700C lock par element trop penalisant pour perf
2701#include "lockon.inc"
2702 IF (ikpat==0) THEN
2703 DO ep = 1,nel
2704 IF (off(ep)>zero.AND.ni(ep)/=nj(ep).AND.
2705 . ni(ep)>0.AND.nj(ep)>0) THEN
2706 n1=ni(ep)
2707 n2=nj(ep)
2708 i = iddl(n1)
2709 j = iddl(n2)
2710 id = min(i,j)
2711 jd = max(i,j)+1
2712 IF (i==id) THEN
2713 DO k=1,ndof(n1)
2714 DO jj = iadk(id+k),iadk(id+1+k)-1
2715C---------find l'adress dans LT-----
2716 IF (jdik(jj)==jd) THEN
2717 jdl = jj-1
2718 GOTO 100
2719 ENDIF
2720 ENDDO
2721 100 DO l=1,ndof(n1)
2722c#include "lockon.inc"
2723 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l,ep)
2724c#include "lockoff.inc"
2725 ENDDO
2726 ENDDO
2727 ELSE
2728 DO k=1,ndof(n2)
2729 DO jj = iadk(id+k),iadk(id+1+k)-1
2730 IF (jdik(jj)==jd) THEN
2731 jdl = jj-1
2732 GOTO 200
2733 ENDIF
2734 ENDDO
2735 200 DO l=1,ndof(n2)
2736c#include "lockon.inc"
2737 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k,ep)
2738c#include "lockoff.inc"
2739 ENDDO
2740 ENDDO
2741 ENDIF
2742 ENDIF
2743 ENDDO
2744 ELSE
2745 DO ep = 1,nel
2746 IF (off(ep)>zero.AND.ni(ep)/=nj(ep).AND.
2747 . ni(ep)>0.AND.nj(ep)>0) THEN
2748 n1=ni(ep)
2749 n2=nj(ep)
2750 i = iddl(n1)
2751 j = iddl(n2)
2752 id = max(i,j)
2753 jd = min(i,j)+1
2754 IF (i==id) THEN
2755 DO k=1,ndof(n1)
2756 DO jj = iadk(id+k),iadk(id+1+k)-1
2757C---------find l'adress dans LT-----
2758 IF (jdik(jj)==jd) THEN
2759 jdl = jj-1
2760 GOTO 300
2761 ENDIF
2762 ENDDO
2763 300 DO l=1,ndof(n1)
2764c#include "lockon.inc"
2765 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l,ep)
2766c#include "lockoff.inc"
2767 ENDDO
2768 ENDDO
2769 ELSE
2770 DO k=1,ndof(n2)
2771 DO jj = iadk(id+k),iadk(id+1+k)-1
2772 IF (jdik(jj)==jd) THEN
2773 jdl = jj-1
2774 GOTO 400
2775 ENDIF
2776 ENDDO
2777 400 DO l=1,ndof(n2)
2778c#include "lockon.inc"
2779 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k,ep)
2780c#include "lockoff.inc"
2781 ENDDO
2782 ENDDO
2783 ENDIF
2784 ENDIF
2785 ENDDO
2786 ENDIF
2787#include "lockoff.inc"
2788C
2789C----6---------------------------------------------------------------7---------8
2790 RETURN
assemc_kii
subroutine assemc_kii(ni, nel, iddl, iadk, k_diag, k_lt, kii, nd, off, ndof)
Definition imp_glob_k.F:2581

◆ eleoff()

subroutine eleoff ( integer jft,
integer jlt,
integer, dimension(nix,*) ix,
integer nix,
integer nn,
integer, dimension(*) etag,
off )

Definition at line 1919 of file imp_glob_k.F.

1920C-----------------------------------------------
1921C I m p l i c i t T y p e s
1922C-----------------------------------------------
1923#include "implicit_f.inc"
1924C-----------------------------------------------
1925C C o m m o n B l o c k s
1926C-----------------------------------------------
1927C-----------------------------------------------------------------
1928C D u m m y A r g u m e n t s
1929C-----------------------------------------------
1930 INTEGER NIX
1931 INTEGER JFT, JLT, IX(NIX,*), ETAG(*),NN
1932 my_real
1933 . off(*)
1934C-----------------------------------------------
1935C L o c a l V a r i a b l e s
1936C-----------------------------------------------
1937 INTEGER I, J ,N,N1,NALL,IUN
1938C
1939 iun = 1
1940 DO i=jft,jlt
1941 n1=ix(2,i)
1942 nall=etag(n1)
1943 DO j=3,nn+1
1944 n=ix(j,i)
1945 nall=nall*etag(n)
1946 ENDDO
1947 nall=min(nall,iun)
1948 off(i)=nall
1949 ENDDO
1950C
1951 RETURN

◆ get_kii()

subroutine get_kii ( integer ni,
integer, dimension(*) iddl,
integer, dimension(*) iadk,
k_diag,
k_lt,
kii,
integer nd )

Definition at line 590 of file imp_glob_k.F.

591C-----------------------------------------------
592C I m p l i c i t T y p e s
593C-----------------------------------------------
594#include "implicit_f.inc"
595C-----------------------------------------------
596C C o m m o n B l o c k s
597C-----------------------------------------------
598#include "impl1_c.inc"
599C-----------------------------------------------
600C D u m m y A r g u m e n t s
601C-----------------------------------------------
602 INTEGER ND
603 INTEGER NI,IDDL(*) ,IADK(*)
604C REAL
605 my_real
606 . k_diag(*) ,k_lt(*) ,kii(6,6)
607C-----------------------------------------------
608C L o c a l V a r i a b l e s
609C-----------------------------------------------
610 INTEGER K,IK,ID,JD,L
611C----6----------KII is always triag_sup whatever IKPAT------------------------
612 id = iddl(ni)
613 IF (ikpat==0) THEN
614 DO k=1,nd
615 kii(k,k) = k_diag(id+k)
616 jd = iadk(id+k)-1
617 DO l=k+1,nd
618 ik = jd+l-k
619 kii(k,l) = k_lt(ik)
620 ENDDO
621 ENDDO
622 ELSE
623 DO k=1,nd
624 kii(k,k) = k_diag(id+k)
625 jd = iadk(id+k+1)-k
626 DO l=1,k-1
627 ik = jd+l
628 kii(l,k) = k_lt(ik)
629 ENDDO
630 ENDDO
631 ENDIF
632C
633 RETURN

◆ get_kij()

subroutine get_kij ( integer ni,
integer nj,
integer, dimension(*) iddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
k_lt,
kij,
integer nk,
integer nl,
integer ierr )

Definition at line 711 of file imp_glob_k.F.

713C----6---------------------------------------------------------------7---------8
714C I m p l i c i t T y p e s
715C-----------------------------------------------
716#include "implicit_f.inc"
717C-----------------------------------------------
718C C o m m o n B l o c k s
719C-----------------------------------------------
720#include "impl1_c.inc"
721C-----------------------------------------------
722C D u m m y A r g u m e n t s
723C-----------------------------------------------
724 INTEGER NK,NL , IERR
725 INTEGER NI,NJ,IDDL(*) ,IADK(*),JDIK(*)
726C REAL
727 my_real
728 . k_lt(*) ,kij(6,6)
729C-----------------------------------------------
730C L o c a l V a r i a b l e s
731C-----------------------------------------------
732 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ
733C----6---------------------------------------------------------------7---------8
734 ierr = 0
735 i = iddl(ni)
736 j = iddl(nj)
737 IF (ikpat==0) THEN
738 id = min(i,j)
739 jd = max(i,j)+1
740 ELSE
741 id = max(i,j)
742 jd = min(i,j)+1
743 ENDIF
744 jdl=0
745 IF (i==id) THEN
746 DO k=1,nk
747 DO jj = iadk(id+k),iadk(id+1+k)-1
748C---------find l'adress dans LT-----
749 IF (jdik(jj)==jd) THEN
750 jdl = jj-1
751 GOTO 100
752 ENDIF
753 ENDDO
754 IF (jdl==0) THEN
755 ierr = 1
756 DO i=1,nk
757 DO j=1,nl
758 kij(i,j)=zero
759 ENDDO
760 ENDDO
761 RETURN
762 ENDIF
763 100 DO l=1,nl
764 kij(k,l)=k_lt(jdl+l)
765 ENDDO
766 ENDDO
767 ELSE
768 DO k=1,nl
769 DO jj = iadk(id+k),iadk(id+1+k)-1
770 IF (jdik(jj)==jd) THEN
771 jdl = jj-1
772 GOTO 200
773 ENDIF
774 ENDDO
775 IF (jdl==0) THEN
776 ierr = 1
777 DO i=1,nk
778 DO j=1,nl
779 kij(i,j)=zero
780 ENDDO
781 ENDDO
782 RETURN
783 ENDIF
784 200 DO l=1,nk
785 kij(l,k)=k_lt(jdl+l)
786 ENDDO
787 ENDDO
788 ENDIF
789C
790C----6---------------------------------------------------------------7---------8
791 RETURN
nl
character *2 function nl()
Definition message.F:2354

◆ grpreorder()

subroutine grpreorder ( integer, dimension(nparg,*) iparg,
integer, dimension(*) igrouc )

Definition at line 2800 of file imp_glob_k.F.

2801C----6---------------------------------------------------------------7---------8
2802C I m p l i c i t T y p e s
2803C-----------------------------------------------
2804#include "implicit_f.inc"
2805C-----------------------------------------------
2806C C o m m o n B l o c k s
2807C-----------------------------------------------
2808#include "com01_c.inc"
2809#include "param_c.inc"
2810C-----------------------------------------------------------------
2811C D u m m y A r g u m e n t s
2812C-----------------------------------------------
2813 INTEGER IPARG(NPARG,*),IGROUC(*)
2814C-----------------------------------------------
2815C L o c a l V a r i a b l e s
2816C-----------------------------------------------
2817 INTEGER NG, ITY, NGROUC
2818C-----------------------------------------------
2819C-------------first shell+ other
2820 ngrouc = 0
2821 DO ng = 1, ngroup
2822 ity =iparg(5,ng)
2823 IF(ity==3.OR.ity==7)THEN
2824 ngrouc = ngrouc + 1
2825 igrouc(ngrouc)=ng
2826 END IF
2827 END DO
2828 DO ng = 1, ngroup
2829 ity =iparg(5,ng)
2830 IF(ity==3.OR.ity==7)THEN
2831 ELSE
2832 ngrouc = ngrouc + 1
2833 igrouc(ngrouc)=ng
2834 END IF
2835 END DO
2836C
2837 RETURN

◆ imp_glob_k()

subroutine imp_glob_k ( pm,
geo,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
elbuf,
integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(4,*) ixtg1,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
integer, dimension(nparg,*) iparg,
tf,
integer, dimension(*) npc,
fr_wave,
w16,
bufmat,
thke,
bufgeo,
rby,
skew,
x,
wa,
integer, dimension(*) iddl,
integer, dimension(*) ndof,
k_diag,
k_lt,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
integer ikgeo,
integer, dimension(*) etag,
type (elbuf_struct_), dimension(ngroup) elbuf_tab,
type (stack_ply) stack,
type (drape_), dimension(numelc_drape) drape_sh4n,
type (drape_), dimension(numeltg_drape) drape_sh3n,
type (drapeg_) drapeg )

Definition at line 52 of file imp_glob_k.F.

62C-----------------------------------------------
63C M o d u l e s
64C-----------------------------------------------
65 USE initbuf_mod
66 USE elbufdef_mod
67 USE stack_mod
68 USE drape_mod
69C----6---------------------------------------------------------------7---------8
70C I m p l i c i t T y p e s
71C-----------------------------------------------
72#include "implicit_f.inc"
73#include "comlock.inc"
74C-----------------------------------------------
75C G l o b a l P a r a m e t e r s
76C-----------------------------------------------
77#include "mvsiz_p.inc"
78C-----------------------------------------------
79C C o m m o n B l o c k s
80C-----------------------------------------------
81#include "com01_c.inc"
82#include "com04_c.inc"
83#include "param_c.inc"
84#include "vect01_c.inc"
85#include "scr14_c.inc"
86#include "task_c.inc"
87#include "units_c.inc"
88#include "impl1_c.inc"
89C-----------------------------------------------------------------
90C D u m m y A r g u m e n t s
91C-----------------------------------------------
92 INTEGER IDDL(*) ,NDOF(*) ,IADK(*) ,JDIK(*) ,
93 . IPM(NPROPMI,*),IGEO(NPROPGI,*),IKGEO
94 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
95 . IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*),
96 . NPC(*), IPARG(NPARG,*),
97 . IXS10(6,*),IXS20(12,*),IXS16(8,*),IXTG1(4,*), ETAG(*)
98C REAL
99 my_real
100 . pm(npropm,*),geo(npropg,*),bufmat(*) ,tf(*) ,
101 . fr_wave(*) ,elbuf(*) ,thke(*),rby(*),skew(lskew,*),
102 . bufgeo(*),w16(*),x(3,*),wa(*)
103 my_real
104 . k_diag(*) ,k_lt(*)
105 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
106 TYPE (STACK_PLY) :: STACK
107 TYPE (DRAPE_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
108 TYPE (DRAPEG_) :: DRAPEG
109C-----------------------------------------------
110C L o c a l V a r i a b l e s
111C-----------------------------------------------
112 INTEGER I,N, NG, NVC, MLW, JFT, JLT,ISOLNOD,ITHK ,IPLA ,
113 . K1, K2, KAD,IAD2,NF1,IPRI, NELEM, OFFSET, NSGRP, K,
114 . K0, K3, K5, K6, K7, K8, K9, NSG, NEL, KFTS,IOFC, ISTRA,
115 . JJ19,NPE,NIPMAX,ICNOD,NFT1,NF2,MPT,
116 . L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,
117 . L17,L18,L19,L20,L21,L22,L23,L24,L25,L26,L27,L28,L29,L30,
118 . SEDRAPE,NUMEL_DRAPE
119 INTEGER INDXOF(MVSIZ),ISH3N,IPRMES_EL(50)
120 INTEGER ICP,ICS,IEXPAN,IETY,IG,ISUBSTACK
121 SAVE
122 . iprmes_el
123 my_real
124 . off(mvsiz)
125C----6---------------------------------------------------------------7-2
126 DO ng = 1, ngroup
127c NG = IGROUC(IG)
128c IF(NGDONE>NGROUP) GOTO 250
129c NGDONE = NG + 1
130C
131 IF(iparg(8,ng)==1)GOTO 250
132 IF (iddw>0) CALL startimeg(ng)
133 IF (ng==1) THEN
134 DO i=1,50
135 iprmes_el(i)=0
136 ENDDO
137 END IF !(NG==1) THEN
138 ity =iparg(5,ng)
139 offset = 0
140 mlw = iparg(1,ng)
141 IF (mlw == 0 .OR. mlw == 13) GOTO 250
142 CALL initbuf(iparg ,ng ,
143 2 mlw ,nel ,nft ,kad ,ity ,
144 3 npt ,jale ,ismstr ,jeul ,jtur ,
145 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
146 5 nvaux ,jpor ,jcvt ,jclose ,ipla ,
147 6 irep ,iint ,igtyp ,israt ,isrot ,
148 7 icsen ,isorth ,isorthg ,ifailure,jsms )
149c
150 icnod = iparg(11,ng)
151 nsg = iparg(10,ng)
152 icp = iparg(10,ng)
153 ics = iparg(17,ng)
154 istra = iparg(44,ng)
155 nvc = iparg(19,ng)
156 ithk = iparg(28,ng)
157 isolnod = iparg(28,ng)
158 kfts = iparg(30,ng)
159 iexpan = iparg(49,ng)
160 ish3n = iparg(23,ng)
161 isubstack=iparg(71,ng)
162 IF(ity==1.OR.ity==2) jplasol=ipla
163 iformdt = 0
164 lft = 1
165 llt = min(nvsiz,nel)
166 mtn = mlw
167 jft=lft
168 jlt=llt
169 nf1 = nft+1
170 iad = kad
171C
172 jsph=0
173C----6---------------------------------------------------------------7---------8
174 IF(ity==1 .AND. jlag==1)THEN
175 igtyp = nint(geo(12,ixs(10,nf1)))
176 IF(isolnod==4)THEN
177 iety=1
178 IF (isrot > 0 .AND. ispmd==0) THEN
179 IF (iprmes_el(iety)==0) THEN
180 WRITE(iout,1005)isrot
181 iprmes_el(iety)=1
182 ENDIF
183 ENDIF
184 CALL s4ke3(
185 1 pm, geo, ixs, x,
186 2 elbuf_tab(ng)%GBUF, etag, iddl,
187 3 ndof, k_diag, k_lt, iadk,
188 4 jdik, nel, ipm, igeo,
189 5 ikgeo, bufmat, nft, mtn,
190 6 ismstr, jhbe, irep, isorth,
191 7 iformdt)
192
193 ELSEIF(isolnod==10)THEN
194 CALL s10ke3(
195 1 pm, geo, ixs, ixs10,
196 2 x, elbuf_tab(ng),etag, iddl,
197 3 ndof, k_diag, k_lt, iadk,
198 4 jdik, nel, ipm, igeo,
199 5 ikgeo, bufmat, nft, mtn,
200 6 npt, ismstr, jhbe, irep,
201 7 isorth, jlag)
202
203 ELSEIF(isolnod==20)THEN
204 CALL s20ke3(
205 1 pm, geo, ixs, ixs20,
206 2 x, elbuf_tab(ng),etag, iddl,
207 3 ndof, k_diag, k_lt, iadk,
208 4 jdik, nel, ipm, igeo,
209 5 ikgeo, bufmat, nft, mtn,
210 6 ismstr, jhbe, irep, igtyp,
211 7 isorth)
212 ELSEIF(isolnod==16)THEN
213 iety=2
214 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
215 WRITE(iout,1001)' S16 SOLID'
216 WRITE(istdo,1001)' S16 SOLID'
217 iprmes_el(iety)=1
218 ENDIF
219 ELSEIF(jhbe==15.AND.isolnod==6)THEN
220 CALL s6cke3(
221 1 pm, geo, ixs, x,
222 2 elbuf_tab(ng),etag, iddl, ndof,
223 3 k_diag, k_lt, iadk, jdik,
224 4 nel, icp, ics, ipm,
225 5 igeo, ikgeo, bufmat, nft,
226 6 mtn, jhbe, isorth, isorthg,
227 7 ismstr)
228C
229 ELSEIF(isolnod==8)THEN
230C NIPMAX = 729
231C L1 = 1
232C L2 = L1 + MVSIZ * NIPMAX
233C L3 = L2 + MVSIZ * NIPMAX
234 IF (jhbe/=14.AND.jhbe/=15.AND.jhbe/=17) THEN
235 IF (ncycle==1.AND.imconv==1)THEN
236 IF(jhbe==24)THEN
237 iety=3
238 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
239 WRITE(iout,1002)jhbe
240 iprmes_el(iety)=1
241 ENDIF
242 ELSEIF(jhbe==12.OR.jhbe==112)THEN
243 iety=4
244 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
245 WRITE(iout,1002)jhbe
246 iprmes_el(iety)=1
247 ENDIF
248 ELSEIF(jhbe==0)THEN
249 iety=5
250 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
251 WRITE(iout,1002)jhbe
252 iprmes_el(iety)=1
253 ENDIF
254 ELSE
255 iety=6
256 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
257 WRITE(iout,1002)jhbe
258 iprmes_el(iety)=1
259 ENDIF
260 ENDIF
261 ENDIF
262 ENDIF
263c
264 IF (jhbe == 14 .AND.
265 . (igtyp == 20 .OR. igtyp == 21 .OR. igtyp == 22)) THEN
266 CALL s8cke3(
267 1 pm, geo, ixs, x,
268 2 elbuf_tab(ng),nel, icp, ics,
269 3 etag, iddl, ndof, k_diag,
270 4 k_lt, iadk, jdik, ipm,
271 5 igeo, ikgeo, bufmat, nft,
272 6 mtn, jhbe, jcvt, igtyp,
273 7 isorth, irep, ismstr)
274 ELSE IF(jhbe == 17 .AND. iparg(36,ng) == 2) THEN
275 mpt = 222
276 CALL s8ske3(
277 1 pm, geo, ixs, x,
278 2 elbuf_tab(ng),nel, icp, ics,
279 3 etag, iddl, ndof, k_diag,
280 4 k_lt, iadk, jdik, mpt,
281 5 ipm, igeo, ikgeo, bufmat,
282 6 nft, mtn, jhbe, jcvt,
283 7 igtyp, isorth)
284 ELSE
285 mpt = 222
286 CALL s8zke3(
287 1 pm, geo, ixs, x,
288 2 elbuf_tab(ng),nel, icp, ics,
289 3 etag, iddl, ndof, k_diag,
290 4 k_lt, iadk, jdik, mpt,
291 5 ipm, igeo, ikgeo, bufmat,
292 6 nft, mtn, ismstr, jhbe,
293 7 jcvt, igtyp, isorth, irep)
294 ENDIF
295
296C OPEN(UNIT=16,FILE='KE_S.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
297C CALL IMPKSOUT( IXS,NFT,NEL,16,
298C 1 K11 ,K12 ,K13 ,K14 ,K15 ,
299C 2 K16 ,K17 ,K18 ,K22 ,K23 ,
300C 3 K24 ,K25 ,K26 ,K27 ,K28 ,
301C 4 K33 ,K34 ,K35 ,K36 ,K37 ,
302C 5 K38 ,K44 ,K45 ,K46 ,K47 ,
303C 6 K48 ,K55 ,K56 ,K57 ,K58 ,
304C 7 K66 ,K67 ,K68 ,K77 ,K78 ,
305C 8 K88 )
306C----6---------------------------------------------------------------7---------8
307 ELSEIF(igtyp>=29)THEN
308 iety=7
309 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
310 WRITE(iout,1001)' USERS '
311 WRITE(istdo,1001)' USERS '
312 iprmes_el(iety)=1
313 ENDIF
314C CALL SUKE3(
315 ELSEIF(npt==1)THEN
316 IF(ng/=ngroup)THEN
317 iad2 = iparg(4,ng+1) - 21 * nel
318 ELSE
319 iad2 = lbufel - 21 * nel + 1
320 ENDIF
321 IF(jhbe==24)THEN
322C---------------ca ne riske pas de entrer ici pour l'instant
323C CALL SZKE3(
324C 1 PM ,GEO ,IXS ,X ,ELBUF(KAD),
325C 1 K11 ,K12 ,K13 ,K14 ,K15 ,
326C 2 K16 ,K17 ,K18 ,K22 ,K23 ,
327C 3 K24 ,K25 ,K26 ,K27 ,K28 ,
328C 4 K33 ,K34 ,K35 ,K36 ,K37 ,
329C 5 K38 ,K44 ,K45 ,K46 ,K47 ,
330C 6 K48 ,K55 ,K56 ,K57 ,K58 ,
331C 7 K66 ,K67 ,K68 ,K77 ,K78 ,
332C 8 K88 ,NEL ,LIAD ,ICP ,ICSIG ,
333C 9 OFFSET,ELBUF(IAD2),OFF)
334 iety=8
335 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
336 WRITE(iout,1001)' HEPH SOLID'
337 WRITE(istdo,1001)' HEPH SOLID'
338 iprmes_el(iety)=1
339 ENDIF
340 ELSE
341 iety=9
342 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
343 WRITE(iout,1001)' S8 SOLID'
344 WRITE(istdo,1001)' S8 SOLID'
345 iprmes_el(iety)=1
346 ENDIF
347 ENDIF
348 ELSEIF(npt==8.AND.mtn/=0 .AND. isolnod/=20)THEN
349C CALL S8KE3(
350 iety=10
351 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
352 WRITE(iout,1001)' S8 SOLID'
353 WRITE(istdo,1001)' S8 SOLID'
354 iprmes_el(iety)=1
355 ENDIF
356 ENDIF
357C----6---------------------------------------------------------------7---------8
358 ELSEIF(ity==2.AND.jmult==0.AND.jlag==1)THEN
359 iety=11
360 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
361 WRITE(iout,1001)' QUAD 2D '
362 WRITE(istdo,1001)' QUAD 2D '
363 iprmes_el(iety)=1
364 ENDIF
365C CALL QFORC2(
366 ELSEIF(ity==3)THEN
367 iofc = 0
368 IF(ng/=ngroup)THEN
369 iad2 = iparg(4,ng+1) - 6 * nel
370 ELSE
371 iad2 = lbufel - 6 * nel + 1
372 ENDIF
373 IF (jhbe<11) THEN
374 IF (ncycle==1.AND.imconv==1) THEN
375 IF(jhbe==4)THEN
376 iety=12
377 IF (iprmes_el(iety)==0) THEN
378 WRITE(iout,1003)jhbe
379 iprmes_el(iety)=1
380 ENDIF
381 ELSEIF(jhbe==3)THEN
382 iety=13
383 IF (iprmes_el(iety)==0) THEN
384 WRITE(iout,1003)jhbe
385 iprmes_el(iety)=1
386 ENDIF
387 ELSEIF(jhbe==1)THEN
388 iety=14
389 IF (iprmes_el(iety)==0) THEN
390 WRITE(iout,1003)jhbe
391 iprmes_el(iety)=1
392 ENDIF
393 ELSE
394 iety=15
395 IF (iprmes_el(iety)==0) THEN
396 WRITE(iout,1003)jhbe
397 iprmes_el(iety)=1
398 ENDIF
399 ENDIF
400 ENDIF
401 ENDIF
402 IF(jhbe>=11.AND.jhbe<=19) THEN
403
404 numel_drape = numelc_drape
405 sedrape = scdrape
406 CALL cbake3 (
407 1 jft ,jlt ,nft ,iabs(npt) ,mlw ,
408 2 ithk ,ncycle ,
409 3 istra ,ipla ,pm ,geo ,ixc(1,nf1) ,
410 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
411 1 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
412 7 jhbe ,thke(nf1) ,ismstr ,x ,ikgeo ,
413 8 ipm ,igeo ,iexpan ,iparg(1,ng),isubstack,
414 9 stack ,drape_sh4n ,drapeg%INDX_SH4N, sedrape,numel_drape)
415 ELSE
416C
417
418 numel_drape = numelc_drape
419 sedrape = scdrape
420 CALL czke3 (
421 1 jft ,jlt ,nft ,iabs(npt) ,mlw ,
422 2 ithk ,ncycle ,
423 3 istra ,ipla ,pm ,geo ,ixc(1,nf1) ,
424 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
425 1 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
426 7 jhbe ,thke(nf1) ,ismstr ,x ,ikgeo ,
427 8 ipm ,igeo ,iexpan ,iparg(1,ng),isubstack,
428 9 stack ,drape_sh4n ,drapeg%INDX_SH4N, sedrape,numel_drape)
429CTMP ELSE
430CTMP WRITE(IOUT,1001)' Q4 SHELL'
431CTMP WRITE(ISTDO,1001)' Q4 SHELL'
432C CALL CKE3(
433 ENDIF
434c OPEN(UNIT=13,FILE='KE.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
435c CALL IMPKCOUT( IXC,NFT,NEL,13,
436c 1 KC11 ,KC12 ,KC13 ,KC14 ,KC22 ,
437c 2 KC23 ,KC24 ,KC33 ,KC34 ,KC44 )
438c CALL KELAMDA( IXC,NIXC,NFT,NEL,13,
439c 1 KC11 ,KC12 ,KC13 ,KC14 ,KC22 ,
440c 2 KC23 ,KC24 ,KC33 ,KC34 ,KC44 )
441
442C----6---------------------------------------------------------------7---------8
443 ELSEIF(ity==4)THEN
444
445 CALL tke3( jft ,jlt ,pm ,geo ,ixt(1,nf1) ,
446 2 x ,elbuf_tab(ng) ,nel ,offset ,ikgeo ,
447 3 etag , iddl ,ndof ,k_diag ,k_lt ,
448 4 iadk ,jdik )
449
450C
451C WRITE(IOUT,1001)' TRUSS '
452C WRITE(ISTDO,1001)' TRUSS '
453C----6---------------------------------------------------------------7---------8
454 ELSEIF(ity==5)THEN
455
456 CALL pke3( jft ,jlt ,nel , mtn , ismstr,
457 1 pm ,ixp(1,nf1) ,x , elbuf_tab(ng) , geo ,
458 2 offset ,ikgeo ,etag , iddl , ndof ,
459 3 k_diag ,k_lt ,iadk , jdik )
460
461
462c OPEN(UNIT=16,FILE='KE_P.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
463c CALL IMPKPOUT(NIXPL,IXP,NFT,NEL,16,KC11 ,KC12 , KC22 )
464C----6---------------------------------------------------------------7---------8
465 ELSEIF(ity==6)THEN
466 igtyp = nint(geo(12,ixr(1,nf1)))
467 k1=1 + 6*(numelc+numeltg)*iepsdot + 15*(numelt+numelp+nft)
468
469 IF (igtyp==4)THEN
470 CALL r4ke3(jft ,jlt ,nel ,mtn ,pm ,
471 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
472 2 tf ,skew ,offset,fr_wave,
473 3 ikgeo ,igeo,
474 1 etag , iddl ,ndof ,k_diag ,k_lt ,
475 2 iadk ,jdik )
476
477
478 ELSEIF (igtyp==8)THEN
479 CALL r8ke3(jft ,jlt ,nel ,mtn ,pm ,
480 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
481 2 tf ,skew ,offset,fr_wave,igeo ,
482 1 etag , iddl ,ndof ,k_diag ,k_lt ,
483 2 iadk ,jdik )
484
485 ELSEIF (igtyp==12)THEN
486 CALL r12ke3(jft ,jlt ,nel ,mtn ,pm ,
487 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
488 2 tf ,skew ,offset,fr_wave,igeo ,
489 1 etag , iddl ,ndof ,k_diag ,k_lt ,
490 2 iadk ,jdik )
491
492 ELSEIF (igtyp==13)THEN
493 CALL r13ke3(jft ,jlt ,nel ,mtn ,pm ,
494 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
495 2 tf ,skew ,offset,fr_wave,ikgeo ,igeo ,
496 1 etag , iddl ,ndof ,k_diag ,k_lt ,
497 2 iadk ,jdik )
498
499
500C OPEN(UNIT=16,FILE='KE_SP.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
501C CALL IMPKPOUT( NIXR,IXR,NFT,NEL,16,KC11 ,KC12 , KC22 )
502 ELSE
503 iety=16
504 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
505 WRITE(iout,1001)' THIS SPRING'
506 WRITE(istdo,1001)' THIS SPRING'
507 iprmes_el(iety)=1
508 ENDIF
509 ENDIF
510C----6---------------------------------------------------------------7---------8
511 ELSEIF(ity==7)THEN
512 iofc = 0
513 IF(ng/=ngroup)THEN
514 iad2 = iparg(4,ng+1) - 6 * nel
515 ELSE
516 iad2 = lbufel - 6 * nel + 1
517 ENDIF
518 nf1 = nft + 1
519 IF(icnod==6)THEN
520
521 iety=17
522 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
523 WRITE(iout,1001)' S3N6 SHELL'
524 WRITE(istdo,1001)' S3N6 SHELL'
525 iprmes_el(iety)=1
526 ENDIF
527
528 ELSE
529 IF (ish3n == 30) THEN
530 IF (ncycle==1.AND.imconv==1) THEN
531 iety=18
532 IF (iprmes_el(iety)==0.AND.ispmd==0) THEN
533 WRITE(iout,1004)ish3n
534 iprmes_el(iety)=1
535 ENDIF
536 ENDIF
537 ENDIF
538 numel_drape = numeltg_drape
539 sedrape = stdrape
540 CALL c3ke3 (
541 1 jft ,jlt ,nft ,iabs(npt),mtn ,
542 2 ithk ,ncycle ,
543 3 istra ,ipla ,pm ,geo ,ixtg(1,nf1),
544 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
545 5 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
546 6 jhbe ,thke(numelc+nf1),ismstr ,x ,
547 7 ikgeo ,ipm ,igeo ,iexpan ,iparg(1,ng),
548 8 isubstack, stack, drape_sh3n ,drapeg%INDX_SH3N,
549 9 sedrape,numel_drape)
550
551 ENDIF
552C----6---------------------------------------------------------------7---------8
553
554 ENDIF
555 250 CONTINUE
556 END DO
557C----6---------------------------------------------------------------7---------8
558 1001 FORMAT(' *****WARNING : IMPLICITE FORMULATION IS NOT AVAILABLE
559 . WITH '/,2x,a11,' ELEMENT : STIFFNESS IGNORED')
560 1002 FORMAT(' *****WARNING : ELEMENT FORMULATION ISOLID= ',
561 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'
562 . ,'USING GENERIC ONE INSTEAD, POSSIBLE CONVERGING ISSUE.')
563 1003 FORMAT(' *****WARNING : ELEMENT FORMULATION ISHELL= ',
564 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'
565 . ,'USING GENERIC ONE INSTEAD, POSSIBLE CONVERGING ISSUE.')
566 1004 FORMAT(' *****WARNING : ELEMENT FORMULATION ISH3N = ',
567 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'
568 . ,'USING GENERIC ONE INSTEAD, POSSIBLE CONVERGING ISSUE.')
569 1005 FORMAT(' *****WARNING : TETRA ELEMENT FORMULATION W/ ITETRA= ',
570 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'
571 . ,'USING ITETRA=0 INSTEAD, POSSIBLE CONVERGING ISSUE.')
572 RETURN
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:54
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:57
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:58
startimeg
subroutine startimeg(ng)
Definition timer.F:1487
drape_mod
Definition drape_mod.F:54
drape_mod::numeltg_drape
integer numeltg_drape
Definition drape_mod.F:92
drape_mod::scdrape
integer scdrape
Definition drape_mod.F:92
drape_mod::stdrape
integer stdrape
Definition drape_mod.F:92
drape_mod::numelc_drape
integer numelc_drape
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:72
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:43
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:42
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:43
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:44
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:43
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:51
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:51
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:50
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:50
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:54
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:47
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:54
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:42

◆ imp_glob_k0()

subroutine imp_glob_k0 ( pm,
geo,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
elbuf,
integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(4,*) ixtg1,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
integer, dimension(nparg,*) iparg,
tf,
integer, dimension(*) npc,
fr_wave,
w16,
bufmat,
thke,
bufgeo,
rby,
skew,
x,
wa,
integer, dimension(*) iddl,
integer, dimension(*) ndof,
k_diag,
k_lt,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
integer ikgeo,
integer, dimension(*) etag,
integer itask,
type (elbuf_struct_), dimension(ngroup) elbuf_tab,
integer, dimension(ngroup) igrouc,
integer, dimension(*) iprmes_el,
type (stack_ply) stack,
type (drape_), dimension(numelc_drape) drape_sh4n,
type (drape_), dimension(numeltg_drape) drape_sh3n,
type (drapeg_) drapeg )

Definition at line 3063 of file imp_glob_k.F.

3074C-----------------------------------------------
3075C M o d u l e s
3076C-----------------------------------------------
3077 USE initbuf_mod
3078 USE elbufdef_mod
3079 USE stack_mod
3080 USE drape_mod
3081C----6---------------------------------------------------------------7---------8
3082C I m p l i c i t T y p e s
3083C-----------------------------------------------
3084#include "implicit_f.inc"
3085#include "comlock.inc"
3086C-----------------------------------------------
3087C G l o b a l P a r a m e t e r s
3088C-----------------------------------------------
3089#include "mvsiz_p.inc"
3090C-----------------------------------------------
3091C C o m m o n B l o c k s
3092C-----------------------------------------------
3093#include "com01_c.inc"
3094#include "com04_c.inc"
3095#include "param_c.inc"
3096#include "vect01_c.inc"
3097#include "scr14_c.inc"
3098#include "task_c.inc"
3099#include "impl1_c.inc"
3100C-----------------------------------------------------------------
3101C D u m m y A r g u m e n t s
3102C-----------------------------------------------
3103 INTEGER IDDL(*) ,NDOF(*) ,IADK(*) ,JDIK(*) ,
3104 . IPM(NPROPMI,*),IGEO(NPROPGI,*),IKGEO,ITASK,IGROUC(NGROUP)
3105 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
3106 . IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*),
3107 . NPC(*), IPARG(NPARG,*),
3108 . IXS10(6,*),IXS20(12,*),IXS16(8,*),IXTG1(4,*), ETAG(*),
3109 . IPRMES_EL(*)
3110C REAL
3111 my_real
3112 . pm(npropm,*),geo(npropg,*),bufmat(*) ,tf(*) ,
3113 . fr_wave(*) ,elbuf(*) ,thke(*),rby(*),skew(lskew,*),
3114 . bufgeo(*),w16(*),x(3,*),wa(*)
3115 my_real
3116 . k_diag(*) ,k_lt(*)
3117 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
3118 TYPE (STACK_PLY) :: STACK
3119 TYPE (DRAPE_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
3120 TYPE (DRAPEG_) :: DRAPEG
3121C-----------------------------------------------
3122C L o c a l V a r i a b l e s
3123C-----------------------------------------------
3124 INTEGER I,N, NG, NVC, MLW, JFT, JLT,ISOLNOD,ITHK ,IPLA ,
3125 . K1, K2, KAD,IAD2,NF1,IPRI, NELEM, OFFSET, NSGRP, K,
3126 . K0, K3, K5, K6, K7, K8, K9, NSG, NEL, KFTS,IOFC, ISTRA,
3127 . JJ19,NPE,NIPMAX,ICNOD,NFT1,LIAD,INPT,NF2,MPT,
3128 . L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,
3129 . L17,L18,L19,L20,L21,L22,L23,L24,L25,L26,L27,L28,L29,L30,
3130 . SEDRAPE, NUMEL_DRAPE
3131 INTEGER INDXOF(MVSIZ),ISH3N
3132 INTEGER ICP,ICS,IEXPAN,IETY,IG,ISUBSTACK
3133 my_real
3134 . off(mvsiz)
3135C----6---------------------------------------------------------------7-2
3136C Boucle parallele dynamique SMP
3137C
3138!$OMP DO SCHEDULE(DYNAMIC,1)
3139 DO ig = 1, ngroup
3140 ng = igrouc(ig)
3141C---------temporarily used to avoid pass KTBUF_STR everywhere
3142 ng_imp = ng
3143c IF(NGDONE>NGROUP) GOTO 250
3144c NGDONE = NG + 1
3145C
3146 IF(iparg(8,ng)==1)GOTO 250
3147 IF (iddw>0) CALL startimeg(ng)
3148 ity =iparg(5,ng)
3149 offset = 0
3150 mlw = iparg(1,ng)
3151C
3152 IF (mlw == 0 .OR. mlw == 13) GOTO 250
3153 CALL initbuf(iparg ,ng ,
3154 2 mlw ,nel ,nft ,kad ,ity ,
3155 3 npt ,jale ,ismstr ,jeul ,jtur ,
3156 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
3157 5 nvaux ,jpor ,jcvt ,jclose ,ipla ,
3158 6 irep ,iint ,igtyp ,israt ,isrot ,
3159 7 icsen ,isorth ,isorthg ,ifailure,jsms )
3160 icnod = iparg(11,ng)
3161 nsg = iparg(10,ng)
3162 icp = iparg(10,ng)
3163 ics = iparg(17,ng)
3164 istra = iparg(44,ng)
3165 nvc = iparg(19,ng)
3166 ithk = iparg(28,ng)
3167 isolnod = iparg(28,ng)
3168 kfts = iparg(30,ng)
3169 iexpan = iparg(49,ng)
3170 ish3n = iparg(23,ng)
3171 isubstack=iparg(71,ng)
3172 IF(ity==1) THEN
3173 liad = nvaux
3174 ENDIF
3175 IF(ity==1.OR.ity==2) jplasol=ipla
3176 iformdt = 0
3177 lft = 1
3178 llt = min(nvsiz,nel)
3179 mtn = mlw
3180 jft=lft
3181 jlt=llt
3182 nf1 = nft+1
3183 iad = kad
3184C
3185 jsph=0
3186C----6---------------------------------------------------------------7---------8
3187 IF(ity==1 .AND. jlag==1)THEN
3188 igtyp = nint(geo(12,ixs(10,nf1)))
3189 IF(isolnod==4)THEN
3190 iety=1
3191 IF (isrot > 0 .AND. ispmd==0) THEN
3192 IF (iprmes_el(iety)==0) THEN
3193 iprmes_el(iety)=1
3194 ENDIF
3195 ENDIF
3196 CALL s4ke3(
3197 1 pm, geo, ixs, x,
3198 2 elbuf_tab(ng)%GBUF, etag, iddl,
3199 3 ndof, k_diag, k_lt, iadk,
3200 4 jdik, nel, ipm, igeo,
3201 5 ikgeo, bufmat, nft, mtn,
3202 6 ismstr, jhbe, irep, isorth,
3203 7 iformdt)
3204 ELSEIF(isolnod==10)THEN
3205 nf2=nf1-numels8
3206 CALL s10ke3(
3207 1 pm, geo, ixs, ixs10,
3208 2 x, elbuf_tab(ng),etag, iddl,
3209 3 ndof, k_diag, k_lt, iadk,
3210 4 jdik, nel, ipm, igeo,
3211 5 ikgeo, bufmat, nft, mtn,
3212 6 npt, ismstr, jhbe, irep,
3213 7 isorth, jlag)
3214
3215 ELSEIF(isolnod==20)THEN
3216 CALL s20ke3(
3217 1 pm, geo, ixs, ixs20,
3218 2 x, elbuf_tab(ng),etag, iddl,
3219 3 ndof, k_diag, k_lt, iadk,
3220 4 jdik, nel, ipm, igeo,
3221 5 ikgeo, bufmat, nft, mtn,
3222 6 ismstr, jhbe, irep, igtyp,
3223 7 isorth)
3224
3225
3226 ELSEIF(isolnod==16)THEN
3227 iety=2
3228 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3229 ELSEIF(jhbe==15.AND.isolnod==6)THEN
3230 CALL s6cke3(
3231 1 pm, geo, ixs, x,
3232 2 elbuf_tab(ng),etag, iddl, ndof,
3233 3 k_diag, k_lt, iadk, jdik,
3234 4 nel, icp, ics, ipm,
3235 5 igeo, ikgeo, bufmat, nft,
3236 6 mtn, jhbe, isorth, isorthg,
3237 7 ismstr)
3238C
3239 ELSEIF(isolnod==8)THEN
3240 IF (jhbe/=14.AND.jhbe/=15.AND.jhbe/=17) THEN
3241 IF (ncycle==1.AND.imconv==1)THEN
3242 IF(jhbe==24)THEN
3243 iety=3
3244 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3245 ELSEIF(jhbe==12.OR.jhbe==112)THEN
3246 iety=4
3247 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3248 ELSEIF(jhbe==0)THEN
3249 iety=5
3250 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3251 ELSE
3252 iety=6
3253 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=jhbe
3254 ENDIF
3255 ENDIF
3256 ENDIF
3257c
3258 IF (jhbe == 14 .AND.
3259 . (igtyp == 20 .OR. igtyp == 21 .OR. igtyp == 22)) THEN
3260 CALL s8cke3(
3261 1 pm, geo, ixs, x,
3262 2 elbuf_tab(ng),nel, icp, ics,
3263 3 etag, iddl, ndof, k_diag,
3264 4 k_lt, iadk, jdik, ipm,
3265 5 igeo, ikgeo, bufmat, nft,
3266 6 mtn, jhbe, jcvt, igtyp,
3267 7 isorth, irep, ismstr)
3268 ELSE IF(jhbe == 17 .AND. iparg(36,ng) == 3) THEN
3269 mpt = 222
3270 CALL s8ske3(
3271 1 pm, geo, ixs, x,
3272 2 elbuf_tab(ng),nel, icp, ics,
3273 3 etag, iddl, ndof, k_diag,
3274 4 k_lt, iadk, jdik, mpt,
3275 5 ipm, igeo, ikgeo, bufmat,
3276 6 nft, mtn, jhbe, jcvt,
3277 7 igtyp, isorth)
3278 ELSE
3279 mpt = 222
3280 CALL s8zke3(
3281 1 pm, geo, ixs, x,
3282 2 elbuf_tab(ng),nel, icp, ics,
3283 3 etag, iddl, ndof, k_diag,
3284 4 k_lt, iadk, jdik, mpt,
3285 5 ipm, igeo, ikgeo, bufmat,
3286 6 nft, mtn, ismstr, jhbe,
3287 7 jcvt, igtyp, isorth, irep)
3288 ENDIF
3289c
3290C OPEN(UNIT=16,FILE='KE_S.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
3291C CALL IMPKSOUT( IXS,NFT,NEL,16,
3292C 1 K11 ,K12 ,K13 ,K14 ,K15 ,
3293C 2 K16 ,K17 ,K18 ,K22 ,K23 ,
3294C 3 K24 ,K25 ,K26 ,K27 ,K28 ,
3295C 4 K33 ,K34 ,K35 ,K36 ,K37 ,
3296C 5 K38 ,K44 ,K45 ,K46 ,K47 ,
3297C 6 K48 ,K55 ,K56 ,K57 ,K58 ,
3298C 7 K66 ,K67 ,K68 ,K77 ,K78 ,
3299C 8 K88 )
3300C----6---------------------------------------------------------------7---------8
3301 ELSEIF(igtyp>=29)THEN
3302 iety=7
3303 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3304C CALL SUKE3(
3305 ELSEIF(npt==1)THEN
3306 IF(jhbe==24)THEN
3307C---------------ca ne riske pas de entrer ici pour l'instant
3308C CALL SZKE3(
3309C 1 PM ,GEO ,IXS ,X ,ELBUF(KAD),
3310C 1 K11 ,K12 ,K13 ,K14 ,K15 ,
3311C 2 K16 ,K17 ,K18 ,K22 ,K23 ,
3312C 3 K24 ,K25 ,K26 ,K27 ,K28 ,
3313C 4 K33 ,K34 ,K35 ,K36 ,K37 ,
3314C 5 K38 ,K44 ,K45 ,K46 ,K47 ,
3315C 6 K48 ,K55 ,K56 ,K57 ,K58 ,
3316C 7 K66 ,K67 ,K68 ,K77 ,K78 ,
3317C 8 K88 ,NEL ,LIAD ,ICP ,ICSIG ,
3318C 9 OFFSET,ELBUF(IAD2),OFF)
3319 iety=8
3320 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3321 ELSE
3322 iety=9
3323 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3324 ENDIF
3325 ELSEIF(npt==8.AND.mtn/=0 .AND. isolnod/=20)THEN
3326C CALL S8KE3(
3327 iety=10
3328 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3329 ENDIF
3330C----6---------------------------------------------------------------7---------8
3331 ELSEIF(ity==2.AND.jmult==0.AND.jlag==1)THEN
3332 IF ((n2d==2.AND.jhbe==17) .OR.
3333 . (n2d==1.AND.jhbe==22)) THEN
3334 inpt = iabs(npt)
3335 icp = iparg(10,ng)
3336 CALL q4ke2(
3337 1 pm, geo, ixq, x,
3338 2 elbuf_tab(ng),nel, liad, icp,
3339 3 ics, etag, iddl, ndof,
3340 4 k_diag, k_lt, iadk, jdik,
3341 5 inpt, ipm, igeo, ikgeo,
3342 6 bufmat, nft, mtn, jmult,
3343 7 jhbe, jcvt, igtyp, isorth,
3344 8 ismstr)
3345 ELSE
3346 iety=11
3347 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3348C CALL QFORC2(
3349 ENDIF
3350C----6---------------------------------------------------------------7---------8
3351 ELSEIF(ity==3)THEN
3352 iofc = 0
3353 IF(ng/=ngroup)THEN
3354 iad2 = iparg(4,ng+1) - 6 * nel
3355 ELSE
3356 iad2 = lbufel - 6 * nel + 1
3357 ENDIF
3358 IF (jhbe<11) THEN
3359 IF (ncycle==1.AND.imconv==1) THEN
3360 IF(jhbe==4)THEN
3361 iety=12
3362 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3363 ELSEIF(jhbe==3)THEN
3364 iety=13
3365 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3366 ELSEIF(jhbe==1)THEN
3367 iety=14
3368 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3369 ELSE
3370 iety=15
3371 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=jhbe
3372 ENDIF
3373 ENDIF
3374 ENDIF
3375
3376 IF(jhbe>=11.AND.jhbe<=19) THEN
3377 numel_drape = numelc_drape
3378 sedrape = scdrape
3379 CALL cbake3 (
3380 1 jft ,jlt ,nft ,iabs(npt) ,mlw ,
3381 2 ithk ,ncycle ,
3382 3 istra ,ipla ,pm ,geo ,ixc(1,nf1) ,
3383 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
3384 1 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
3385 7 jhbe ,thke(nf1) ,ismstr ,x ,ikgeo ,
3386 8 ipm ,igeo ,iexpan ,iparg(1,ng),isubstack ,
3387 9 stack ,drape_sh4n ,drapeg%INDX_SH4N, sedrape, numel_drape)
3388 ELSE
3389C
3390
3391 numel_drape = numelc_drape
3392 sedrape = scdrape
3393 CALL czke3 (
3394 1 jft ,jlt ,nft ,iabs(npt) ,mlw ,
3395 2 ithk ,ncycle ,
3396 3 istra ,ipla ,pm ,geo ,ixc(1,nf1) ,
3397 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
3398 1 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
3399 7 jhbe ,thke(nf1) ,ismstr ,x ,ikgeo ,
3400 8 ipm ,igeo ,iexpan ,iparg(1,ng),isubstack ,
3401 9 stack ,drape_sh4n ,drapeg%INDX_SH4N , sedrape, numel_drape)
3402C CALL CKE3(
3403 ENDIF
3404c OPEN(UNIT=13,FILE='KE.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
3405c CALL IMPKCOUT( IXC,NFT,NEL,13,
3406c 1 KC11 ,KC12 ,KC13 ,KC14 ,KC22 ,
3407c 2 KC23 ,KC24 ,KC33 ,KC34 ,KC44 )
3408c CALL KELAMDA( IXC,NIXC,NFT,NEL,13,
3409c 1 KC11 ,KC12 ,KC13 ,KC14 ,KC22 ,
3410c 2 KC23 ,KC24 ,KC33 ,KC34 ,KC44 )
3411
3412C----6---------------------------------------------------------------7---------8
3413 ELSEIF(ity==4)THEN
3414 CALL tke3(
3415 1 jft ,jlt ,pm ,geo ,ixt(1,nf1) ,
3416 2 x ,elbuf_tab(ng) ,nel ,offset ,ikgeo,
3417 3 etag , iddl ,ndof ,k_diag ,k_lt ,
3418 4 iadk ,jdik )
3419
3420
3421C----6---------------------------------------------------------------7---------8
3422 ELSEIF(ity==5)THEN
3423 CALL pke3(jft ,jlt ,nel ,mtn ,ismstr,
3424 1 pm ,ixp(1,nf1),x ,elbuf_tab(ng),
3425 2 geo ,offset , ikgeo,
3426 3 etag , iddl ,ndof ,k_diag ,k_lt ,
3427 4 iadk ,jdik )
3428
3429
3430c OPEN(UNIT=16,FILE='KE_P.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
3431c CALL IMPKPOUT(NIXPL,IXP,NFT,NEL,16,KC11 ,KC12 , KC22 )
3432C----6---------------------------------------------------------------7---------8
3433 ELSEIF(ity==6)THEN
3434 igtyp = nint(geo(12,ixr(1,nf1)))
3435 k1=1 + 6*(numelc+numeltg)*iepsdot + 15*(numelt+numelp+nft)
3436 IF (igtyp==4)THEN
3437 CALL r4ke3 (jft ,jlt ,nel ,mtn ,pm ,
3438 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3439 2 tf ,skew ,offset,fr_wave,
3440 3 ikgeo ,igeo,
3441 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3442 2 iadk ,jdik )
3443
3444 ELSEIF (igtyp==32)THEN
3445 CALL ruser32ke3 (jft ,jlt ,nel ,mtn ,pm ,
3446 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3447 2 tf ,skew ,offset,fr_wave,
3448 3 ikgeo ,igeo,
3449 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3450 2 iadk ,jdik )
3451
3452 ELSEIF (igtyp==8)THEN
3453 CALL r8ke3(jft ,jlt ,nel ,mtn ,pm ,
3454 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3455 2 tf ,skew ,offset,fr_wave,igeo ,
3456 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3457 2 iadk ,jdik )
3458
3459 ELSEIF (igtyp==12)THEN
3460 CALL r12ke3(jft ,jlt ,nel ,mtn ,pm ,
3461 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3462 2 tf ,skew ,offset,fr_wave,igeo ,
3463 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3464 2 iadk ,jdik )
3465
3466 ELSEIF (igtyp==13)THEN
3467 CALL r13ke3 (jft ,jlt ,nel ,mtn ,pm ,
3468 1 geo ,ixr(1,nf1),x ,elbuf_tab(ng),npc ,
3469 2 tf ,skew ,offset,fr_wave,ikgeo ,igeo ,
3470 1 etag , iddl ,ndof ,k_diag ,k_lt ,
3471 2 iadk ,jdik )
3472
3473
3474C OPEN(UNIT=16,FILE='KE_SP.TMP',STATUS='UNKNOWN',FORM='FORMATTED')
3475C CALL IMPKPOUT( NIXR,IXR,NFT,NEL,16,KC11 ,KC12 , KC22 )
3476 ELSE
3477 iety=16
3478 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=igtyp
3479 ENDIF
3480C----6---------------------------------------------------------------7---------8
3481 ELSEIF(ity==7)THEN
3482 iofc = 0
3483 IF(ng/=ngroup)THEN
3484 iad2 = iparg(4,ng+1) - 6 * nel
3485 ELSE
3486 iad2 = lbufel - 6 * nel + 1
3487 ENDIF
3488 nf1 = nft + 1
3489 IF(icnod==6)THEN
3490 iety=17
3491 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3492 ELSE
3493 IF (ish3n >= 30) THEN
3494 iety=18
3495 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=ish3n
3496 ENDIF
3497 numel_drape = numeltg_drape
3498 sedrape = stdrape
3499 CALL c3ke3 (
3500 1 jft ,jlt ,nft ,iabs(npt),mtn ,
3501 2 ithk ,ncycle ,
3502 3 istra ,ipla ,pm ,geo ,ixtg(1,nf1),
3503 4 elbuf_tab(ng),bufmat ,offset ,indxof ,
3504 5 etag , iddl ,ndof ,k_diag ,k_lt , iadk ,jdik ,
3505 6 jhbe ,thke(numelc+nf1),ismstr ,x ,
3506 7 ikgeo ,ipm ,igeo ,iexpan ,iparg(1,ng),
3507 8 isubstack , stack , drape_sh3n, drapeg%INDX_SH3N,
3508 9 sedrape, numel_drape )
3509
3510 ENDIF
3511C----6---------------------------------------------------------------7---------8
3512 ELSEIF(ity==50)THEN
3513 iety=19
3514 IF (iprmes_el(iety) == 0 ) iprmes_el(iety)=1
3515 ENDIF
3516 250 CONTINUE
3517 END DO
3518!$OMP END DO
3519C----6---------------------------------------------------------------7---------8
3520 RETURN
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:54
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:43

◆ imp_glob_khp()

subroutine imp_glob_khp ( pm,
geo,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
elbuf,
integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(4,*) ixtg1,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
integer, dimension(nparg,*) iparg,
tf,
integer, dimension(*) npc,
fr_wave,
w16,
bufmat,
thke,
bufgeo,
rby,
skew,
x,
wa,
integer, dimension(*) iddl,
integer, dimension(*) ndof,
k_diag,
k_lt,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
integer ikgeo,
integer, dimension(*) etag,
integer itask0,
type (elbuf_struct_), dimension(ngroup) elbuf_tab,
type (stack_ply) stack,
type (drape_), dimension(numelc_drape), target drape_sh4n,
type (drape_), dimension(numeltg_drape), target drape_sh3n,
type (drapeg_) drapeg )

Definition at line 2857 of file imp_glob_k.F.

2867C-----------------------------------------------
2868C M o d u l e s
2869C-----------------------------------------------
2870 USE initbuf_mod
2871 USE elbufdef_mod
2872 USE stack_mod
2873 USE drape_mod
2874C-----------------------------------------------
2875C I m p l i c i t T y p e s
2876C-----------------------------------------------
2877#include "implicit_f.inc"
2878#include "comlock.inc"
2879C-----------------------------------------------
2880C C o m m o n B l o c k s
2881C-----------------------------------------------
2882#include "com01_c.inc"
2883#include "param_c.inc"
2884#include "task_c.inc"
2885#include "units_c.inc"
2886#include "impl1_c.inc"
2887C-----------------------------------------------------------------
2888C D u m m y A r g u m e n t s
2889C-----------------------------------------------
2890 INTEGER IDDL(*) ,NDOF(*) ,IADK(*) ,JDIK(*) ,
2891 . IPM(NPROPMI,*),IGEO(NPROPGI,*),IKGEO,ITASK0
2892 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
2893 . IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*),
2894 . NPC(*), IPARG(NPARG,*),
2895 . IXS10(6,*),IXS20(12,*),IXS16(8,*),IXTG1(4,*), ETAG(*)
2896C REAL
2897 my_real
2898 . pm(npropm,*),geo(npropg,*),bufmat(*) ,tf(*) ,
2899 . fr_wave(*) ,elbuf(*) ,thke(*),rby(*),skew(lskew,*),
2900 . bufgeo(*),w16(*),x(3,*),wa(*)
2901 my_real
2902 . k_diag(*) ,k_lt(*)
2903 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
2904 TYPE (STACK_PLY) :: STACK
2905 TYPE (DRAPE_), TARGET :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
2906 TYPE (DRAPEG_) :: DRAPEG
2907C-----------------------------------------------
2908C L o c a l V a r i a b l e s
2909C-----------------------------------------------
2910 INTEGER I,N,ITASK
2911 INTEGER IGROUC(NGROUP),IPRMES_EL(40)
2912C
2913 INTEGER OMP_GET_THREAD_NUM
2914 EXTERNAL omp_get_thread_num
2915C----6---------------------------------------------------------------7-2
2916 IF (ncycle==1.AND.inconv==1) THEN
2917 DO i=1,40
2918 iprmes_el(i)=0
2919 ENDDO
2920C /---------------/
2921 END IF
2922 CALL grpreorder(iparg, igrouc)
2923!$OMP PARALLEL PRIVATE(ITASK)
2924 itask = omp_get_thread_num()
2925
2926c
2927 CALL imp_glob_k0(
2928 1 pm ,geo ,ipm ,igeo ,elbuf ,
2929 2 ixs ,ixq ,ixc ,ixt ,ixp ,
2930 3 ixr ,ixtg ,ixtg1 ,ixs10 ,
2931 4 ixs20 ,ixs16 ,iparg ,tf ,npc ,
2932 5 fr_wave ,w16 ,bufmat ,thke ,bufgeo ,
2933 6 rby ,skew ,x ,
2934 7 wa ,iddl ,ndof ,k_diag ,k_lt ,
2935 8 iadk ,jdik ,ikgeo ,etag ,itask ,
2936 9 elbuf_tab ,igrouc ,iprmes_el ,stack ,drape_sh4n, drape_sh3n ,
2937 a drapeg )
2938C
2939!$OMP END PARALLEL
2940 IF (ncycle==1.AND.inconv==1) THEN
2941 IF (nspmd>1) THEN
2942 DO i=1,19
2943 CALL spmd_max_i(iprmes_el(i))
2944 ENDDO
2945 ENDIF
2946 IF (ispmd == 0 ) THEN
2947 DO i=1,19
2948 IF (iprmes_el(i)>0) THEN
2949 SELECT CASE (i)
2950C
2951 CASE(1)
2952 WRITE(iout,1006)
2953 WRITE(istdo,1006)
2954 CASE(2)
2955 WRITE(iout,1001)' S16 SOLID'
2956 WRITE(istdo,1001)' S16 SOLID'
2957 CASE(3)
2958 n = 24
2959 WRITE(iout,1002) n
2960 CASE(4)
2961 n = 12
2962 WRITE(iout,1002) n
2963 CASE(5)
2964 n = 0
2965 WRITE(iout,1002) n
2966 CASE(6)
2967 n = iprmes_el(i)
2968 WRITE(iout,1002) n
2969 CASE(7)
2970 WRITE(iout,1001)' USERS '
2971 WRITE(istdo,1001)' USERS '
2972 CASE(8)
2973 WRITE(iout,1001)' HEPH SOLID'
2974 CASE(9,10)
2975 WRITE(iout,1001)' S8 SOLID'
2976 CASE(11)
2977 WRITE(iout,1001)' QUAD 2D '
2978 WRITE(istdo,1001)' QUAD 2D '
2979 CASE(12)
2980 n = 4
2981 WRITE(iout,1003) n
2982 CASE(13)
2983 n = 3
2984 WRITE(iout,1003) n
2985 CASE(14)
2986 n = 1
2987 WRITE(iout,1003) n
2988 CASE(15)
2989 n = iprmes_el(i)
2990 WRITE(iout,1003) n
2991 CASE(16)
2992 n = iprmes_el(i)
2993 WRITE(iout,1005) n
2994 WRITE(istdo,1005) n
2995 CASE(17)
2996 WRITE(iout,1001)' S3N6 SHELL'
2997 WRITE(istdo,1001)' S3N6 SHELL'
2998 CASE(18)
2999 n = iprmes_el(i)
3000 WRITE(iout,1004) n
3001 CASE(19)
3002 WRITE(iout,1001)'USER-SPRING'
3003 WRITE(istdo,1001)'USER-SPRING'
3004 END SELECT
3005 ENDIF
3006 ENDDO
3007 ENDIF
3008 END IF !(NCYCLE==1.AND.INCONV==1) THEN
3009C----6---------------------------------------------------------------7---------8
3010 1001 FORMAT(' ***** WARNING : IMPLICIT FORMULATION IS NOT AVAILABLE
3011 . WITH '/,2x,a11,' ELEMENT : STIFFNESS IGNORED *****')
3012 1002 FORMAT(' ***** WARNING : ELEMENT FORMULATION ISOLID= ',
3013 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING,'
3014 . ,' USING GENERIC ONE INSTEAD'/
3015 . ,5x,' POSSIBLE CONVERGING ISSUE. *****')
3016 1003 FORMAT(' ***** WARNING : ELEMENT FORMULATION ISHELL= ',
3017 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING,'
3018 . ,' USING GENERIC ONE INSTEAD'/
3019 . ,5x,' POSSIBLE CONVERGING ISSUE. *****')
3020 1004 FORMAT(' ***** WARNING : ELEMENT FORMULATION ISH3N = ',
3021 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING,'
3022 . ,' USING GENERIC ONE INSTEAD'/
3023 . ,5x,' POSSIBLE CONVERGING ISSUE. *****')
3024 1005 FORMAT(' ***** WARNING : SPRING ELEMENT PROP.TYPE = ',
3025 . i4/,5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING,'
3026 . ,' STIFFNESS IGNORED *****')
3027 1006 FORMAT(' *****WARNING : TETRA ELEMENT FORMULATION W/ ITETRA>0 '/,
3028 . 5x,'IS NOT AVAILABLE FOR STIFFNESS MATRIX BUILDING;'/,
3029 . 5x,'USING ITETRA=0 INSTEAD, POSSIBLE CONVERGING ISSUE.')
3030 RETURN
grpreorder
subroutine grpreorder(iparg, igrouc)
Definition imp_glob_k.F:2801
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:3074
spmd_max_i
subroutine spmd_max_i(n)
Definition imp_spmd.F:1362

◆ imp_kpres()

subroutine imp_kpres ( integer, dimension(nibcld,*) ib,
fac,
integer, dimension(*) npc,
tf,
x,
skew,
integer, intent(in) nsensor,
type (sensor_str_), dimension(nsensor), intent(in) sensor_tab,
integer, dimension(*) weight,
integer, dimension(4,*) iadc,
integer, dimension(*) iddl,
integer, dimension(*) ndof,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
k_diag,
k_lt )

Definition at line 1967 of file imp_glob_k.F.

1971C-----------------------------------------------
1972C M o d u l e s
1973C-----------------------------------------------
1974 USE sensor_mod
1975C-----------------------------------------------
1976C I m p l i c i t T y p e s
1977C-----------------------------------------------
1978#include "implicit_f.inc"
1979#include "comlock.inc"
1980#include "param_c.inc"
1981C-----------------------------------------------
1982C C o m m o n B l o c k s
1983C-----------------------------------------------
1984#include "com01_c.inc"
1985#include "com04_c.inc"
1986#include "com08_c.inc"
1987C-----------------------------------------------
1988C E x t e r n a l F u n c t i o n s
1989C-----------------------------------------------
1990 INTEGER ,INTENT(IN) :: NSENSOR
1991C-----------------------------------------------,
1992C D u m m y A r g u m e n t s
1993C-----------------------------------------------
1994 INTEGER NPC(*),IB(NIBCLD,*)
1995 INTEGER WEIGHT(*), IADC(4,*)
1996 INTEGER IDDL(*) ,NDOF(*) ,IADK(*) ,JDIK(*)
1997C REAL
1998 my_real
1999 . fac(lfaccld,*), tf(*), x(3,*), skew(lskew,*),
2000 . k_diag(*) ,k_lt(*)
2001 TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) ,INTENT(IN) :: SENSOR_TAB
2002C-----------------------------------------------
2003C L o c a l V a r i a b l e s
2004C-----------------------------------------------
2005 INTEGER NL, N1, ISK, N2, N3, N4, N5, K1, K2, K3, ISENS,K,LL,
2006 . ICODE,IAD,N_OLD,IPRES4,IERR,ND,I,J
2007C REAL
2008 my_real
2009 . axi, aa, a0, vv, fx, fy, fz, ax, dydx, ts,
2010 . sixth,x_old, f1, f2,xsens,fcx,fcy,scaln
2011 my_real
2012 . vksi(4,4),veta(4,4),vf4(4,4),
2013 . k11(6,6),k22(6,6),k33(6,6),k44(6,6),k12(6,6),
2014 . k13(6,6),k14(6,6),k23(6,6),k24(6,6),k34(6,6)
2015 my_real finter
2016 EXTERNAL finter
2017C=======================================================================
2018C-------IPRES4=0:no pressure,1:pressure with 3n; 2: with 4N
2019 ipres4=0
2020 nd =3
2021 scaln=half
2022C IF (ILINE==0) SCALN=ONEP1
2023C IF (NBUCK>0) SCALN=-ONE
2024 DO nl=1,nconld
2025 n4=ib(4,nl)
2026 isens=0
2027 xsens = one
2028 DO k=1,nsensor
2029 IF(ib(6,nl)==sensor_tab(k)%SENS_ID) isens=k
2030 ENDDO
2031 IF(isens==0)THEN
2032 ts=tt
2033 ELSE
2034 ts = tt-sensor_tab(isens)%TSTART
2035 IF(ts < zero) cycle
2036 ENDIF
2037C
2038 IF(n4==-1)THEN
2039C----------------
2040C FORCE CONCENTREE
2041C----------------
2042 ELSE
2043C----------------
2044C PRESSION
2045C----------------
2046 IF (xsens==zero) cycle
2047C
2048 IF(n2d==0)THEN
2049C ANALYSE 3D
2050 IF(n4/=0)THEN
2051 ipres4=2
2052 GOTO 100
2053 ELSE
2054C true triangles.
2055 ipres4=1
2056 ENDIF
2057 ENDIF
2058 ENDIF
2059 END DO
2060C
2061 100 CONTINUE
2062 IF (ipres4==0) RETURN
2063 IF (ipres4>1) CALL kp4_ini(vksi,veta,vf4)
2064 n_old = 0
2065 x_old = zero
2066 DO 10 nl=1,nconld
2067 n1=ib(1,nl)
2068 n2=ib(2,nl)
2069 n3=ib(3,nl)
2070 n4=ib(4,nl)
2071 n5=ib(5,nl)
2072 fcy = fac(1,nl)
2073 fcx = fac(2,nl)
2074 isens=0
2075 xsens = one
2076 DO k=1,nsensor
2077 IF(ib(6,nl)==sensor_tab(k)%SENS_ID) isens=k
2078 ENDDO
2079 IF(isens==0)THEN
2080 ts=tt
2081 ELSE
2082 ts = tt-sensor_tab(isens)%TSTART
2083 IF(ts < zero) GOTO 10
2084 ENDIF
2085C
2086 IF(n4==-1)THEN
2087C----------------
2088C FORCE CONCENTREE
2089C----------------
2090 ELSE
2091C----------------
2092C PRESSION
2093C----------------
2094 IF(n_old/=n5.OR.x_old/=ts) THEN
2095 f1 = finter(n5,ts*fcx,npc,tf,dydx)
2096 n_old = n5
2097 x_old = ts
2098 ENDIF
2099 aa = -scaln*fcy*f1*xsens
2100 IF (aa==zero) cycle
2101C
2102 IF(n2d==0)THEN
2103C ANALYSE 3D
2104 IF(n4/=0)THEN
2105 CALL kpquad(n1,n2,n3,n4,aa,x,vksi,veta,vf4,
2106 . k11,k22,k33,k44,k12,k13,k14,k23,k24,k34)
2107C-----------add in ind_glob_k in case element has been deleted---
2108c CALL PUT_KII(N1 ,IDDL ,IADK,K_DIAG,K_LT ,K11,ND )
2109c CALL PUT_KII(N2 ,IDDL ,IADK,K_DIAG,K_LT ,K22,ND )
2110c CALL PUT_KII(N3 ,IDDL ,IADK,K_DIAG,K_LT ,K33,ND )
2111c CALL PUT_KII(N4 ,IDDL ,IADK,K_DIAG,K_LT ,K44,ND )
2112C
2113 CALL put_kij(n1 ,n2 ,iddl ,iadk,jdik,k_lt,k12,nd ,nd ,
2114 . ierr)
2115 CALL put_kij(n1 ,n3 ,iddl ,iadk,jdik,k_lt,k13,nd ,nd ,
2116 . ierr)
2117 CALL put_kij(n1 ,n4 ,iddl ,iadk,jdik,k_lt,k14,nd ,nd ,
2118 . ierr)
2119 CALL put_kij(n2 ,n3 ,iddl ,iadk,jdik,k_lt,k23,nd ,nd ,
2120 . ierr)
2121 CALL put_kij(n2 ,n4 ,iddl ,iadk,jdik,k_lt,k24,nd ,nd ,
2122 . ierr)
2123 CALL put_kij(n3 ,n4 ,iddl ,iadk,jdik,k_lt,k34,nd ,nd ,
2124 . ierr)
2125 ELSE
2126C triangles.
2127 CALL kptria(n1,n2,n3,aa,x,
2128 . k11,k22,k33,k12,k13,k23)
2129c CALL PUT_KII(N1 ,IDDL ,IADK,K_DIAG,K_LT ,K11,ND )
2130c CALL PUT_KII(N2 ,IDDL ,IADK,K_DIAG,K_LT ,K22,ND )
2131c CALL PUT_KII(N3 ,IDDL ,IADK,K_DIAG,K_LT ,K33,ND )
2132C
2133 CALL put_kij(n1 ,n2 ,iddl ,iadk,jdik,k_lt,k12,nd ,nd ,
2134 . ierr)
2135 CALL put_kij(n1 ,n3 ,iddl ,iadk,jdik,k_lt,k13,nd ,nd ,
2136 . ierr)
2137 CALL put_kij(n2 ,n3 ,iddl ,iadk,jdik,k_lt,k23,nd ,nd ,
2138 . ierr)
2139 ENDIF
2140 ELSE
2141C ANALYSE 2D
2142 ENDIF
2143 ENDIF
2144 10 CONTINUE
2145C
2146 RETURN
kptria
subroutine kptria(n1, n2, n3, p, x, k11, k22, k33, k12, k13, k23)
Definition imp_glob_k.F:2485
kp4_ini
subroutine kp4_ini(vksi, veta, vf4)
Definition imp_glob_k.F:2401
put_kij
subroutine put_kij(ni, nj, iddl, iadk, jdik, k_lt, kij, nk, nl, ierr)
Definition imp_glob_k.F:810
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:2155

◆ impkcout()

subroutine impkcout ( integer, dimension(nixc,*) ixc,
integer nft,
integer nel,
integer iugeo,
ke11,
ke12,
ke13,
ke14,
ke22,
ke23,
ke24,
ke33,
ke34,
ke44 )

Definition at line 1432 of file imp_glob_k.F.

1435C
1436C-----------------------------------------------
1437C I m p l i c i t T y p e s
1438C-----------------------------------------------
1439#include "implicit_f.inc"
1440#include "mvsiz_p.inc"
1441C-----------------------------------------------
1442C D u m m y A r g u m e n t s
1443C-----------------------------------------------
1444 INTEGER IXC(NIXC,*),NFT,NEL,IUGEO
1445C REAL
1446 my_real
1447 . ke11(6,6,*),ke22(6,6,*),ke33(6,6,*),ke44(6,6,*),
1448 . ke12(6,6,*),ke13(6,6,*),ke14(6,6,*),ke23(6,6,*),
1449 . ke24(6,6,*),ke34(6,6,*)
1450C-----------------------------------------------
1451C L o c a l V a r i a b l e s
1452C-----------------------------------------------
1453 INTEGER I,J,N,NT,IG(MVSIZ)
1454C=======================================================================
1455C SHELL
1456C=======================================================================
1457 DO n= 1,nel
1458 nt=n+nft
1459 ig(n)=ixc(nixc,nt)
1460 ENDDO
1461 CALL writekc(iugeo,nft,nel,ig,'K11',ke11)
1462 CALL writekc(iugeo,nft,nel,ig,'K12',ke12)
1463 CALL writekc(iugeo,nft,nel,ig,'K13',ke13)
1464 CALL writekc(iugeo,nft,nel,ig,'K14',ke14)
1465 CALL writekc(iugeo,nft,nel,ig,'K22',ke22)
1466 CALL writekc(iugeo,nft,nel,ig,'K23',ke23)
1467 CALL writekc(iugeo,nft,nel,ig,'K24',ke24)
1468 CALL writekc(iugeo,nft,nel,ig,'K33',ke33)
1469 CALL writekc(iugeo,nft,nel,ig,'K34',ke34)
1470 CALL writekc(iugeo,nft,nel,ig,'K44',ke44)
1471C
1472 RETURN
writekc
subroutine writekc(in, nft, nel, ig, ch, kij)
Definition imp_glob_k.F:1481

◆ impkiout()

subroutine impkiout ( integer nixpl,
integer, dimension(nixpl,*) ixp,
integer nft,
integer nel,
integer iugeo,
ke11,
ke12,
ke22 )

Definition at line 1597 of file imp_glob_k.F.

1598C
1599C-----------------------------------------------
1600C I m p l i c i t T y p e s
1601C-----------------------------------------------
1602#include "implicit_f.inc"
1603#include "mvsiz_p.inc"
1604C-----------------------------------------------
1605C D u m m y A r g u m e n t s
1606C-----------------------------------------------
1607 INTEGER NIXPL
1608 INTEGER IXP(NIXPL,*),NEL,IUGEO,NFT
1609C REAL
1610 my_real
1611 . ke11(3,3,*),ke22(3,3,*),ke12(3,3,*)
1612C-----------------------------------------------
1613C L o c a l V a r i a b l e s
1614C-----------------------------------------------
1615 INTEGER I,J,N,NT,IG(MVSIZ)
1616C=======================================================================
1617C SHELL
1618C=======================================================================
1619 DO n= 1,nel
1620 ig(n)=ixp(nixpl,n)
1621 ENDDO
1622 CALL writeki(iugeo,nft,nel,ig,'K11',ke11)
1623 CALL writeki(iugeo,nft,nel,ig,'K12',ke12)
1624 CALL writeki(iugeo,nft,nel,ig,'K22',ke22)
1625C
1626 RETURN
writeki
subroutine writeki(in, nft, nel, ig, ch, kij)
Definition imp_glob_k.F:1635

◆ impkpout()

subroutine impkpout ( integer nixpl,
integer, dimension(nixpl,*) ixp,
integer nft,
integer nel,
integer iugeo,
ke11,
ke12,
ke22 )

Definition at line 1520 of file imp_glob_k.F.

1521C
1522C-----------------------------------------------
1523C I m p l i c i t T y p e s
1524C-----------------------------------------------
1525#include "implicit_f.inc"
1526#include "mvsiz_p.inc"
1527C-----------------------------------------------
1528C D u m m y A r g u m e n t s
1529C-----------------------------------------------
1530 INTEGER NIXPL
1531 INTEGER IXP(NIXPL,*),NEL,IUGEO,NFT
1532C REAL
1533 my_real
1534 . ke11(6,6,*),ke22(6,6,*),ke12(6,6,*)
1535C-----------------------------------------------
1536C L o c a l V a r i a b l e s
1537C-----------------------------------------------
1538 INTEGER I,J,N,NT,IG(MVSIZ)
1539C=======================================================================
1540C SHELL
1541C=======================================================================
1542 DO n= 1,nel
1543 ig(n)=ixp(nixpl,n)
1544 ENDDO
1545 CALL writekp(iugeo,nft,nel,ig,'K11',ke11)
1546 CALL writekp(iugeo,nft,nel,ig,'K12',ke12)
1547 CALL writekp(iugeo,nft,nel,ig,'K22',ke22)
1548C
1549 RETURN
writekp
subroutine writekp(in, nft, nel, ig, ch, kij)
Definition imp_glob_k.F:1558

◆ impksout()

subroutine impksout ( integer, dimension(nixs,*) ixs,
integer nft,
integer nel,
integer 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 at line 1307 of file imp_glob_k.F.

1316C
1317C-----------------------------------------------
1318C I m p l i c i t T y p e s
1319C-----------------------------------------------
1320#include "implicit_f.inc"
1321#include "mvsiz_p.inc"
1322C-----------------------------------------------
1323C D u m m y A r g u m e n t s
1324C-----------------------------------------------
1325 INTEGER IXS(NIXS,*),NFT,NEL,IUGEO
1326C REAL
1327 my_real
1328 . k11(3,3,*),k12(3,3,*),k13(3,3,*) ,k14(3,3,*) ,k15(3,3,*),
1329 . k16(3,3,*),k17(3,3,*),k18(3,3,*) ,k22(3,3,*) ,k23(3,3,*),
1330 . k24(3,3,*),k25(3,3,*),k26(3,3,*) ,k27(3,3,*) ,k28(3,3,*),
1331 . k33(3,3,*),k34(3,3,*),k35(3,3,*) ,k36(3,3,*) ,k37(3,3,*),
1332 . k38(3,3,*),k44(3,3,*),k45(3,3,*) ,k46(3,3,*) ,k47(3,3,*),
1333 . k48(3,3,*),k55(3,3,*),k56(3,3,*) ,k57(3,3,*) ,k58(3,3,*),
1334 . k66(3,3,*),k67(3,3,*),k68(3,3,*) ,k77(3,3,*) ,k78(3,3,*),
1335 . k88(3,3,*)
1336C-----------------------------------------------
1337C L o c a l V a r i a b l e s
1338C-----------------------------------------------
1339 INTEGER I,J,N,NT,IG(MVSIZ)
1340C=======================================================================
1341C SOLID
1342C=======================================================================
1343 DO n= 1,nel
1344 nt=n+nft
1345 ig(n)=ixs(nixs,nt)
1346 ENDDO
1347 CALL writeks(iugeo,nft,nel,ig,'K11',k11)
1348 CALL writeks(iugeo,nft,nel,ig,'K12',k12)
1349 CALL writeks(iugeo,nft,nel,ig,'K13',k13)
1350 CALL writeks(iugeo,nft,nel,ig,'K14',k14)
1351 CALL writeks(iugeo,nft,nel,ig,'K15',k15)
1352 CALL writeks(iugeo,nft,nel,ig,'K16',k16)
1353 CALL writeks(iugeo,nft,nel,ig,'K17',k17)
1354 CALL writeks(iugeo,nft,nel,ig,'K18',k18)
1355 CALL writeks(iugeo,nft,nel,ig,'K22',k22)
1356 CALL writeks(iugeo,nft,nel,ig,'K23',k23)
1357 CALL writeks(iugeo,nft,nel,ig,'K24',k24)
1358 CALL writeks(iugeo,nft,nel,ig,'K25',k25)
1359 CALL writeks(iugeo,nft,nel,ig,'K26',k26)
1360 CALL writeks(iugeo,nft,nel,ig,'K27',k27)
1361 CALL writeks(iugeo,nft,nel,ig,'K28',k28)
1362 CALL writeks(iugeo,nft,nel,ig,'K33',k33)
1363 CALL writeks(iugeo,nft,nel,ig,'K34',k34)
1364 CALL writeks(iugeo,nft,nel,ig,'K35',k35)
1365 CALL writeks(iugeo,nft,nel,ig,'K36',k36)
1366 CALL writeks(iugeo,nft,nel,ig,'K37',k37)
1367 CALL writeks(iugeo,nft,nel,ig,'K38',k38)
1368 CALL writeks(iugeo,nft,nel,ig,'K44',k44)
1369 CALL writeks(iugeo,nft,nel,ig,'K45',k45)
1370 CALL writeks(iugeo,nft,nel,ig,'K46',k46)
1371 CALL writeks(iugeo,nft,nel,ig,'K47',k47)
1372 CALL writeks(iugeo,nft,nel,ig,'K48',k48)
1373 CALL writeks(iugeo,nft,nel,ig,'K55',k55)
1374 CALL writeks(iugeo,nft,nel,ig,'K56',k56)
1375 CALL writeks(iugeo,nft,nel,ig,'K57',k57)
1376 CALL writeks(iugeo,nft,nel,ig,'K58',k58)
1377 CALL writeks(iugeo,nft,nel,ig,'K66',k66)
1378 CALL writeks(iugeo,nft,nel,ig,'K67',k67)
1379 CALL writeks(iugeo,nft,nel,ig,'K68',k68)
1380 CALL writeks(iugeo,nft,nel,ig,'K77',k77)
1381 CALL writeks(iugeo,nft,nel,ig,'K78',k78)
1382 CALL writeks(iugeo,nft,nel,ig,'K88',k88)
1383C
1384 RETURN
writeks
subroutine writeks(in, nft, nel, ig, ch, kij)
Definition imp_glob_k.F:1393

◆ jacobien()

subroutine jacobien ( a,
integer n,
ew,
ev,
tol,
lamda )

Definition at line 1779 of file imp_glob_k.F.

1780C-------------------------------------------------------KK141189-
1781C COMPUTATION OF ALL EIGENVALUES AND EIGENVECTORS OF A SYMMETRIC
1782C MATRIX A BY THE JACOBI ALGORITHM
1783C
1784C A(N,N) EIGENWERTPROBLEM
1785C N DIMENSION OF A
1786C EW(N) EIGENVALUES
1787C EV(N,N) EIGENVEKTORS
1788C NROT NUMBER OF ROTATIONS
1789C MAXA MAXIMUM ELEMENT OF A
1790C-----------------------------------------------
1791C I m p l i c i t T y p e s
1792C-----------------------------------------------
1793#include "implicit_f.inc"
1794 INTEGER N
1795 my_real
1796 . a(n,n), ew(n), ev(n,n)
1797 . , b(n), z(n),tol,lamda
1798 INTEGER IZ,IS,ITER,J,NROT
1799 my_real
1800 . sumrs,eps,g,h,t,c,s,tau,theta,r,lamda0
1801C----------------------------------------------------------------
1802 DO 130 iz=1,n
1803 DO 120 is=1,n
1804 IF(iz<is) a(is,iz) = a(iz,is)
1805 ev(iz,is)=zero
1806 120 CONTINUE
1807 b(iz)=a(iz,iz)
1808 ew(iz)=b(iz)
1809 z(iz)=0.
1810 ev(iz,iz)=one
1811c EV(IZ,IZ)=ZERO
1812 130 CONTINUE
1813
1814 nrot=0
1815 r=ep30
1816 iter =0
1817
1818 sumrs = zero
1819
1820 lamda0=zero
1821
1822C SUM OF THE OFF DIAGONALS
1823 DO 150 iz=1,n-1
1824 DO 140 is=iz+1,n
1825 sumrs=sumrs+abs(a(iz,is))
1826 140 CONTINUE
1827 150 CONTINUE
1828
1829 IF (sumrs ==zero) GOTO 9000
1830 IF (iter > 4) THEN
1831 eps = zero
1832 ELSE
1833 eps = one_fifth*sumrs/n**2
1834 ENDIF
1835C START ITERATION
1836
1837 DO WHILE (r>tol)
1838c DO 240 ITER = 1,50
1839 iter =iter+ 1
1840
1841 DO 220 iz=1,n-1
1842 DO 210 is=iz+1,n
1843 g = 100. * abs(a(iz,is))
1844 IF (iter>4 .AND. abs(ew(iz))+g==abs(ew(iz))
1845 & .AND. abs(ew(is))+g==abs(ew(is))) THEN
1846 a(iz,is)=zero
1847 ELSE IF (abs(a(iz,is)) > eps) THEN
1848 h = ew(is)-ew(iz)
1849 IF (abs(h)+g==abs(h)) THEN
1850 t = a(iz,is)/h
1851 ELSE
1852 theta = half*h/a(iz,is)
1853 t=one/(abs(theta)+sqrt(one+theta**2))
1854 IF (theta < zero) t=-t
1855 ENDIF
1856 c=one/sqrt(one+t**2)
1857 s=t*c
1858 tau=s/(one+c)
1859 h=t*a(iz,is)
1860 z(iz)=z(iz)-h
1861 z(is)=z(is)+h
1862 ew(iz)=ew(iz)-h
1863 ew(is)=ew(is)+h
1864 a(iz,is)=zero
1865 DO 160 j=1,iz-1
1866 g=a(j,iz)
1867 h=a(j,is)
1868 a(j,iz)=g-s*(h+g*tau)
1869 a(j,is)=h+s*(g-h*tau)
1870 160 CONTINUE
1871 DO 170 j=iz+1,is-1
1872 g=a(iz,j)
1873 h=a(j,is)
1874 a(iz,j)=g-s*(h+g*tau)
1875 a(j,is)=h+s*(g-h*tau)
1876 170 CONTINUE
1877 DO 180 j=is+1,n
1878 g=a(iz,j)
1879 h=a(is,j)
1880 a(iz,j)=g-s*(h+g*tau)
1881 a(is,j)=h+s*(g-h*tau)
1882 180 CONTINUE
1883 DO 190 j=1,n
1884 g=ev(j,iz)
1885 h=ev(j,is)
1886 ev(j,iz)=g-s*(h+g*tau)
1887 ev(j,is)=h+s*(g-h*tau)
1888 190 CONTINUE
1889 nrot=nrot+1
1890 ENDIF
1891 210 CONTINUE
1892 220 CONTINUE
1893 DO 230 iz=1,n
1894 b(iz)=b(iz)+z(iz)
1895 IF (b(iz)>lamda)lamda=b(iz)
1896 ew(iz)=b(iz)
1897 z(iz)=zero
1898 230 CONTINUE
1899c R=ABS(LAMDA-LAMDA0)
1900 r=abs(lamda/max(em20,lamda0)-one)
1901 lamda0=lamda
1902c write(*,*)'iter,lamda,R=',iter,lamda,R
1903 lamda=zero
1904c 240 CONTINUE
1905 ENDDO
1906
1907 lamda=lamda0
1908c write(*,*)'n_iter,nrot=',iter,nrot,eps
1909 9000 CONTINUE
1910
1911 RETURN
1912

◆ kelamda()

subroutine kelamda ( integer, dimension(nixcl,*) ixc,
integer nixcl,
integer nft,
integer nel,
integer iugeo,
ke11,
ke12,
ke13,
ke14,
ke22,
ke23,
ke24,
ke33,
ke34,
ke44 )

Definition at line 1674 of file imp_glob_k.F.

1677C-----------------------------------------------
1678C I m p l i c i t T y p e s
1679C-----------------------------------------------
1680#include "implicit_f.inc"
1681#include "mvsiz_p.inc"
1682C-----------------------------------------------
1683C D u m m y A r g u m e n t s
1684C-----------------------------------------------
1685 INTEGER NIXCL
1686 INTEGER IXC(NIXCL,*),NFT,NEL,IUGEO
1687C REAL
1688 my_real
1689 . ke11(6,6,*),ke22(6,6,*),ke33(6,6,*),ke44(6,6,*),
1690 . ke12(6,6,*),ke13(6,6,*),ke14(6,6,*),ke23(6,6,*),
1691 . ke24(6,6,*),ke34(6,6,*)
1692C-----------------------------------------------
1693C L o c a l V a r i a b l e s
1694C-----------------------------------------------
1695 INTEGER I,J,N,NT,IG(MVSIZ),I2,I3,I4,J2,J3,J4
1696 my_real
1697 . ke(24,24,mvsiz),ew(24,mvsiz),tol,lamda(mvsiz),
1698 . a,b,c,lamdas(mvsiz),ev(24,24),ktmp(2,2)
1699C
1700 tol=em5
1701 DO n= 1,nel
1702 nt=n+nft
1703 ig(n)=ixc(nixcl,nt)
1704 ENDDO
1705 DO i=1,6
1706 i2=i+6
1707 i3=i2+6
1708 i4=i3+6
1709 DO j=i,6
1710 j2=j+6
1711 j3=j2+6
1712 j4=j3+6
1713 DO n= 1,nel
1714 ke(i,j,n)=ke11(i,j,n)
1715 ke(i2,j2,n)=ke22(i,j,n)
1716 ke(i3,j3,n)=ke33(i,j,n)
1717 ke(i4,j4,n)=ke44(i,j,n)
1718 ENDDO
1719 ENDDO
1720 ENDDO
1721 DO i=1,6
1722 i2=i+6
1723 i3=i2+6
1724 i4=i3+6
1725 DO j=1,6
1726 j2=j+6
1727 j3=j2+6
1728 j4=j3+6
1729 DO n= 1,nel
1730 ke(i,j2,n)=ke12(i,j,n)
1731 ke(i,j3,n)=ke13(i,j,n)
1732 ke(i,j4,n)=ke14(i,j,n)
1733 ke(i2,j3,n)=ke23(i,j,n)
1734 ke(i2,j4,n)=ke24(i,j,n)
1735 ke(i3,j4,n)=ke34(i,j,n)
1736 ENDDO
1737 ENDDO
1738 ENDDO
1739 DO n= 1,nel
1740 CALL jacobien(ke(1,1,n),24,ew(1,n),ev,tol,lamda(n))
1741 a=half*(ke11(1,1,n)+ke11(2,2,n))
1742 b=half*(ke11(1,1,n)-ke11(2,2,n))
1743 c=a+sqrt(b*b+ke11(1,2,n)*ke11(1,2,n))
1744 lamdas(n)=c
1745 a=half*(ke22(1,1,n)+ke22(2,2,n))
1746 b=half*(ke22(1,1,n)-ke22(2,2,n))
1747 c=a+sqrt(b*b+ke22(1,2,n)*ke22(1,2,n))
1748 IF(c>lamdas(n))lamdas(n)=c
1749 a=half*(ke33(1,1,n)+ke33(2,2,n))
1750 b=half*(ke33(1,1,n)-ke33(2,2,n))
1751 c=a+sqrt(b*b+ke33(1,2,n)*ke33(1,2,n))
1752 IF(c>lamdas(n))lamdas(n)=c
1753 a=half*(ke44(1,1,n)+ke44(2,2,n))
1754 b=half*(ke44(1,1,n)-ke44(2,2,n))
1755 c=a+sqrt(b*b+ke44(1,2,n)*ke44(1,2,n))
1756 IF(c>lamdas(n))lamdas(n)=c
1757 ENDDO
1758 WRITE(iugeo,'(A)') '#SHELL EIGENVALUES'
1759 WRITE(iugeo,'(A)')
1760 . '#FORMAT: (2I8,1P3E16.9,/,4(/,1P5E16.9),/,1P4E16.9) '
1761 WRITE(iugeo,'(2A)')
1762 . '#SYSSHEL USRSHEL LAMDA1,LAMDAS,FAC, LAMDA(I),I=24'
1763 DO n= 1,nel
1764 nt=n+nft
1765 WRITE(iugeo,'(2I8,1P3E16.9,/,4(/,1P5E16.9),/,1P4E16.9)'
1766 . )nt,ig(n),lamda(n),lamdas(n),lamda(n)/lamdas(n),
1767 . (ew(i,n),i=1,24)
1768 ENDDO
1769C
1770 RETURN
jacobien
subroutine jacobien(a, n, ew, ev, tol, lamda)
Definition imp_glob_k.F:1780

◆ kp4_ini()

subroutine kp4_ini ( vksi,
veta,
vf4 )

Definition at line 2400 of file imp_glob_k.F.

2401C-----------------------------------------------
2402C I m p l i c i t T y p e s
2403C-----------------------------------------------
2404#include "implicit_f.inc"
2405C-----------------------------------------------
2406C C o m m o n B l o c k s
2407C-----------------------------------------------
2408C-----------------------------------------------------------------
2409C D u m m y A r g u m e n t s
2410C-----------------------------------------------
2411 my_real
2412 . vksi(4,4),veta(4,4),vf4(4,4)
2413C-----------------------------------------------
2414C L o c a l V a r i a b l e s
2415C-----------------------------------------------
2416 INTEGER I, J ,K
2417 my_real
2418 . pg,pg2
2419 DATA pg/.577350269189626/
2420C------------NI,ksi=VKSI,NI,eta=VETA--------------------------------
2421 vksi(1,1)=-fourth*(one+pg)
2422 vksi(2,1)=-vksi(1,1)
2423 vksi(3,1)= fourth*(one-pg)
2424 vksi(4,1)=-vksi(3,1)
2425 veta(1,1)=-fourth*(one+pg)
2426 veta(2,1)=-fourth*(one-pg)
2427 veta(3,1)=-veta(2,1)
2428 veta(4,1)=-veta(1,1)
2429 vksi(1,2)= vksi(1,1)
2430 vksi(2,2)=-vksi(1,2)
2431 vksi(3,2)= vksi(3,1)
2432 vksi(4,2)=-vksi(3,2)
2433 veta(1,2)= veta(2,1)
2434 veta(2,2)= veta(1,1)
2435 veta(3,2)=-veta(2,2)
2436 veta(4,2)=-veta(1,2)
2437 vksi(1,3)=-vksi(3,1)
2438 vksi(2,3)=-vksi(1,3)
2439 vksi(3,3)=-vksi(1,1)
2440 vksi(4,3)=-vksi(3,3)
2441 veta(1,3)= veta(1,2)
2442 veta(2,3)= veta(2,2)
2443 veta(3,3)=-veta(2,3)
2444 veta(4,3)=-veta(1,3)
2445 vksi(1,4)= vksi(1,3)
2446 vksi(2,4)=-vksi(1,4)
2447 vksi(3,4)= vksi(3,3)
2448 vksi(4,4)=-vksi(3,4)
2449 veta(1,4)= veta(1,1)
2450 veta(2,4)= veta(2,1)
2451 veta(3,4)=-veta(2,4)
2452 veta(4,4)=-veta(1,4)
2453 pg2=fourth*pg*pg
2454 DO i =1,4
2455 vf4(i,1)=fourth+(-vksi(i,1)-veta(i,1))*pg
2456 vf4(i,2)=fourth+(vksi(i,2)-veta(i,2))*pg
2457 vf4(i,3)=fourth+(vksi(i,3)+veta(i,3))*pg
2458 vf4(i,4)=fourth+(-vksi(i,4)+veta(i,4))*pg
2459 END DO
2460 vf4(1,1)=vf4(1,1)-pg2
2461 vf4(2,1)=vf4(2,1)+pg2
2462 vf4(3,1)=vf4(3,1)-pg2
2463 vf4(4,1)=vf4(4,1)+pg2
2464 vf4(1,2)=vf4(1,2)+pg2
2465 vf4(2,2)=vf4(2,2)-pg2
2466 vf4(3,2)=vf4(3,2)+pg2
2467 vf4(4,2)=vf4(4,2)-pg2
2468 vf4(1,3)=vf4(1,3)-pg2
2469 vf4(2,3)=vf4(2,3)+pg2
2470 vf4(3,3)=vf4(3,3)-pg2
2471 vf4(4,3)=vf4(4,3)+pg2
2472 vf4(1,4)=vf4(1,4)+pg2
2473 vf4(2,4)=vf4(2,4)-pg2
2474 vf4(3,4)=vf4(3,4)+pg2
2475 vf4(4,4)=vf4(4,4)-pg2
2476 RETURN

◆ kpquad()

subroutine kpquad ( integer n1,
integer n2,
integer n3,
integer n4,
p,
x,
vksi,
veta,
vf4,
k11,
k22,
k33,
k44,
k12,
k13,
k14,
k23,
k24,
k34 )

Definition at line 2153 of file imp_glob_k.F.

2155C-----------------------------------------------
2156C I m p l i c i t T y p e s
2157C-----------------------------------------------
2158#include "implicit_f.inc"
2159C-----------------------------------------------
2160C C o m m o n B l o c k s
2161C-----------------------------------------------
2162C-----------------------------------------------------------------
2163C D u m m y A r g u m e n t s
2164C-----------------------------------------------
2165 INTEGER N1,N2,N3,N4
2166 my_real
2167 . p,x(3,*),vksi(4,4),veta(4,4),vf4(4,4),
2168 . k11(6,6),k22(6,6),k33(6,6),k44(6,6),k12(6,6),
2169 . k13(6,6),k14(6,6),k23(6,6),k24(6,6),k34(6,6)
2170C-----------------------------------------------
2171C L o c a l V a r i a b l e s
2172C-----------------------------------------------
2173 INTEGER I, J ,K,NP
2174 my_real
2175 . pg,j0,j1,j2,deta(4),x1,y1,s1,pg2,
2176 . ksix,ksiy,ksiz,etax,etay,etaz,hx,hy,hz,
2177 . g1x(4),g1y(4),g1z(4),g2x(4),g2y(4),g2z(4)
2178 DATA pg/.577350269189626/
2179C
2180 ksix=(-x(1,n1)+x(1,n2)+x(1,n3)-x(1,n4))*fourth
2181 ksiy=(-x(2,n1)+x(2,n2)+x(2,n3)-x(2,n4))*fourth
2182 ksiz=(-x(3,n1)+x(3,n2)+x(3,n3)-x(3,n4))*fourth
2183C
2184 etax=(-x(1,n1)-x(1,n2)+x(1,n3)+x(1,n4))*fourth
2185 etay=(-x(2,n1)-x(2,n2)+x(2,n3)+x(2,n4))*fourth
2186 etaz=(-x(3,n1)-x(3,n2)+x(3,n3)+x(3,n4))*fourth
2187C
2188 hx=(x(1,n1)-x(1,n2)+x(1,n3)-x(1,n4))*fourth
2189 hy=(x(2,n1)-x(2,n2)+x(2,n3)-x(2,n4))*fourth
2190 hz=(x(3,n1)-x(3,n2)+x(3,n3)-x(3,n4))*fourth
2191C
2192 g1x(1)=ksix-pg*hx
2193 g1y(1)=ksiy-pg*hy
2194 g1z(1)=ksiz-pg*hz
2195 g1x(3)=ksix+pg*hx
2196 g1y(3)=ksiy+pg*hy
2197 g1z(3)=ksiz+pg*hz
2198 g1x(2)=g1x(1)
2199 g1y(2)=g1y(1)
2200 g1z(2)=g1z(1)
2201 g1x(4)=g1x(3)
2202 g1y(4)=g1y(3)
2203 g1z(4)=g1z(3)
2204C
2205 g2x(1)=etax-pg*hx
2206 g2y(1)=etay-pg*hy
2207 g2z(1)=etaz-pg*hz
2208 g2x(2)=etax+pg*hx
2209 g2y(2)=etay+pg*hy
2210 g2z(2)=etaz+pg*hz
2211 g2x(3)=g2x(2)
2212 g2y(3)=g2y(2)
2213 g2z(3)=g2z(2)
2214 g2x(4)=g2x(1)
2215 g2y(4)=g2y(1)
2216 g2z(4)=g2z(1)
2217C
2218C DO I =1,4
2219c CALL PRODUITV(G1X,G1Y,G1Z,G2X,G2Y,G2Z,DETA(I))
2220C END DO
2221C
2222 DO j =1,3
2223 DO k =j,3
2224 k11(j,k)=zero
2225 k22(j,k)=zero
2226 k33(j,k)=zero
2227 k44(j,k)=zero
2228 END DO
2229 END DO
2230C
2231 DO j =1,3
2232 DO k =1,3
2233 k12(j,k)=zero
2234 k13(j,k)=zero
2235 k14(j,k)=zero
2236 k23(j,k)=zero
2237 k24(j,k)=zero
2238 k34(j,k)=zero
2239 END DO
2240 END DO
2241C
2242 s1=half*p
2243 DO np =1,4
2244c K11(1,2)=K11(1,2) + S1*VF4(1,NP)*
2245c . (VETA(1,NP)*G2Z(NP)-VKSI(1,NP)*G1Z(NP))
2246c K11(1,3)=K11(1,3) - S1*VF4(1,NP)*
2247c . (VETA(1,NP)*G2Y(NP)-VKSI(1,NP)*G1Y(NP))
2248c K11(2,3)=K11(2,3) + S1*VF4(1,NP)*
2249c . (VETA(1,NP)*G2X(NP)-VKSI(1,NP)*G1X(NP))
2250c K22(1,2)=K22(1,2) + S1*VF4(2,NP)*
2251c . (VETA(2,NP)*G2Z(NP)-VKSI(2,NP)*G1Z(NP))
2252c K22(1,3)=K22(1,3) - S1*VF4(2,NP)*
2253c . (VETA(2,NP)*G2Y(NP)-VKSI(2,NP)*G1Y(NP))
2254c K22(2,3)=K22(2,3) + S1*VF4(2,NP)*
2255c . (VETA(2,NP)*G2X(NP)-VKSI(2,NP)*G1X(NP))
2256c K33(1,2)=K33(1,2) + S1*VF4(3,NP)*
2257c . (VETA(3,NP)*G2Z(NP)-VKSI(3,NP)*G1Z(NP))
2258c K33(1,3)=K33(1,3) - S1*VF4(3,NP)*
2259c . (VETA(3,NP)*G2Y(NP)-VKSI(3,NP)*G1Y(NP))
2260c K33(2,3)=K33(2,3) + S1*VF4(3,NP)*
2261c . (VETA(3,NP)*G2X(NP)-VKSI(3,NP)*G1X(NP))
2262c K44(1,2)=K44(1,2) + S1*VF4(4,NP)*
2263c . (VETA(4,NP)*G2Z(NP)-VKSI(4,NP)*G1Z(NP))
2264c K44(1,3)=K44(1,3) - S1*VF4(4,NP)*
2265c . (VETA(4,NP)*G2Y(NP)-VKSI(4,NP)*G1Y(NP))
2266c K44(2,3)=K44(2,3) + S1*VF4(4,NP)*
2267c . (VETA(4,NP)*G2X(NP)-VKSI(4,NP)*G1X(NP))
2268C
2269 k12(1,2)=k12(1,2) + s1*vf4(1,np)*
2270 . (vksi(2,np)*g2z(np)-veta(2,np)*g1z(np))
2271 k12(1,3)=k12(1,3) - s1*vf4(1,np)*
2272 . (vksi(2,np)*g2y(np)-veta(2,np)*g1y(np))
2273 k12(2,3)=k12(2,3) + s1*vf4(1,np)*
2274 . (vksi(2,np)*g2x(np)-veta(2,np)*g1x(np))
2275 k13(1,2)=k13(1,2) + s1*vf4(1,np)*
2276 . (vksi(3,np)*g2z(np)-veta(3,np)*g1z(np))
2277 k13(1,3)=k13(1,3) - s1*vf4(1,np)*
2278 . (vksi(3,np)*g2y(np)-veta(3,np)*g1y(np))
2279 k13(2,3)=k13(2,3) + s1*vf4(1,np)*
2280 . (vksi(3,np)*g2x(np)-veta(3,np)*g1x(np))
2281 k14(1,2)=k14(1,2) + s1*vf4(1,np)*
2282 . (vksi(4,np)*g2z(np)-veta(4,np)*g1z(np))
2283 k14(1,3)=k14(1,3) - s1*vf4(1,np)*
2284 . (vksi(4,np)*g2y(np)-veta(4,np)*g1y(np))
2285 k14(2,3)=k14(2,3) + s1*vf4(1,np)*
2286 . (vksi(4,np)*g2x(np)-veta(4,np)*g1x(np))
2287 k23(1,2)=k23(1,2) + s1*vf4(2,np)*
2288 . (vksi(3,np)*g2z(np)-veta(3,np)*g1z(np))
2289 k23(1,3)=k23(1,3) - s1*vf4(2,np)*
2290 . (vksi(3,np)*g2y(np)-veta(3,np)*g1y(np))
2291 k23(2,3)=k23(2,3) + s1*vf4(2,np)*
2292 . (vksi(3,np)*g2x(np)-veta(3,np)*g1x(np))
2293 k24(1,2)=k24(1,2) + s1*vf4(2,np)*
2294 . (vksi(4,np)*g2z(np)-veta(4,np)*g1z(np))
2295 k24(1,3)=k24(1,3) - s1*vf4(2,np)*
2296 . (vksi(4,np)*g2y(np)-veta(4,np)*g1y(np))
2297 k24(2,3)=k24(2,3) + s1*vf4(2,np)*
2298 . (vksi(4,np)*g2x(np)-veta(4,np)*g1x(np))
2299 k34(1,2)=k34(1,2) + s1*vf4(3,np)*
2300 . (vksi(4,np)*g2z(np)-veta(4,np)*g1z(np))
2301 k34(1,3)=k34(1,3) - s1*vf4(3,np)*
2302 . (vksi(4,np)*g2y(np)-veta(4,np)*g1y(np))
2303 k34(2,3)=k34(2,3) + s1*vf4(3,np)*
2304 . (vksi(4,np)*g2x(np)-veta(4,np)*g1x(np))
2305 END DO
2306C
2307 DO np =1,4
2308 k12(1,2)=k12(1,2) - s1*vf4(2,np)*
2309 . (vksi(1,np)*g2z(np)-veta(1,np)*g1z(np))
2310 k12(1,3)=k12(1,3) + s1*vf4(2,np)*
2311 . (vksi(1,np)*g2y(np)-veta(1,np)*g1y(np))
2312 k12(2,3)=k12(2,3) - s1*vf4(2,np)*
2313 . (vksi(1,np)*g2x(np)-veta(1,np)*g1x(np))
2314 k13(1,2)=k13(1,2) - s1*vf4(3,np)*
2315 . (vksi(1,np)*g2z(np)-veta(1,np)*g1z(np))
2316 k13(1,3)=k13(1,3) + s1*vf4(3,np)*
2317 . (vksi(1,np)*g2y(np)-veta(1,np)*g1y(np))
2318 k13(2,3)=k13(2,3) - s1*vf4(3,np)*
2319 . (vksi(1,np)*g2x(np)-veta(1,np)*g1x(np))
2320 k14(1,2)=k14(1,2) - s1*vf4(4,np)*
2321 . (vksi(1,np)*g2z(np)-veta(1,np)*g1z(np))
2322 k14(1,3)=k14(1,3) + s1*vf4(4,np)*
2323 . (vksi(1,np)*g2y(np)-veta(1,np)*g1y(np))
2324 k14(2,3)=k14(2,3) - s1*vf4(4,np)*
2325 . (vksi(1,np)*g2x(np)-veta(1,np)*g1x(np))
2326 k23(1,2)=k23(1,2) - s1*vf4(3,np)*
2327 . (vksi(2,np)*g2z(np)-veta(2,np)*g1z(np))
2328 k23(1,3)=k23(1,3) + s1*vf4(3,np)*
2329 . (vksi(2,np)*g2y(np)-veta(2,np)*g1y(np))
2330 k23(2,3)=k23(2,3) - s1*vf4(3,np)*
2331 . (vksi(2,np)*g2x(np)-veta(2,np)*g1x(np))
2332 k24(1,2)=k24(1,2) - s1*vf4(4,np)*
2333 . (vksi(2,np)*g2z(np)-veta(2,np)*g1z(np))
2334 k24(1,3)=k24(1,3) + s1*vf4(4,np)*
2335 . (vksi(2,np)*g2y(np)-veta(2,np)*g1y(np))
2336 k24(2,3)=k24(2,3) - s1*vf4(4,np)*
2337 . (vksi(2,np)*g2x(np)-veta(2,np)*g1x(np))
2338 k34(1,2)=k34(1,2) - s1*vf4(4,np)*
2339 . (vksi(3,np)*g2z(np)-veta(3,np)*g1z(np))
2340 k34(1,3)=k34(1,3) + s1*vf4(4,np)*
2341 . (vksi(3,np)*g2y(np)-veta(3,np)*g1y(np))
2342 k34(2,3)=k34(2,3) - s1*vf4(4,np)*
2343 . (vksi(3,np)*g2x(np)-veta(3,np)*g1x(np))
2344 END DO
2345 k12(2,1)=-k12(1,2)
2346 k12(3,1)=-k12(1,3)
2347 k12(3,2)=-k12(2,3)
2348 k13(2,1)=-k13(1,2)
2349 k13(3,1)=-k13(1,3)
2350 k13(3,2)=-k13(2,3)
2351 k14(2,1)=-k14(1,2)
2352 k14(3,1)=-k14(1,3)
2353 k14(3,2)=-k14(2,3)
2354 k23(2,1)=-k23(1,2)
2355 k23(3,1)=-k23(1,3)
2356 k23(3,2)=-k23(2,3)
2357 k24(2,1)=-k24(1,2)
2358 k24(3,1)=-k24(1,3)
2359 k24(3,2)=-k24(2,3)
2360 k34(2,1)=-k34(1,2)
2361 k34(3,1)=-k34(1,3)
2362 k34(3,2)=-k34(2,3)
2363C
2364 RETURN

◆ kptria()

subroutine kptria ( integer n1,
integer n2,
integer n3,
p,
x,
k11,
k22,
k33,
k12,
k13,
k23 )

Definition at line 2483 of file imp_glob_k.F.

2485C-----------------------------------------------
2486C I m p l i c i t T y p e s
2487C-----------------------------------------------
2488#include "implicit_f.inc"
2489C-----------------------------------------------
2490C C o m m o n B l o c k s
2491C-----------------------------------------------
2492C-----------------------------------------------------------------
2493C D u m m y A r g u m e n t s
2494C-----------------------------------------------
2495 INTEGER N1,N2,N3
2496 my_real
2497 . p,x(3,*),
2498 . k11(6,6),k22(6,6),k33(6,6),k12(6,6),
2499 . k13(6,6),k23(6,6)
2500C-----------------------------------------------
2501C L o c a l V a r i a b l e s
2502C-----------------------------------------------
2503 INTEGER I, J ,K
2504 my_real
2505 . x21,y21,z21,x31,y31,z31,s1,g1x,g1y,g1z,g2x,g2y,g2z
2506C
2507 x21=x(1,n2)-x(1,n1)
2508 y21=x(2,n2)-x(2,n1)
2509 z21=x(3,n2)-x(3,n1)
2510 x31=x(1,n3)-x(1,n1)
2511 y31=x(2,n3)-x(2,n1)
2512 z31=x(3,n3)-x(3,n1)
2513C
2514 g1x=x21
2515 g1y=y21
2516 g1z=z21
2517 g2x=x31
2518 g2y=y31
2519 g2z=z31
2520C CALL PRODUITV(G1X,G1Y,G1Z,G2X,G2Y,G2Z,DETA2)
2521 DO k =1,3
2522 k11(k,k)=zero
2523 k22(k,k)=zero
2524 k33(k,k)=zero
2525 k12(k,k)=zero
2526 k13(k,k)=zero
2527 k23(k,k)=zero
2528 END DO
2529C
2530 s1 = one_over_6*p*half
2531C K11(1,2)=-S1*(G2Z-G1Z)
2532C K11(1,3)=S1*(G2Y-G1Y)
2533C K11(2,3)=-S1*(G2X-G1X)
2534C K22(1,2)=S1*G2Z
2535C K22(1,3)=-S1*G2Y
2536C K22(2,3)=S1*G2X
2537C K33(1,2)=-S1*G1Z
2538C K33(1,3)=S1*G1Y
2539C K33(2,3)=-S1*G1X
2540 k11(1,2)=zero
2541 k11(1,3)=zero
2542 k11(2,3)=zero
2543 k22(1,2)=zero
2544 k22(1,3)=zero
2545 k22(2,3)=zero
2546 k33(1,2)=zero
2547 k33(1,3)=zero
2548 k33(2,3)=zero
2549C----------Kij(1,2) =0.5(Kij(1,2)+Kji(2,1))
2550 k12(1,2)=s1*(g2z+g2z-g1z)
2551 k12(1,3)=-s1*(g2y+g2y-g1y)
2552 k12(2,3)=s1*(g2x+g2x-g1x)
2553 k13(1,2)=-s1*(g1z-g2z+g1z)
2554 k13(1,3)=s1*(g1y-g2y+g1y)
2555 k13(2,3)=-s1*(g1x-g2x+g1x)
2556 k23(1,2)=-s1*(g1z+g2z)
2557 k23(1,3)=s1*(g1y+g2y)
2558 k23(2,3)=-s1*(g1x+g2x)
2559C
2560 k12(2,1)=-k12(1,2)
2561 k12(3,1)=-k12(1,3)
2562 k12(3,2)=-k12(2,3)
2563 k13(2,1)=-k13(1,2)
2564 k13(3,1)=-k13(1,3)
2565 k13(3,2)=-k13(2,3)
2566 k23(2,1)=-k23(1,2)
2567 k23(3,1)=-k23(1,3)
2568 k23(3,2)=-k23(2,3)
2569C
2570 RETURN

◆ print_wkij()

subroutine print_wkij ( integer ni,
integer nj,
integer iflag )

Definition at line 889 of file imp_glob_k.F.

890C-----------------------------------------------
891C I m p l i c i t T y p e s
892C-----------------------------------------------
893#include "implicit_f.inc"
894C-----------------------------------------------
895C C o m m o n B l o c k s
896C-----------------------------------------------
897#include "units_c.inc"
898C-----------------------------------------------
899C D u m m y A r g u m e n t s
900C-----------------------------------------------
901 INTEGER NI ,NJ ,IFLAG
902C REAL
903C-----------------------------------------------
904C L o c a l V a r i a b l e s
905C-----------------------------------------------
906 INTEGER I
907C-----------------------------------------------
908 IF (iflag==1) THEN
909 WRITE(iout,1001)ni,nj
910 WRITE(istdo,1001)ni,nj
911 ELSEIF (iflag==2) THEN
912 WRITE(iout,1002)ni,nj
913 WRITE(istdo,1002)ni,nj
914 ELSEIF (iflag==3) THEN
915 WRITE(iout,1003)ni,nj
916 WRITE(istdo,1003)ni,nj
917 ELSEIF (iflag==4) THEN
918 WRITE(iout,1004)ni,nj
919 WRITE(istdo,1004)ni,nj
920 ELSEIF (iflag==5) THEN
921 WRITE(iout,1005)ni,nj
922 WRITE(istdo,1005)ni,nj
923 ELSE
924 WRITE(iout,1000)ni,nj
925 WRITE(istdo,1000)ni,nj
926 ENDIF
927C----6---------------------------------------------------------------7---------8
928 1000 FORMAT(' *** WARNING : IN OPTION ? :'/,
929 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
930 1001 FORMAT(' *** WARNING : IN RIGID BODY CONDENSATION:'/,
931 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
932 1002 FORMAT(' *** WARNING : IN INTERFACE TYPE 2 CONDENSATION:'/,
933 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
934 1003 FORMAT(' *** WARNING : IN REMESH KINEMATIC CONDENSATION:'/,
935 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
936 1004 FORMAT(' *** WARNING : IN RBE3 CONDENSATION:'/,
937 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
938 1005 FORMAT(' *** WARNING : IN RBE2 CONDENSATION:'/,
939 . '*** NO CONNECTIVITY BETWEEN NODES:',2i10)
940 RETURN

◆ produitv()

subroutine produitv ( rx,
ry,
rz,
sx,
sy,
sz,
det )

Definition at line 2369 of file imp_glob_k.F.

2370C-----------------------------------------------
2371C I m p l i c i t T y p e s
2372C-----------------------------------------------
2373#include "implicit_f.inc"
2374C-----------------------------------------------
2375C D u m m y A r g u m e n t s
2376C-----------------------------------------------
2377C REAL
2378 my_real
2379 . rx , ry , rz,sx , sy, sz, det
2380C-----------------------------------------------
2381C L o c a l V a r i a b l e s
2382C-----------------------------------------------
2383 INTEGER I
2384C REAL
2385C 12
2386 my_real
2387 . e3x,e3y,e3z
2388 e3x = ry * sz - rz * sy
2389 e3y = rz * sx - rx * sz
2390 e3z = rx * sy - ry * sx
2391 det= sqrt(e3x*e3x + e3y*e3y + e3z*e3z)
2392C
2393 RETURN

◆ put_kii()

subroutine put_kii ( integer ni,
integer, dimension(*) iddl,
integer, dimension(*) iadk,
k_diag,
k_lt,
kii,
integer nd )

Definition at line 652 of file imp_glob_k.F.

653C-----------------------------------------------
654C I m p l i c i t T y p e s
655C-----------------------------------------------
656#include "implicit_f.inc"
657C-----------------------------------------------
658C C o m m o n B l o c k s
659C-----------------------------------------------
660#include "impl1_c.inc"
661C-----------------------------------------------
662C D u m m y A r g u m e n t s
663C-----------------------------------------------
664 INTEGER ND
665 INTEGER NI,IDDL(*) ,IADK(*)
666C REAL
667 my_real
668 . k_diag(*) ,k_lt(*) ,kii(6,6)
669C-----------------------------------------------
670C L o c a l V a r i a b l e s
671C-----------------------------------------------
672 INTEGER K,IK,ID,JD,L
673C----6----------KII is always triag_sup whatever IKPAT------------------------
674 id = iddl(ni)
675 IF (ikpat==0) THEN
676 DO k=1,nd
677 k_diag(id+k) = k_diag(id+k) + kii(k,k)
678 jd = iadk(id+k)-1
679 DO l=k+1,nd
680 ik = jd+l-k
681 k_lt(ik) = k_lt(ik) + kii(k,l)
682 ENDDO
683 ENDDO
684 ELSE
685 DO k=1,nd
686 k_diag(id+k) = k_diag(id+k) + kii(k,k)
687 jd = iadk(id+k+1)-k
688 DO l=1,k-1
689 ik = jd+l
690 k_lt(ik) = k_lt(ik) + kii(l,k)
691 ENDDO
692 ENDDO
693 ENDIF
694C
695 RETURN

◆ put_kij()

subroutine put_kij ( integer ni,
integer nj,
integer, dimension(*) iddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
k_lt,
kij,
integer nk,
integer nl,
integer ierr )

Definition at line 808 of file imp_glob_k.F.

810C-----------------------------------------------
811C I m p l i c i t T y p e s
812C-----------------------------------------------
813#include "implicit_f.inc"
814C-----------------------------------------------
815C C o m m o n B l o c k s
816C-----------------------------------------------
817#include "impl1_c.inc"
818C-----------------------------------------------
819C D u m m y A r g u m e n t s
820C-----------------------------------------------
821 INTEGER NK,NL ,IERR
822 INTEGER NI,NJ,IDDL(*) ,IADK(*),JDIK(*)
823C REAL
824 my_real
825 . k_lt(*) ,kij(6,6)
826C-----------------------------------------------
827C L o c a l V a r i a b l e s
828C-----------------------------------------------
829 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ
830C----6---------------------------------------------------------------7---------8
831 ierr = 0
832 i = iddl(ni)
833 j = iddl(nj)
834 IF (ikpat==0) THEN
835 id = min(i,j)
836 jd = max(i,j)+1
837 ELSE
838 id = max(i,j)
839 jd = min(i,j)+1
840 ENDIF
841 IF (i==id) THEN
842 DO k=1,nk
843 DO jj = iadk(id+k),iadk(id+1+k)-1
844C---------find l'adress dans LT-----
845 IF (jdik(jj)==jd) THEN
846 jdl = jj-1
847 GOTO 100
848 ENDIF
849 ENDDO
850 ierr = 1
851 RETURN
852 100 DO l=1,nl
853 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l)
854 ENDDO
855 ENDDO
856 ELSE
857 DO k=1,nl
858 DO jj = iadk(id+k),iadk(id+1+k)-1
859 IF (jdik(jj)==jd) THEN
860 jdl = jj-1
861 GOTO 200
862 ENDIF
863 ENDDO
864 ierr = 1
865 RETURN
866 200 DO l=1,nk
867 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k)
868 ENDDO
869 ENDDO
870 ENDIF
871C----6---------------------------------------------------------------7---------8
872 RETURN

◆ put_kmii()

subroutine put_kmii ( integer id,
integer, dimension(*) iadk,
k_diag,
k_lt,
kii,
integer nd )

Definition at line 1184 of file imp_glob_k.F.

1186C-----------------------------------------------
1187C I m p l i c i t T y p e s
1188C-----------------------------------------------
1189#include "implicit_f.inc"
1190C-----------------------------------------------
1191C C o m m o n B l o c k s
1192C-----------------------------------------------
1193#include "impl1_c.inc"
1194C-----------------------------------------------
1195C D u m m y A r g u m e n t s
1196C-----------------------------------------------
1197 INTEGER ND
1198 INTEGER ID,IADK(*)
1199C REAL
1200 my_real
1201 . k_diag(*) ,k_lt(*) ,kii(6,6)
1202C-----------------------------------------------
1203C L o c a l V a r i a b l e s
1204C-----------------------------------------------
1205 INTEGER K,IK,JD,L,IDM
1206C----6----------KII is always triag_sup whatever IKPAT------------------------
1207 IF (ikpat==0) THEN
1208 DO k=1,nd
1209 k_diag(id+k) = k_diag(id+k) + kii(k,k)
1210 jd = iadk(id+k)-1
1211 DO l=k+1,nd
1212 ik = jd+l-k
1213 k_lt(ik) = k_lt(ik) + kii(k,l)
1214 ENDDO
1215 ENDDO
1216 ELSE
1217 DO k=1,nd
1218 k_diag(id+k) = k_diag(id+k) + kii(k,k)
1219 jd = iadk(id+k+1)-k
1220 DO l=1,k-1
1221 ik = jd+l
1222 k_lt(ik) = k_lt(ik) + kii(l,k)
1223 ENDDO
1224 ENDDO
1225 ENDIF
1226C
1227 RETURN

◆ put_kmij()

subroutine put_kmij ( integer ini,
integer inj,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
k_lt,
kij,
integer nk,
integer nl,
integer ierr )

Definition at line 1236 of file imp_glob_k.F.

1238C-----------------------------------------------
1239C I m p l i c i t T y p e s
1240C-----------------------------------------------
1241#include "implicit_f.inc"
1242C-----------------------------------------------
1243C C o m m o n B l o c k s
1244C-----------------------------------------------
1245#include "impl1_c.inc"
1246C-----------------------------------------------
1247C D u m m y A r g u m e n t s
1248C-----------------------------------------------
1249 INTEGER NK,NL ,IERR
1250 INTEGER INI,INJ,IADK(*),JDIK(*)
1251C REAL
1252 my_real
1253 . k_lt(*) ,kij(6,6)
1254C-----------------------------------------------
1255C L o c a l V a r i a b l e s
1256C-----------------------------------------------
1257 INTEGER I,J,K,EP,ID,JD,JDL,L,JJ
1258C----6---------------------------------------------------------------7---------8
1259 ierr = 0
1260 i = ini
1261 j = inj
1262 IF (ikpat==0) THEN
1263 id = min(i,j)
1264 jd = max(i,j)+1
1265 ELSE
1266 id = max(i,j)
1267 jd = min(i,j)+1
1268 ENDIF
1269 IF (i==id) THEN
1270 DO k=1,nk
1271 DO jj = iadk(id+k),iadk(id+1+k)-1
1272C---------find l'adress dans LT-----
1273 IF (jdik(jj)==jd) THEN
1274 jdl = jj-1
1275 GOTO 100
1276 ENDIF
1277 ENDDO
1278 ierr = 1
1279 RETURN
1280 100 DO l=1,nl
1281 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l)
1282 ENDDO
1283 ENDDO
1284 ELSE
1285 DO k=1,nl
1286 DO jj = iadk(id+k),iadk(id+1+k)-1
1287 IF (jdik(jj)==jd) THEN
1288 jdl = jj-1
1289 GOTO 200
1290 ENDIF
1291 ENDDO
1292 ierr = 1
1293 RETURN
1294 200 DO l=1,nk
1295 k_lt(jdl+l) = k_lt(jdl+l) + kij(l,k)
1296 ENDDO
1297 ENDDO
1298 ENDIF
1299C----6---------------------------------------------------------------7---------8
1300 RETURN

◆ writekc()

subroutine writekc ( integer in,
integer nft,
integer nel,
integer, dimension(*) ig,
character ch,
kij )

Definition at line 1480 of file imp_glob_k.F.

1481C-----------------------------------------------
1482C I m p l i c i t T y p e s
1483C-----------------------------------------------
1484#include "implicit_f.inc"
1485C-----------------------------------------------
1486C D u m m y A r g u m e n t s
1487C-----------------------------------------------
1488 INTEGER IG(*),NFT,NEL,IN
1489 CHARACTER CH*3
1490C REAL
1491 my_real
1492 . kij(6,6,*)
1493C-----------------------------------------------
1494C L o c a l V a r i a b l e s
1495C-----------------------------------------------
1496 INTEGER I,J,N,NT
1497 CHARACTER KEY*10,KEY1*23
1498C-----------------------------------------------
1499 key='/SHELL_'//ch
1500 key1='#3d Shell Elements '//ch
1501 WRITE(in,'(A)') key
1502 WRITE(in,'(A)')key1
1503 WRITE(in,'(A)')
1504 . '#FORMAT: (2I8,1P4E16.9,6(/,1P5E16.9),/,1P2E16.9) '
1505 WRITE(in,'(2A)')'#SYSSHEL USRSHEL K(I,J) I=1,6;J=1,6'
1506 DO n= 1,nel
1507 nt=n+nft
1508 WRITE(in,'(2I8,1P4E16.9,6(/,1P5E16.9),/,1P2E16.9)'
1509 . )nt,ig(n),((kij(i,j,n),i=1,6),j=1,6)
1510 ENDDO
1511 RETURN

◆ writeki()

subroutine writeki ( integer in,
integer nft,
integer nel,
integer, dimension(*) ig,
character ch,
kij )

Definition at line 1634 of file imp_glob_k.F.

1635C-----------------------------------------------
1636C I m p l i c i t T y p e s
1637C-----------------------------------------------
1638#include "implicit_f.inc"
1639C-----------------------------------------------
1640C D u m m y A r g u m e n t s
1641C-----------------------------------------------
1642 INTEGER IG(*),NFT,NEL,IN
1643 CHARACTER CH*3
1644C REAL
1645 my_real
1646 . kij(6,6,*)
1647C-----------------------------------------------
1648C L o c a l V a r i a b l e s
1649C-----------------------------------------------
1650 INTEGER I,J,N,NT
1651 CHARACTER KEY*10,KEY1*23
1652C-----------------------------------------------
1653 key='/TRUSS_'//ch
1654 key1='#3d TRUSS Elements '//ch
1655 WRITE(in,'(A)') key
1656 WRITE(in,'(A)')key1
1657 WRITE(in,'(A)')
1658 . '#FORMAT: (2I8,1P4E16.9,6(/,1P5E16.9)) '
1659 WRITE(in,'(2A)')'#SYSSHEL USRSHEL K(I,J) I=1,3;J=1,3'
1660 DO n= 1,nel
1661 nt=n+nft
1662 WRITE(in,'(2I8,1P4E16.9,6(/,1P5E16.9))'
1663 . )nt,ig(n),((kij(i,j,n),i=1,3),j=1,3)
1664 ENDDO
1665 RETURN

◆ writekp()

subroutine writekp ( integer in,
integer nft,
integer nel,
integer, dimension(*) ig,
character ch,
kij )

Definition at line 1557 of file imp_glob_k.F.

1558C-----------------------------------------------
1559C I m p l i c i t T y p e s
1560C-----------------------------------------------
1561#include "implicit_f.inc"
1562C-----------------------------------------------
1563C D u m m y A r g u m e n t s
1564C-----------------------------------------------
1565 INTEGER IG(*),NFT,NEL,IN
1566 CHARACTER CH*3
1567C REAL
1568 my_real
1569 . kij(6,6,*)
1570C-----------------------------------------------
1571C L o c a l V a r i a b l e s
1572C-----------------------------------------------
1573 INTEGER I,J,N,NT
1574 CHARACTER KEY*10,KEY1*23
1575C-----------------------------------------------
1576 key='/BEAM_'//ch
1577 key1='#3d Beam Elements '//ch
1578 WRITE(in,'(A)') key
1579 WRITE(in,'(A)')key1
1580 WRITE(in,'(A)')
1581 . '#FORMAT: (2I8,1P4E16.9,6(/,1P5E16.9),/,1P2E16.9) '
1582 WRITE(in,'(2A)')'#SYSSHEL USRSHEL K(I,J) I=1,6;J=1,6'
1583 DO n= 1,nel
1584 nt=n+nft
1585 WRITE(in,'(2I8,1P4E16.9,6(/,1P5E16.9),/,1P2E16.9)'
1586 . )nt,ig(n),((kij(i,j,n),i=1,6),j=1,6)
1587 ENDDO
1588 RETURN

◆ writeks()

subroutine writeks ( integer in,
integer nft,
integer nel,
integer, dimension(*) ig,
character ch,
kij )

Definition at line 1392 of file imp_glob_k.F.

1393C-----------------------------------------------
1394C I m p l i c i t T y p e s
1395C-----------------------------------------------
1396#include "implicit_f.inc"
1397C-----------------------------------------------
1398C D u m m y A r g u m e n t s
1399C-----------------------------------------------
1400 INTEGER IG(*),NFT,NEL,IN
1401 CHARACTER CH*3
1402C REAL
1403 my_real
1404 . kij(3,3,*)
1405C-----------------------------------------------
1406C L o c a l V a r i a b l e s
1407C-----------------------------------------------
1408 INTEGER I,J,N,NT
1409 CHARACTER KEY*10,KEY1*23
1410C-----------------------------------------------
1411 key='/SOLID_'//ch
1412 key1='#3d Solid Elements '//ch
1413 WRITE(in,'(A)') key
1414 WRITE(in,'(A)')key1
1415 WRITE(in,'(A)')
1416 . '#FORMAT: (2I8,1P4E16.9,6(/,1P5E16.9)) '
1417 WRITE(in,'(2A)')'# SYSSOL USRSOL K(I,J) I=1,3;J=1,3'
1418 DO n= 1,nel
1419 nt=n+nft
1420 WRITE(in,'(2I8,1P4E16.9,6(/,1P5E16.9))'
1421 . )nt,ig(n),((kij(i,j,n),i=1,3),j=1,3)
1422 ENDDO
1423 RETURN