OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
bc_imp0.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "com01_c.inc"
#include "param_c.inc"
#include "impl1_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine bc_imp0 (icodt, icodr, iskew, ifix, ndof, iadn)
subroutine bc_imp1 (icodt, icodr, iskew, skew, ifix, ndof, iadn, iadk, jdik, diag_k, lt_k)
subroutine bcl_impk (ict, isk, skew, ifix, iadn, iadk, jdik, diag_k, lt_k, i, nd, ir)
subroutine l_dir0 (ej, j)
subroutine l_dir (ej, j)
subroutine l_dir2 (ej, j, j0)
subroutine bc_updk (n, iddl, ej, jj, ir, iadk, jdik, diag_k, lt_k)
subroutine bc_imp2 (icodt, icodr, iskew, skew, ndof, d, dr)
subroutine bcl_impd (ict, isk, skew, i, d)
subroutine bc_updd (n, ej, j, d)
subroutine bc_updd2 (n, ej, j, ej1, j1, d)
subroutine bcl_impkd (ict, isk, skew, kdd, diag_k)
subroutine bc_updf (nbc, ibc, skew, a)
subroutine bc_fi (n, ej, j1, a)
subroutine bc_updb (id, ej, jj, ir, lb)
subroutine bc_impr1 (icodt, icodr, iskew, skew, ndof, iadn, lb)
subroutine bcl_impb (ict, isk, skew, nd, lb, ir)
subroutine bc_updfr (n, iddl, ej, jj, iddlm, ikc, iadk, jdik, diag_k, lt_k, lb, a, kss, ksm, idlm, ifss, ifsm)
subroutine bcl_frk (n, iddl, iddlm, ict, isk, skew, ikc, iadk, jdik, diag_k, lt_k, lb, a, kss, ksm, idlm, ifss, ifsm)
subroutine bc_impa (iadk, jdik, diag_k, lt_k, ndof, iddl, ikc)
subroutine clceig (amtx, eigval, eigvec, small, nmtx, ierr)
subroutine autspc (kii, ideg, raspcc, smleig, nddl, ikc, naspcc, lauspc, ierr)
subroutine nrmlzauspc (vector, smleig, length, nzero)
subroutine spc_dir (ikc, j, j1)
subroutine upd_aspc0 (nddl, ndof, iddl, ikc, itab, iadk, jdik, diag_k, lt_k)
subroutine upd_aspc (nddl, ndof, iddl, ikc, itab, iadk, jdik, diag_k, lt_k)
subroutine bc_updk2d (iadn, ifix, skew, skew1, i, ir, kc, iadk, jdik, diag_k, lt_k)
subroutine bc_updf2d (nd, skew, skew1, ir, b)
subroutine bc_upd2d (n, skew, skew1, d)
subroutine fv_updkd2 (skew, skew1, kdd, diag_k)
subroutine bc_fi2 (n, skew, skew1, a)
subroutine bc_updfr2 (n, iddl, skew, skew1, iddlm, ikc, iadk, jdik, diag_k, lt_k, lb, a, kss, ksm, idlm, ifss, ifsm)
subroutine get_nspc (nspc)
subroutine put_nspc (nspc)
subroutine bc_c2d (ej, ej1, j, j1, ea, eb)

Function/Subroutine Documentation

◆ autspc()

subroutine autspc ( kii,
integer, dimension(3) ideg,
raspcc,
smleig,
integer nddl,
integer, dimension(3) ikc,
integer naspcc,
integer lauspc,
integer ierr )

Definition at line 1779 of file bc_imp0.F.

1781C-----------------------------------------------
1782C --- based on AUTSPC of OS----
1783C
1784C PURPOSE:
1785C
1786C RETRIEVE THE STIFFNESS MATRIX (MAX. DIMENSION OF 3X3)
1787C CORRESPONDING TO THE SPECIFIED D.O.F.S OF CURRENT GRID POINT,
1788C CALCULATE ITS EIGENVALUES TO IDENTIFY AUTO-SPC D.O.F.
1789C CANDIDATES
1790C
1791C INPUT:
1792C
1793C KII(3,3) - NODAL GLOBAL STIFFNESS MATRIX (TRA. OR ROT.)
1794C IDEG(3) - IDDL ARRAY
1795C SMLEIG - VALUE BELOW WHICH EIGENVALUE IS CONSIDERED = 0
1796C NDDL - NUMBER OF EQUATIONS
1797C
1798C OUTPUT:
1799C
1800C NASPCC (0-2) - DIMENSION OF AUTO-SPC WITH LOCAL DIRECTION
1801C RASPCC(6) - EIGENVECTORS OF FREE D.O.F.S WITH RIGID MODES
1802C LAUSPC (0-3) - TOTAL NUMBER OF D.O.F.S THAT HAVE AUTO-SPC
1803C IERR - ERROR SWITCH
1804C = 0 - NO ERROR ENCOUNTERED
1805C > 0 - ERROR ENCOUNTERED
1806C
1807C-----------------------------------------------
1808C I m p l i c i t T y p e s
1809C-----------------------------------------------
1810#include "implicit_f.inc"
1811C-----------------------------------------------
1812C D u m m y A r g u m e n t s
1813C-----------------------------------------------
1814 INTEGER NDDL, NASPCC, LAUSPC,N,IERR
1815 INTEGER IDEG(3), IKC(3)
1816 my_real
1817 * kii(3,3), raspcc(*), smleig
1818C-----------------------------------------------
1819C L o c a l V a r i a b l e s
1820C-----------------------------------------------
1821 my_real
1822 * amtx(9), copy(9)
1823 INTEGER IDMTX,JDMTX,KDMTX,NZERO
1824 INTEGER I, J, IND, IHIGH, NMTX, IEQ, ID(3)
1825 my_real
1826 * eigvec(9), eigval(3), high,nom
1827C
1828C INITIALIZE GRID MATRIX DATA TO ZERO
1829C
1830 nmtx = 0
1831 lauspc = 0
1832 naspcc = 0
1833 ierr = 0
1834C
1835C GET THE FREE DEGREES OF FREEDOM
1836C
1837 DO i = 1,3
1838 IF (ideg(i) <= nddl .AND. ikc(i) == 0 ) THEN
1839 nmtx = nmtx + 1
1840 id(nmtx) = i
1841 ENDIF
1842 ENDDO
1843C
1844 IF (nmtx == 0) GOTO 999
1845C
1846
1847 CALL zero1(eigval,3)
1848
1849C================================== ONE DOF
1850 IF (nmtx == 1) THEN
1851C
1852C IF GRID POINT HAS ONE FREE D.O.F., GET THE 1X1 MATRIX
1853C
1854 idmtx=id(nmtx)
1855 amtx(1) = kii(idmtx,idmtx)
1856C
1857C IF THERE IS A RIGID BODY MODE, UPDATE AUTO-SPC CANDIDATE ARRAY
1858C
1859 IF (abs(amtx(1)) <= em10 ) THEN
1860 lauspc = lauspc + 1
1861 ikc(idmtx) = 14
1862 ENDIF
1863C
1864C================================== TWO DOF
1865 ELSEIF (nmtx == 2) THEN
1866C
1867C IF GRID POINT HAS TWO FREE D.O.F.S, GET THE 2X2 MATRIX
1868C
1869 CALL zero1(amtx,4)
1870 CALL zero1(eigvec,4)
1871 idmtx=id(1)
1872 jdmtx=id(2)
1873 amtx(1) = kii(idmtx,idmtx)
1874 amtx(3) = kii(idmtx,jdmtx)
1875 amtx(4) = kii(jdmtx,jdmtx)
1876 amtx(2) = amtx(3)
1877C
1878C CALCULATE EIGENVALUES AND IF THERE ARE RIGID BODY MODES, UPDATE
1879C AUTO-SPC CANDIDATE ARRAY - THE D.O.F IN EACH RIGID BODY MODE
1880C WHICH HAS THE HIGHEST COMPONENT WITHIN ITS EIGEN VECTOR IS THE
1881C ONE TO BE UPDATED
1882C
1883 CALL clceig(amtx,eigval,eigvec,smleig,nmtx,ierr)
1884 IF (ierr /= 0) GOTO 999
1885C
1886C NORMALIZE EIGENVALUES BASED ON MAXIMUM EIGENVALUE
1887C
1888 CALL nrmlzauspc(eigval,smleig,2,nzero)
1889C
1890C IF BOTH EIGENVALUES ARE ZERO, IKC=14
1891C
1892 IF (nzero == 2) THEN
1893 DO i = 1 , nmtx
1894 lauspc = lauspc + 1
1895 ikc(id(i)) = 14
1896 ENDDO
1897 ELSEIF (nzero == 1) THEN
1898 DO 100 i = 1, nmtx
1899 IF ( eigval(i) < smleig ) THEN
1900 lauspc = lauspc + 1
1901 ind = 2*i-1
1902 high = max(abs(eigvec(ind)),eigvec(abs(ind+1)))
1903 IF (abs(high-one)<smleig) THEN
1904 ikc(id(i)) = 14
1905 ELSE
1906 ikc(id(i)) = 15
1907 naspcc =naspcc +1
1908 raspcc(id(1)) = eigvec(ind)
1909 raspcc(id(2)) = eigvec(ind+1)
1910 ENDIF
1911 ENDIF
1912 100 CONTINUE
1913 ENDIF
1914C
1915C================================== THREE DOF
1916 ELSEIF (nmtx == 3) THEN
1917C
1918C IF GRID POINT HAS THREE FREE D.O.F.S, FILL THE AMTX MATRIX
1919C
1920 CALL zero1(eigvec,9)
1921C
1922C CALCULATE EIGENVALUES AND IF THERE ARE RIGID BODY MODES, UPDATE
1923C AUTO-SPC CANDIDATE ARRAY - THE D.O.F IN EACH RIGID BODY MODE
1924C WHICH HAS THE HIGHEST COMPONENT WITHIN ITS EIGEN VECTOR IS THE
1925C ONE TO BE UPDATED
1926C
1927 CALL clceig(kii,eigval,eigvec,smleig,nmtx,ierr)
1928 IF (ierr /= 0) GOTO 999
1929c
1930 DO i = 1, nmtx
1931 copy(i)=eigval(i)
1932 ENDDO
1933C
1934C NORMALIZE EIGENVALUES BASED ON MAXIMUM EIGENVALUE
1935C
1936 CALL nrmlzauspc(eigval,smleig,3,nzero)
1937C
1938 IF (nzero == 3) THEN
1939 DO i = 1 , nmtx
1940 lauspc = lauspc + 1
1941 ikc(i) = 14
1942 ENDDO
1943 ELSEIF (nzero == 2) THEN
1944 high = zero
1945 DO i = 1, nmtx
1946 IF ( eigval(i) < smleig ) THEN
1947 lauspc = lauspc + 1
1948 ind = 3*i-2
1949 DO j=0,2
1950 high = max(high,abs(eigvec(ind+j)))
1951 ENDDO
1952 ENDIF
1953 ENDDO
1954C STILL GLOBAL SYSTEM
1955 IF (abs(high-one)<smleig) THEN
1956 DO i = 1, nmtx
1957 IF ( eigval(i) < smleig ) ikc(i) = 14
1958 ENDDO
1959 ELSE
1960 DO i = 1, nmtx
1961 IF ( eigval(i) < smleig ) THEN
1962 naspcc =naspcc +1
1963 ikc(i) = 15
1964 ind = 3*i-2
1965 ieq = 3*(naspcc-1)
1966 raspcc(ieq+1) = eigvec(ind)
1967 raspcc(ieq+2) = eigvec(ind+1)
1968 raspcc(ieq+3) = eigvec(ind+2)
1969 ENDIF
1970 ENDDO
1971 ENDIF
1972 ELSEIF (nzero == 1) THEN
1973 DO i = 1, nmtx
1974 IF ( eigval(i) < smleig ) THEN
1975 lauspc = lauspc + 1
1976 ind = 3*i-2
1977 high = max(eigvec(ind),eigvec(ind+1),eigvec(ind+2))
1978 IF (abs(high-one)<smleig) THEN
1979 ikc(i) = 14
1980 ELSE
1981 naspcc =naspcc +1
1982 ikc(i) = 15
1983 raspcc(1) = eigvec(ind)
1984 raspcc(2) = eigvec(ind+1)
1985 raspcc(3) = eigvec(ind+2)
1986 ENDIF
1987 ENDIF
1988 ENDDO
1989 ENDIF
1990 ENDIF
1991C
1992 999 CONTINUE
1993C
1994 RETURN
nrmlzauspc
subroutine nrmlzauspc(vector, smleig, length, nzero)
Definition bc_imp0.F:2004
clceig
subroutine clceig(amtx, eigval, eigvec, small, nmtx, ierr)
Definition bc_imp0.F:1557
my_real
#define my_real
Definition cppsort.cpp:32
zero1
subroutine zero1(r, n)
Definition hm_read_rbe3.F:1481
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4

◆ bc_c2d()

subroutine bc_c2d ( ej,
ej1,
integer j,
integer j1,
ea,
eb )

Definition at line 2739 of file bc_imp0.F.

2740C-----------------------------------------------
2741C I m p l i c i t T y p e s
2742C-----------------------------------------------
2743#include "implicit_f.inc"
2744C-----------------------------------------------
2745C D u m m y A r g u m e n t s
2746C-----------------------------------------------
2747 INTEGER J, J1
2748 my_real
2749 . ej(3),ej1(3),ea,eb
2750C-----------------------------------------------
2751C L o c a l V a r i a b l e s
2752C-----------------------------------------------
2753 INTEGER K
2754 my_real
2755 . det
2756C---------set up Matrix C=-(EA,EB) for BC local 2 dir
2757C-----determine ind dir K
2758 CALL gdir2_ind(ej,ej1,k)
2759 j = k +1
2760 IF (j >3) j= j-3
2761 j1 = k +2
2762 IF (j1 >3) j1= j1-3
2763 det = one/(ej(j)*ej1(j1)-ej(j1)*ej1(j))
2764 ea = det*(ej1(j1)*ej(k)-ej(j1)*ej1(k))
2765 eb = det*(ej(j)*ej1(k)-ej1(j)*ej(k))
2766 RETURN
gdir2_ind
subroutine gdir2_ind(ei, ej, k)
Definition fv_imp0.F:3485

◆ bc_fi()

subroutine bc_fi ( integer n,
ej,
integer j1,
a )

Definition at line 1035 of file bc_imp0.F.

1036C-----------------------------------------------
1037C I m p l i c i t T y p e s
1038C-----------------------------------------------
1039#include "implicit_f.inc"
1040C-----------------------------------------------
1041C D u m m y A r g u m e n t s
1042C-----------------------------------------------
1043 INTEGER J1,N
1044 my_real
1045 . a(3,*),ej(3)
1046C-----------------------------------------------
1047C L o c a l V a r i a b l e s
1048C-----------------------------------------------
1049 INTEGER K,L
1050C-----------------------------------------------
1051 k = j1 + 1
1052 IF (k>3) k = k - 3
1053 l = j1 + 2
1054 IF (l>3) l = l - 3
1055 a(k,n)=a(k,n)-ej(k)*a(j1,n)
1056 a(l,n)=a(l,n)-ej(l)*a(j1,n)
1057C
1058 RETURN

◆ bc_fi2()

subroutine bc_fi2 ( integer n,
skew,
skew1,
a )

Definition at line 2561 of file bc_imp0.F.

2562C-----------------------------------------------
2563C I m p l i c i t T y p e s
2564C-----------------------------------------------
2565#include "implicit_f.inc"
2566C-----------------------------------------------
2567C D u m m y A r g u m e n t s
2568C-----------------------------------------------
2569 INTEGER N
2570 my_real
2571 . a(3,*),skew(3),skew1(3)
2572C-----------------------------------------------
2573C L o c a l V a r i a b l e s
2574C-----------------------------------------------
2575 INTEGER K,L,J,J1
2576 my_real
2577 . ej(3),ej1(3),s,ea,eb
2578C-----------------------------------------------
2579 ej(1)=skew(1)
2580 ej(2)=skew(2)
2581 ej(3)=skew(3)
2582c CALL L_DIR(EJ,J)
2583 ej1(1)=skew1(1)
2584 ej1(2)=skew1(2)
2585 ej1(3)=skew1(3)
2586 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
2587 CALL dir_rbe2(j ,j1 ,k )
2588 ea = -ea
2589 eb = -eb
2590c S=ONE/(ONE-EJ(J1)*EJ1(J))
2591c EA=S*(EJ(J1)*EJ1(K)-EJ(K))
2592c EB=S*(EJ1(J)*EJ(K)-EJ1(K))
2593C
2594 a(k,n)=a(k,n)+ea*a(j,n)+eb*a(j1,n)
2595C
2596 RETURN
bc_c2d
subroutine bc_c2d(ej, ej1, j, j1, ea, eb)
Definition bc_imp0.F:2740
dir_rbe2
subroutine dir_rbe2(j, j1, k)
Definition rbe2v.F:714

◆ bc_imp0()

subroutine bc_imp0 ( integer, dimension(*) icodt,
integer, dimension(*) icodr,
integer, dimension(*) iskew,
integer, dimension(*) ifix,
integer, dimension(*) ndof,
integer, dimension(*) iadn )

Definition at line 30 of file bc_imp0.F.

31C-----------------------------------------------
32C I m p l i c i t T y p e s
33C-----------------------------------------------
34#include "implicit_f.inc"
35C-----------------------------------------------
36C C o m m o n B l o c k s
37C-----------------------------------------------
38#include "com04_c.inc"
39#include "com01_c.inc"
40C-----------------------------------------------
41C D u m m y A r g u m e n t s
42C-----------------------------------------------
43 INTEGER ICODT(*),ICODR(*),ISKEW(*),IFIX(*),
44 . NDOF(*),IADN(*)
45C-----------------------------------------------
46C L o c a l V a r i a b l e s
47C-----------------------------------------------
48 INTEGER I, ISK, ICT,ICR,J,K,NFIX,ND
49C----------------BC-------------------------
50Ccw FIX X-DOF FOR 2D CASE
51 IF (n2d/=0) THEN
52 DO i = 1,numnod
53C IF (ICODT(I)<4) THEN
54C ICODT(I) = ICODT(I) + 4
55C ENDIF
56 IF (ndof(i)>0) THEN
57 nd = iadn(i)
58 ifix(nd+1) = 1
59 ENDIF
60 ENDDO
61 ENDIF
62 IF (iroddl==0) THEN
63 DO i = 1,numnod
64 isk = iskew(i)
65 IF (isk==1) THEN
66 ict = icodt(i)
67 k = ndof(i)
68 nd = iadn(i)
69 IF (ict > 0 .AND. k> 0) THEN
70 IF (ict == 4 .AND. k>2) THEN
71 ifix(nd +1) = 1
72 ELSEIF (ict == 2) THEN
73 ifix(nd +2) = 1
74 ELSEIF (ict == 1) THEN
75 ifix(nd +3) = 1
76 ELSEIF (ict == 3) THEN
77 ifix(nd +2) = 1
78 ifix(nd +3) = 1
79 ELSEIF (ict == 5) THEN
80 IF (k>2) ifix(nd +1) = 1
81 ifix(nd +3) = 1
82 ELSEIF (ict == 6) THEN
83 IF (k>2) ifix(nd +1) = 1
84 ifix(nd +2) = 1
85 ELSEIF (ict == 7) THEN
86 IF (k>2) ifix(nd +1) = 1
87 ifix(nd +2) = 1
88 ifix(nd +3) = 1
89 ENDIF
90 ENDIF
91 ENDIF
92 ENDDO
93 ELSE
94 DO i = 1,numnod
95 isk = iskew(i)
96 IF (isk==1) THEN
97 ict = icodt(i)
98 icr = icodr(i)
99 k = ndof(i)
100 nd = iadn(i)
101 IF (ict > 0 .AND. k> 0) THEN
102 IF (ict == 4 .AND. k>2) THEN
103 ifix(nd +1) = 1
104 ELSEIF (ict == 2) THEN
105 ifix(nd +2) = 1
106 ELSEIF (ict == 1) THEN
107 ifix(nd +3) = 1
108 ELSEIF (ict == 3) THEN
109 ifix(nd +2) = 1
110 ifix(nd +3) = 1
111 ELSEIF (ict == 5) THEN
112 IF (k>2) ifix(nd +1) = 1
113 ifix(nd +3) = 1
114 ELSEIF (ict == 6) THEN
115 IF (k>2) ifix(nd +1) = 1
116 ifix(nd +2) = 1
117 ELSEIF (ict == 7) THEN
118 IF (k>2) ifix(nd +1) = 1
119 ifix(nd +2) = 1
120 ifix(nd +3) = 1
121 ENDIF
122 ENDIF
123 IF (icr > 0 .AND. k==6) THEN
124 IF (icr == 1) THEN
125 ifix(nd +6) = 1
126 ELSEIF (icr == 2) THEN
127 ifix(nd +5) = 1
128 ELSEIF (icr == 3) THEN
129 ifix(nd +5) = 1
130 ifix(nd +6) = 1
131 ELSEIF (icr == 4) THEN
132 ifix(nd +4) = 1
133 ELSEIF (icr == 5) THEN
134 ifix(nd +4) = 1
135 ifix(nd +6) = 1
136 ELSEIF (icr == 6) THEN
137 ifix(nd +4) = 1
138 ifix(nd +5) = 1
139 ELSEIF (icr == 7) THEN
140 ifix(nd +4) = 1
141 ifix(nd +5) = 1
142 ifix(nd +6) = 1
143 ENDIF
144 ENDIF
145 ENDIF
146 ENDDO
147 ENDIF
148C
149 RETURN

◆ bc_imp1()

subroutine bc_imp1 ( integer, dimension(*) icodt,
integer, dimension(*) icodr,
integer, dimension(*) iskew,
skew,
integer, dimension(*) ifix,
integer, dimension(*) ndof,
integer, dimension(*) iadn,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k )

Definition at line 159 of file bc_imp0.F.

162C-----------------------------------------------
163C I m p l i c i t T y p e s
164C-----------------------------------------------
165#include "implicit_f.inc"
166C-----------------------------------------------
167C C o m m o n B l o c k s
168C-----------------------------------------------
169#include "com04_c.inc"
170#include "com01_c.inc"
171#include "param_c.inc"
172C-----------------------------------------------
173C D u m m y A r g u m e n t s
174C-----------------------------------------------
175 INTEGER ICODT(*),ICODR(*),ISKEW(*),IFIX(*),
176 . NDOF(*),IADN(*),IADK(*) ,JDIK(*)
177 my_real
178 . skew(lskew,*),diag_k(*),lt_k(*)
179C-----------------------------------------------
180C L o c a l V a r i a b l e s
181C-----------------------------------------------
182 INTEGER I, ISK, ICT,ICR,J,K,ND,IR,IT,IFIX_CP(6)
183C----------------BC-------------------------
184 it = 0
185 ir = 1
186 IF (iroddl==0) THEN
187 DO i = 1,numnod
188 isk = iskew(i)
189 IF (isk>1) THEN
190 ict = iabs(icodt(i))
191 k = ndof(i)
192 nd = iadn(i)
193C---------<0 with FV coupling, not to change IFIX
194 IF (icodt(i)<0) THEN
195 DO j =1,3
196 ifix_cp(j)=ifix(nd+j)
197 END DO
198 END IF
199 IF (ict > 0 .AND. k> 0) THEN
200 CALL bcl_impk(ict ,isk ,skew ,ifix ,iadn ,
201 1 iadk ,jdik ,diag_k,lt_k ,
202 2 i ,nd ,it )
203 ENDIF
204 IF (icodt(i)<0) THEN
205 DO j =1,3
206 ifix(nd+j)=ifix_cp(j)
207 END DO
208 END IF
209 ENDIF
210 ENDDO
211 ELSE
212 DO i = 1,numnod
213 isk = iskew(i)
214 IF (isk>1) THEN
215 ict = iabs(icodt(i))
216 icr = iabs(icodr(i))
217 k = ndof(i)
218 nd = iadn(i)
219 IF (icodt(i)<0) THEN
220 DO j =1,3
221 ifix_cp(j)=ifix(nd+j)
222 END DO
223 END IF
224 IF (ict > 0 .AND. k> 0) THEN
225 CALL bcl_impk(ict ,isk ,skew ,ifix ,iadn ,
226 1 iadk ,jdik ,diag_k,lt_k ,
227 2 i ,nd ,it )
228 ENDIF
229 IF (icodt(i)<0) THEN
230 DO j =1,3
231 ifix(nd+j)=ifix_cp(j)
232 END DO
233 END IF
234 IF (icodr(i)<0) THEN
235 DO j =4,6
236 ifix_cp(j)=ifix(nd+j)
237 END DO
238 END IF
239 IF (icr > 0 .AND. k==6) THEN
240 nd = nd + 3
241 CALL bcl_impk(icr ,isk ,skew ,ifix ,iadn ,
242 1 iadk ,jdik ,diag_k,lt_k ,
243 2 i ,nd ,ir )
244 ENDIF
245 IF (icodr(i)<0) THEN
246 DO j =4,6
247 ifix(nd+j) = ifix_cp(j)
248 END DO
249 END IF
250 ENDIF
251 ENDDO
252 ENDIF
253C
254 RETURN
bcl_impk
subroutine bcl_impk(ict, isk, skew, ifix, iadn, iadk, jdik, diag_k, lt_k, i, nd, ir)
Definition bc_imp0.F:268

◆ bc_imp2()

subroutine bc_imp2 ( integer, dimension(*) icodt,
integer, dimension(*) icodr,
integer, dimension(*) iskew,
skew,
integer, dimension(*) ndof,
d,
dr )

Definition at line 616 of file bc_imp0.F.

618C-----------------------------------------------
619C M o d u l e s
620C-----------------------------------------------
621 USE imp_aspc
622C-----------------------------------------------
623C I m p l i c i t T y p e s
624C-----------------------------------------------
625#include "implicit_f.inc"
626C-----------------------------------------------
627C C o m m o n B l o c k s
628C-----------------------------------------------
629#include "com04_c.inc"
630#include "com01_c.inc"
631#include "param_c.inc"
632C-----------------------------------------------
633C D u m m y A r g u m e n t s
634C-----------------------------------------------
635 INTEGER ICODT(*),ICODR(*),ISKEW(*),NDOF(*)
636 my_real
637 . skew(lskew,*),d(3,*),dr(3,*)
638C-----------------------------------------------
639C L o c a l V a r i a b l e s
640C-----------------------------------------------
641 INTEGER I, ISK, ICT,ICR,J,K,IAD,IR,N,NN
642 my_real
643 . ej(3)
644C----------------BC-------------------------
645 IF (iroddl==0) THEN
646 DO i = 1,numnod
647 isk = iskew(i)
648 IF (isk>1) THEN
649 ict = icodt(i)
650 k = ndof(i)
651 IF (ict /= 0 .AND. k> 0) THEN
652 CALL bcl_impd(ict ,isk ,skew ,i ,d )
653 ENDIF
654 ENDIF
655 ENDDO
656 ELSE
657 DO i = 1,numnod
658 isk = iskew(i)
659 IF (isk>1) THEN
660 ict = icodt(i)
661 icr = icodr(i)
662 k = ndof(i)
663 IF (ict /= 0 .AND. k> 0) THEN
664 CALL bcl_impd(ict ,isk ,skew ,i ,d )
665 ENDIF
666 IF (icr /= 0 .AND. k==6) THEN
667 CALL bcl_impd(icr ,isk ,skew ,i ,dr )
668 ENDIF
669 ENDIF
670 ENDDO
671 ENDIF
672C--------AUTOSPC---------------------------------------
673 DO n = nspcl,1 ,-1
674 i = in_spc(n)
675 IF (ndof(i)==0) cycle
676 ir = 0
677 iad = 6*(n-1)+1
678 nn = ic_spc(n)
679 IF (nn>3) THEN
680 nn= nn-3
681 ir = 1
682 ENDIF
683 IF (nn==1) THEN
684 ej(1)=skew_spc(iad)
685 ej(2)=skew_spc(iad+1)
686 ej(3)=skew_spc(iad+2)
687 CALL l_dir(ej,j)
688 END IF
689 IF (ir==0) THEN
690 IF (nn==1) THEN
691 d(j,i) = zero
692 CALL bc_updd(i ,ej ,j ,d )
693 ELSEIF (nn==2) THEN
694 CALL bc_upd2d(i ,skew_spc(iad),skew_spc(iad+3),d )
695 END IF
696 ELSE
697 IF (nn==1) THEN
698 dr(j,i) = zero
699 CALL bc_updd(i ,ej ,j ,dr )
700 ELSEIF (nn==2) THEN
701 CALL bc_upd2d(i ,skew_spc(iad),skew_spc(iad+3),dr )
702 END IF
703 ENDIF
704 ENDDO
705C
706 RETURN
l_dir
subroutine l_dir(ej, j)
Definition bc_imp0.F:405
bcl_impd
subroutine bcl_impd(ict, isk, skew, i, d)
Definition bc_imp0.F:721
bc_updd
subroutine bc_updd(n, ej, j, d)
Definition bc_imp0.F:843
bc_upd2d
subroutine bc_upd2d(n, skew, skew1, d)
Definition bc_imp0.F:2469
imp_aspc
Definition impbufdef_mod.F:526
imp_aspc::in_spc
integer, dimension(:), allocatable in_spc
Definition impbufdef_mod.F:529
imp_aspc::ic_spc
integer, dimension(:), allocatable ic_spc
Definition impbufdef_mod.F:529
imp_aspc::nspcl
integer nspcl
Definition impbufdef_mod.F:527

◆ bc_impa()

subroutine bc_impa ( integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer, dimension(*) ndof,
integer, dimension(*) iddl,
integer, dimension(*) ikc )

Definition at line 1495 of file bc_imp0.F.

1497C-----------------------------------------------
1498C M o d u l e s
1499C-----------------------------------------------
1500 USE imp_aspc
1501C-----------------------------------------------
1502C I m p l i c i t T y p e s
1503C-----------------------------------------------
1504#include "implicit_f.inc"
1505C-----------------------------------------------
1506C D u m m y A r g u m e n t s
1507C-----------------------------------------------
1508 INTEGER IADK(*),JDIK(*),NDOF(*),IDDL(*),IKC(*)
1509 my_real
1510 . diag_k(*),lt_k(*)
1511C-----------------------------------------------
1512C L o c a l V a r i a b l e s
1513C-----------------------------------------------
1514 INTEGER I,J,K,N,IER1,IR,IAD,NN,ND,KC
1515C
1516 my_real
1517 . ej(3)
1518C-----------------------------------------------
1519 kc=15
1520 DO n = 1, nspcl
1521 i = in_spc(n)
1522 IF (ndof(i)==0) cycle
1523 ir = 0
1524 iad = 6*(n-1)+1
1525 nn = ic_spc(n)
1526 nd = iddl(i)
1527 IF (nn>3) THEN
1528 nn= nn-3
1529 ir = 1
1530 ENDIF
1531 IF (nn==1) THEN
1532 ej(1)=skew_spc(iad)
1533 ej(2)=skew_spc(iad+1)
1534 ej(3)=skew_spc(iad+2)
1535 CALL l_dir(ej,j)
1536 CALL bc_updk(i ,iddl ,ej ,j ,ir ,
1537 1 iadk ,jdik ,diag_k ,lt_k )
1538 ikc(nd +j) = kc
1539 ELSEIF (nn==2) THEN
1540 CALL bc_updk2d(iddl ,ikc(nd+1),skew_spc(iad),skew_spc(iad+3),
1541 1 i ,ir ,kc ,iadk ,jdik ,diag_k,
1542 2 lt_k )
1543 END IF
1544 ENDDO
1545C
1546 RETURN
bc_updk
subroutine bc_updk(n, iddl, ej, jj, ir, iadk, jdik, diag_k, lt_k)
Definition bc_imp0.F:491
bc_updk2d
subroutine bc_updk2d(iadn, ifix, skew, skew1, i, ir, kc, iadk, jdik, diag_k, lt_k)
Definition bc_imp0.F:2375

◆ bc_impr1()

subroutine bc_impr1 ( integer, dimension(*) icodt,
integer, dimension(*) icodr,
integer, dimension(*) iskew,
skew,
integer, dimension(*) ndof,
integer, dimension(*) iadn,
lb )

Definition at line 1122 of file bc_imp0.F.

1124C-----------------------------------------------
1125C M o d u l e s
1126C-----------------------------------------------
1127 USE imp_aspc
1128 USE imp_fvbcl
1129C-----------------------------------------------
1130C I m p l i c i t T y p e s
1131C-----------------------------------------------
1132#include "implicit_f.inc"
1133C-----------------------------------------------
1134C C o m m o n B l o c k s
1135C-----------------------------------------------
1136#include "com04_c.inc"
1137#include "com01_c.inc"
1138#include "param_c.inc"
1139C-----------------------------------------------
1140C D u m m y A r g u m e n t s
1141C-----------------------------------------------
1142 INTEGER ICODT(*),ICODR(*),ISKEW(*),NDOF(*),IADN(*)
1143 my_real
1144 . skew(lskew,*),lb(*)
1145C-----------------------------------------------
1146C L o c a l V a r i a b l e s
1147C-----------------------------------------------
1148 INTEGER I, ISK, ICT,ICR,J,K,ND,IR,IT,IAD,NN,N
1149 my_real
1150 . ej(3)
1151C----------------BC-------------------------
1152 it = 0
1153 ir = 1
1154C-----case FV,BCS coupling---
1155 IF (nfvbcl > 0 )THEN
1156 IF (iroddl==0) THEN
1157 DO i = 1,numnod
1158 isk = iskew(i)
1159 IF (isk>1) THEN
1160 ict = iabs(ict_1(i))
1161 k = ndof(i)
1162 nd = iadn(i)
1163 IF (ict > 0 .AND. k> 0) THEN
1164 CALL bcl_impb(ict ,isk ,skew ,nd ,lb ,
1165 1 it )
1166 ENDIF
1167 ENDIF
1168 ENDDO
1169C
1170 ELSE
1171C
1172 DO i = 1,numnod
1173 isk = iskew(i)
1174 IF (isk>1) THEN
1175 ict = iabs(ict_1(i))
1176 icr = iabs(icr_1(i))
1177 k = ndof(i)
1178 nd = iadn(i)
1179 IF (ict > 0 .AND. k> 0) THEN
1180 CALL bcl_impb(ict ,isk ,skew ,nd ,lb ,
1181 1 it )
1182 ENDIF
1183 IF (icr > 0 .AND. k==6) THEN
1184 CALL bcl_impb(icr ,isk ,skew ,nd ,lb ,
1185 1 ir )
1186 ENDIF
1187 ENDIF
1188 ENDDO
1189C
1190 END IF !(IRODDL==0) THEN
1191 ELSE
1192C
1193 IF (iroddl==0) THEN
1194 DO i = 1,numnod
1195 isk = iskew(i)
1196 IF (isk>1) THEN
1197 ict = icodt(i)
1198 k = ndof(i)
1199 nd = iadn(i)
1200 IF (ict > 0 .AND. k> 0) THEN
1201 CALL bcl_impb(ict ,isk ,skew ,nd ,lb ,
1202 1 it )
1203 ENDIF
1204 ENDIF
1205 ENDDO
1206C
1207 ELSE
1208C
1209 DO i = 1,numnod
1210 isk = iskew(i)
1211 IF (isk>1) THEN
1212 ict = icodt(i)
1213 icr = icodr(i)
1214 k = ndof(i)
1215 nd = iadn(i)
1216 IF (ict > 0 .AND. k> 0) THEN
1217 CALL bcl_impb(ict ,isk ,skew ,nd ,lb ,
1218 1 it )
1219 ENDIF
1220 IF (icr > 0 .AND. k==6) THEN
1221C
1222 CALL bcl_impb(icr ,isk ,skew ,nd ,lb ,
1223 1 ir )
1224 ENDIF
1225 ENDIF
1226 ENDDO
1227C
1228 ENDIF
1229 END IF !(nfvbcl > 0 )THEN
1230C
1231 DO n = 1, nspcl
1232 i = in_spc(n)
1233 IF (ndof(i)==0) cycle
1234 iad = 6*(n-1)+1
1235 nn = ic_spc(n)
1236 nd = iadn(i)
1237 ir=0
1238 IF (nn>3) THEN
1239 nn=nn-3
1240 ir = 1
1241 END IF
1242 IF (nn==1) THEN
1243 ej(1)=skew_spc(iad)
1244 ej(2)=skew_spc(iad+1)
1245 ej(3)=skew_spc(iad+2)
1246 CALL l_dir(ej,j)
1247 CALL bc_updb(nd ,ej ,j ,ir ,lb )
1248 ELSEIF (nn==2) THEN
1249 CALL bc_updf2d(nd ,skew_spc(iad),skew_spc(iad+3),ir,lb )
1250 END IF
1251 ENDDO
1252C
1253 RETURN
bcl_impb
subroutine bcl_impb(ict, isk, skew, nd, lb, ir)
Definition bc_imp0.F:1266
bc_updf2d
subroutine bc_updf2d(nd, skew, skew1, ir, b)
Definition bc_imp0.F:2423
bc_updb
subroutine bc_updb(id, ej, jj, ir, lb)
Definition bc_imp0.F:1069
imp_fvbcl
Definition impbufdef_mod.F:621
imp_fvbcl::nfvbcl
integer nfvbcl
Definition impbufdef_mod.F:623
imp_fvbcl::icr_1
integer, dimension(:), allocatable icr_1
Definition impbufdef_mod.F:624
imp_fvbcl::ict_1
integer, dimension(:), allocatable ict_1
Definition impbufdef_mod.F:624

◆ bc_upd2d()

subroutine bc_upd2d ( integer n,
skew,
skew1,
d )

Definition at line 2468 of file bc_imp0.F.

2469C-----------------------------------------------
2470C I m p l i c i t T y p e s
2471C-----------------------------------------------
2472#include "implicit_f.inc"
2473C-----------------------------------------------
2474C D u m m y A r g u m e n t s
2475C-----------------------------------------------
2476 INTEGER N
2477 my_real
2478 . skew(3),skew1(3),d(3,*)
2479C-----------------------------------------------
2480C L o c a l V a r i a b l e s
2481C-----------------------------------------------
2482 INTEGER I,K,L,J,J1
2483 my_real
2484 . ej(3),ej1(3),s,ea,eb
2485C-----------------------------------------------
2486 ej(1)=skew(1)
2487 ej(2)=skew(2)
2488 ej(3)=skew(3)
2489c CALL L_DIR(EJ,J)
2490 ej1(1)=skew1(1)
2491 ej1(2)=skew1(2)
2492 ej1(3)=skew1(3)
2493 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
2494 CALL dir_rbe2(j ,j1 ,k )
2495c S=ONE/(ONE-EJ(J1)*EJ1(J))
2496c EA=S*(EJ(J1)*EJ1(K)-EJ(K))
2497c EB=S*(EJ1(J)*EJ(K)-EJ1(K))
2498C
2499 d(j,n) = -ea* d(k,n)
2500 d(j1,n)= -eb* d(k,n)
2501C
2502 RETURN

◆ bc_updb()

subroutine bc_updb ( integer id,
ej,
integer jj,
integer ir,
lb )

Definition at line 1068 of file bc_imp0.F.

1069C-----------------------------------------------
1070C I m p l i c i t T y p e s
1071C-----------------------------------------------
1072#include "implicit_f.inc"
1073C-----------------------------------------------
1074C D u m m y A r g u m e n t s
1075C-----------------------------------------------
1076 INTEGER ID,JJ,IR
1077 my_real
1078 . ej(*),lb(*)
1079C-----------------------------------------------
1080C L o c a l V a r i a b l e s
1081C-----------------------------------------------
1082 INTEGER I,J,ND,K,L,J1,K1,L1
1083C-----------------------------------------------
1084 IF (ir==0) THEN
1085 nd = 3
1086 ELSE
1087 nd = 6
1088 ENDIF
1089 k = jj + 1
1090 l = jj + 2
1091 IF (k>3) k = k - 3
1092 IF (l>3) l = l - 3
1093 IF (ej(k)==zero.AND.ej(l)==zero) RETURN
1094 IF (ir==0) THEN
1095 j1 = jj
1096 k1 = k
1097 l1 = l
1098 ELSE
1099 j1 = jj + 3
1100 k1 = k + 3
1101 l1 = l + 3
1102 ENDIF
1103 lb(id+k1)=lb(id+k1)-ej(k)*lb(id+j1)
1104 lb(id+l1)=lb(id+l1)-ej(l)*lb(id+j1)
1105C
1106 RETURN

◆ bc_updd()

subroutine bc_updd ( integer n,
ej,
integer j,
d )

Definition at line 842 of file bc_imp0.F.

843C-----------------------------------------------
844C I m p l i c i t T y p e s
845C-----------------------------------------------
846#include "implicit_f.inc"
847C-----------------------------------------------
848C D u m m y A r g u m e n t s
849C-----------------------------------------------
850 INTEGER N,J
851 my_real
852 . ej(*),d(3,*)
853C-----------------------------------------------
854C L o c a l V a r i a b l e s
855C-----------------------------------------------
856 INTEGER I,ND,K,L
857C-----------------------------------------------
858 k = j + 1
859 l = j + 2
860 IF (k>3) k = k - 3
861 IF (l>3) l = l - 3
862 d(j,n) = d(j,n)- ej(k)* d(k,n)-ej(l)* d(l,n)
863C
864 RETURN

◆ bc_updd2()

subroutine bc_updd2 ( integer n,
ej,
integer j,
ej1,
integer j1,
d )

Definition at line 871 of file bc_imp0.F.

872C-----------------------------------------------
873C I m p l i c i t T y p e s
874C-----------------------------------------------
875#include "implicit_f.inc"
876C-----------------------------------------------
877C D u m m y A r g u m e n t s
878C-----------------------------------------------
879 INTEGER N,J,J1
880 my_real
881 . ej(*),ej1(*),d(3,*)
882C-----------------------------------------------
883C L o c a l V a r i a b l e s
884C-----------------------------------------------
885 INTEGER I,K,L
886 my_real
887 . s
888C-----------------------------------------------
889 k = j + 1
890 IF (k>3) k = k - 3
891 IF (k==j1) THEN
892 k = j + 2
893 IF (k>3) k = k - 3
894 ENDIF
895 s =one-ej1(j)*ej(j1)
896 d(j1,n) = ( d(j1,n)-ej1(j)*d(j,n)+
897 . (ej1(j)*ej(k)-ej1(k))*d(k,n) )/s
898 d(j,n) = d(j,n)- ej(k)* d(k,n)-ej(j1)* d(j1,n)
899C
900 RETURN

◆ bc_updf()

subroutine bc_updf ( integer nbc,
integer, dimension(3,*) ibc,
skew,
a )

Definition at line 973 of file bc_imp0.F.

974C-----------------------------------------------
975C I m p l i c i t T y p e s
976C-----------------------------------------------
977#include "implicit_f.inc"
978C-----------------------------------------------
979C C o m m o n B l o c k s
980C-----------------------------------------------
981#include "param_c.inc"
982C-----------------------------------------------
983C D u m m y A r g u m e n t s
984C-----------------------------------------------
985 INTEGER NBC ,IBC(3,*)
986 my_real
987 . a(3,*),skew(lskew,*)
988C-----------------------------------------------
989C L o c a l V a r i a b l e s
990C-----------------------------------------------
991 INTEGER I,J,N,K,L,J1,K1,L1,K2,K3,II,ISK,ICT
992 my_real
993 . ej(3)
994C-----------------------------------------------
995 DO ii=1,nbc
996 n = ibc(1,ii)
997 isk = ibc(2,ii)
998 ict = ibc(3,ii)
999 IF (ict == 4 ) THEN
1000 ej(1)=skew(1,isk)
1001 ej(2)=skew(2,isk)
1002 ej(3)=skew(3,isk)
1003 CALL l_dir2(ej,j,1)
1004 CALL bc_fi(n ,ej ,j ,a )
1005 ELSEIF (ict == 2) THEN
1006 ej(1)=skew(4,isk)
1007 ej(2)=skew(5,isk)
1008 ej(3)=skew(6,isk)
1009 CALL l_dir2(ej,j,2)
1010 CALL bc_fi(n ,ej ,j ,a )
1011 ELSEIF (ict == 1) THEN
1012 ej(1)=skew(7,isk)
1013 ej(2)=skew(8,isk)
1014 ej(3)=skew(9,isk)
1015 CALL l_dir2(ej,j,3)
1016 CALL bc_fi(n ,ej ,j ,a )
1017 ELSEIF (ict == 3) THEN
1018 CALL bc_fi2(n ,skew(7,isk),skew(4,isk),a )
1019 ELSEIF (ict == 5) THEN
1020 CALL bc_fi2(n ,skew(7,isk),skew(1,isk),a )
1021 ELSEIF (ict == 6) THEN
1022 CALL bc_fi2(n ,skew(4,isk),skew(1,isk),a )
1023 ENDIF
1024 ENDDO
1025C
1026 RETURN
bc_fi
subroutine bc_fi(n, ej, j1, a)
Definition bc_imp0.F:1036
bc_fi2
subroutine bc_fi2(n, skew, skew1, a)
Definition bc_imp0.F:2562
l_dir2
subroutine l_dir2(ej, j, j0)
Definition bc_imp0.F:444

◆ bc_updf2d()

subroutine bc_updf2d ( integer nd,
skew,
skew1,
integer ir,
b )

Definition at line 2422 of file bc_imp0.F.

2423C-----------------------------------------------
2424C I m p l i c i t T y p e s
2425C-----------------------------------------------
2426#include "implicit_f.inc"
2427C-----------------------------------------------
2428C D u m m y A r g u m e n t s
2429C-----------------------------------------------
2430 INTEGER ND,IR
2431 my_real
2432 . skew(3),skew1(3),b(*)
2433C-----------------------------------------------
2434C L o c a l V a r i a b l e s
2435C-----------------------------------------------
2436 INTEGER J,K,J1,L
2437 my_real
2438 . ej(3),ej1(3),s,ea,eb
2439C-----------------------------------------------
2440 ej(1)=skew(1)
2441 ej(2)=skew(2)
2442 ej(3)=skew(3)
2443C CALL L_DIR(EJ,J)
2444 ej1(1)=skew1(1)
2445 ej1(2)=skew1(2)
2446 ej1(3)=skew1(3)
2447 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
2448 CALL dir_rbe2(j ,j1 ,k )
2449c S=ONE/(ONE-EJ(J1)*EJ1(J))
2450c EA=S*(EJ(J1)*EJ1(K)-EJ(K))
2451c EB=S*(EJ1(J)*EJ(K)-EJ1(K))
2452C
2453 IF (ir>0) nd=nd+3
2454 b(nd+k)=b(nd+k)-ea*b(nd+j)-eb*b(nd+j1)
2455C
2456 RETURN

◆ bc_updfr()

subroutine bc_updfr ( integer n,
integer, dimension(*) iddl,
ej,
integer jj,
integer, dimension(*) iddlm,
integer, dimension(*) ikc,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
lb,
a,
kss,
ksm,
integer idlm,
integer ifss,
integer ifsm )

Definition at line 1328 of file bc_imp0.F.

1332C-----------------------------------------------
1333C I m p l i c i t T y p e s
1334C-----------------------------------------------
1335#include "implicit_f.inc"
1336C-----------------------------------------------
1337C D u m m y A r g u m e n t s
1338C-----------------------------------------------
1339 INTEGER N,JJ,IDDL(*),IDDLM(*),IKC(*),IADK(*),JDIK(*),
1340 . IDLM,IFSS ,IFSM
1341 my_real
1342 . ej(*),diag_k(*),lt_k(*),lb(*),a(3,*),
1343 . kss(6),ksm(3,3)
1344C-----------------------------------------------
1345C L o c a l V a r i a b l e s
1346C-----------------------------------------------
1347 INTEGER I,J,ND,K,L,J1,K1,L1,ID,IDM
1348 my_real
1349 . kdd(3,3),kii(6,6)
1350C-----------------------------------------------
1351 nd = 3
1352 k = jj + 1
1353 l = jj + 2
1354 IF (k>3) k = k - 3
1355 IF (l>3) l = l - 3
1356 IF (ej(k)==zero.AND.ej(l)==zero) RETURN
1357 j1 = jj
1358 k1 = k
1359 l1 = l
1360 DO i=1,nd
1361 DO j=1,nd
1362 kii(i,j)=zero
1363 ENDDO
1364 ENDDO
1365 IF (ifss>0) THEN
1366 DO i=1,nd
1367 kdd(i,i)=kss(i)
1368 ENDDO
1369 kdd(1,2) = kss(4)
1370 kdd(1,3) = kss(5)
1371 kdd(2,3) = kss(6)
1372 kdd(2,1) = kdd(1,2)
1373 kdd(3,1) = kdd(1,3)
1374 kdd(3,2) = kdd(2,3)
1375C
1376 kii(k1,k1)=kdd(k1,k1)-(two*kdd(k1,j1)-kdd(j1,j1)*ej(k))*ej(k)
1377 kii(l1,l1)=kdd(l1,l1)-(two*kdd(l1,j1)-kdd(j1,j1)*ej(l))*ej(l)
1378 kii(l1,k1)=kdd(l1,k1)-kdd(l1,j1)*ej(k)-kdd(k1,j1)*ej(l)
1379 1 +kdd(j1,j1)*ej(l)*ej(k)
1380 kii(k1,l1)=kii(l1,k1)
1381 CALL put_kmii(idlm ,iadk,diag_k,lt_k ,kii,nd)
1382 id = iddl(n)
1383 idm = iddlm(n)
1384C--------debug test door_rd8 (GPCG+contact)
1385C IF(IKC(ID+K1)==0) LB(IDM+K1)=LB(IDM+K1)-EJ(K)*A(J1,N)
1386C IF(IKC(ID+L1)==0) LB(IDM+L1)=LB(IDM+L1)-EJ(L)*A(J1,N)
1387 ENDIF
1388C
1389 IF (ifsm>0) THEN
1390 ksm(k1,j1)=ksm(k1,j1)-ej(k)*ksm(j1,j1)
1391 ksm(k1,k1)=ksm(k1,k1)-ej(k)*ksm(j1,k1)
1392 ksm(k1,l1)=ksm(k1,l1)-ej(k)*ksm(j1,l1)
1393 ksm(l1,j1)=ksm(l1,j1)-ej(l)*ksm(j1,j1)
1394 ksm(l1,k1)=ksm(l1,k1)-ej(l)*ksm(j1,k1)
1395 ksm(l1,l1)=ksm(l1,l1)-ej(l)*ksm(j1,l1)
1396 ENDIF
1397C
1398 RETURN
put_kmii
subroutine put_kmii(id, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:1186

◆ bc_updfr2()

subroutine bc_updfr2 ( integer n,
integer, dimension(*) iddl,
skew,
skew1,
integer, dimension(*) iddlm,
integer, dimension(*) ikc,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
lb,
a,
kss,
ksm,
integer idlm,
integer ifss,
integer ifsm )

Definition at line 2609 of file bc_imp0.F.

2613C-----------------------------------------------
2614C I m p l i c i t T y p e s
2615C-----------------------------------------------
2616#include "implicit_f.inc"
2617C-----------------------------------------------
2618C D u m m y A r g u m e n t s
2619C-----------------------------------------------
2620 INTEGER N,IDDL(*),IDDLM(*),IKC(*),IADK(*),JDIK(*),
2621 . IDLM,IFSS ,IFSM
2622 my_real
2623 . diag_k(*),lt_k(*),lb(*),a(3,*),
2624 . kss(6),ksm(3,3),skew(3),skew1(3)
2625C-----------------------------------------------
2626C L o c a l V a r i a b l e s
2627C-----------------------------------------------
2628 INTEGER I,J,ND,K,L,J1,ID,IDM
2629 my_real
2630 . ej(3),ej1(3),s,ea,eb,kdd(6,6)
2631C-----------------------------------------------
2632 ej(1)=skew(1)
2633 ej(2)=skew(2)
2634 ej(3)=skew(3)
2635c CALL L_DIR(EJ,J)
2636 ej1(1)=skew1(1)
2637 ej1(2)=skew1(2)
2638 ej1(3)=skew1(3)
2639 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
2640 CALL dir_rbe2(j ,j1 ,k )
2641 ea = -ea
2642 eb = -eb
2643c S=ONE/(ONE-EJ(J1)*EJ1(J))
2644c EA=S*(EJ(J1)*EJ1(K)-EJ(K))
2645c EB=S*(EJ1(J)*EJ(K)-EJ1(K))
2646C
2647 nd = 3
2648 IF (ifss>0) THEN
2649 DO i=1,nd
2650 kdd(i,i)=kss(i)
2651 ENDDO
2652 kdd(1,2) = kss(4)
2653 kdd(1,3) = kss(5)
2654 kdd(2,3) = kss(6)
2655 kdd(2,1) = kdd(1,2)
2656 kdd(3,1) = kdd(1,3)
2657 kdd(3,2) = kdd(2,3)
2658C
2659 kdd(k,k)= kdd(k,k)
2660 . +ea*(kdd(j,j)*ea+two*eb*kdd(j,j1)-two*kdd(j,k))
2661 . +eb*(kdd(j1,j1)*eb-two*kdd(j1,k))
2662 CALL put_kmii(idlm ,iadk,diag_k,lt_k ,kdd,nd)
2663 id = iddl(n)
2664 idm = iddlm(n)
2665 IF(ikc(id+k)==0) lb(idm+k)=lb(idm+k)+ea*a(j,n)+eb*a(j1,n)
2666 ENDIF
2667C
2668 IF (ifsm>0) THEN
2669 ksm(k,k)= ea*(ksm(j,j)*ea+two*eb*ksm(j,j1)-two*ksm(j,k))
2670 . +eb*(ksm(j1,j1)*eb-two*ksm(j1,k))
2671 ENDIF
2672C
2673 RETURN

◆ bc_updk()

subroutine bc_updk ( integer n,
integer, dimension(*) iddl,
ej,
integer jj,
integer ir,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k )

Definition at line 489 of file bc_imp0.F.

491C-----------------------------------------------
492C I m p l i c i t T y p e s
493C-----------------------------------------------
494#include "implicit_f.inc"
495C-----------------------------------------------
496C C o m m o n B l o c k s
497C-----------------------------------------------
498#include "impl1_c.inc"
499C-----------------------------------------------
500C D u m m y A r g u m e n t s
501C-----------------------------------------------
502 INTEGER N,JJ,IDDL(*),IR,IADK(*) ,JDIK(*)
503 my_real
504 . ej(*),diag_k(*),lt_k(*)
505C-----------------------------------------------
506C L o c a l V a r i a b l e s
507C-----------------------------------------------
508 INTEGER I,J,ND,K,L,J1,K1,L1,ID,SHF,JFT,KFT,LFT,NL,NJ,
509 . IT(6),KK
510 my_real
511 . kdd(6,6),kii(6,6)
512C-----------------------------------------------
513 IF (ir==0) THEN
514 nd = 3
515 ELSE
516 nd = 6
517 ENDIF
518 k = jj + 1
519 l = jj + 2
520 IF (k>3) k = k - 3
521 IF (l>3) l = l - 3
522 IF (ej(k)==zero.AND.ej(l)==zero) RETURN
523 DO i=1,nd
524 DO j=1,nd
525 kii(i,j)=zero
526 ENDDO
527 ENDDO
528 IF (ir==0) THEN
529 j1 = jj
530 k1 = k
531 l1 = l
532 ELSE
533 j1 = jj + 3
534 k1 = k + 3
535 l1 = l + 3
536 ENDIF
537 CALL get_kii(n ,iddl ,iadk,diag_k,lt_k ,kdd,nd)
538 DO i=1,nd
539 DO j=i+1,nd
540 kdd(j,i)=kdd(i,j)
541 ENDDO
542 ENDDO
543 kii(k1,k1)=-(two*kdd(k1,j1)-kdd(j1,j1)*ej(k))*ej(k)
544 kii(l1,l1)=-(two*kdd(l1,j1)-kdd(j1,j1)*ej(l))*ej(l)
545 kii(l1,k1)=-kdd(l1,j1)*ej(k)-kdd(k1,j1)*ej(l)
546 1 +kdd(j1,j1)*ej(l)*ej(k)
547 kii(k1,l1)=kii(l1,k1)
548 IF (ir/=0) THEN
549 j = jj
550 kii(j,k1)=-kdd(j,j1)*ej(k)
551 kii(k,k1)=-kdd(k,j1)*ej(k)
552 kii(l,k1)=-kdd(l,j1)*ej(k)
553 kii(j,l1)=-kdd(j,j1)*ej(l)
554 kii(k,l1)=-kdd(k,j1)*ej(l)
555 kii(l,l1)=-kdd(l,j1)*ej(l)
556 ENDIF
557 CALL put_kii(n ,iddl ,iadk,diag_k,lt_k ,kii,nd)
558 id = iddl(n)+ j1
559 IF (ikpat==0) THEN
560 shf = iabs(jj-3)
561 nl = iadk(id+1)-iadk(id)-shf
562 jft = iadk(id)+shf-1
563 kft = iadk(iddl(n)+ k1)+iabs(k-3)-1
564 lft = iadk(iddl(n)+ l1)+iabs(l-3)-1
565 DO j = 1, nl
566 lt_k(kft+j) = lt_k(kft+j)-ej(k)*lt_k(jft+j)
567 lt_k(lft+j) = lt_k(lft+j)-ej(l)*lt_k(jft+j)
568 ENDDO
569 DO i = 1, iddl(n)
570 nj =0
571 DO j = iadk(i), iadk(i+1)-1
572 IF (jdik(j)==id) nj = j
573 ENDDO
574 IF (nj>0) THEN
575 lt_k(nj+k1-j1) = lt_k(nj+k1-j1)-ej(k)*lt_k(nj)
576 lt_k(nj+l1-j1) = lt_k(nj+l1-j1)-ej(l)*lt_k(nj)
577 ENDIF
578 ENDDO
579 ELSE
580 shf = j1-1
581 nl = iadk(id+1)-iadk(id)-shf
582 jft = iadk(id)-1
583 kft = iadk(iddl(n)+k1)-1
584 lft = iadk(iddl(n)+l1)-1
585 DO j = 1, nl
586 lt_k(kft+j) = lt_k(kft+j)-ej(k)*lt_k(jft+j)
587 lt_k(lft+j) = lt_k(lft+j)-ej(l)*lt_k(jft+j)
588 ENDDO
589C---------ajoute NDDL_L dans impl1_c.inc
590 DO i = iddl(n)+nd+1, nddl_l
591 nj =0
592 DO j = iadk(i), iadk(i+1)-1
593 IF (jdik(j)==id) nj = j
594 ENDDO
595 IF (nj>0) THEN
596 lt_k(nj+k1-j1) = lt_k(nj+k1-j1)-ej(k)*lt_k(nj)
597 lt_k(nj+l1-j1) = lt_k(nj+l1-j1)-ej(l)*lt_k(nj)
598 ENDIF
599 ENDDO
600 ENDIF
601C
602 RETURN
put_kii
subroutine put_kii(ni, iddl, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:653
get_kii
subroutine get_kii(ni, iddl, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:591
nl
character *2 function nl()
Definition message.F:2354

◆ bc_updk2d()

subroutine bc_updk2d ( integer, dimension(*) iadn,
integer, dimension(*) ifix,
skew,
skew1,
integer i,
integer ir,
integer kc,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k )

Definition at line 2372 of file bc_imp0.F.

2375C-----------------------------------------------
2376C I m p l i c i t T y p e s
2377C-----------------------------------------------
2378#include "implicit_f.inc"
2379C-----------------------------------------------
2380C D u m m y A r g u m e n t s
2381C-----------------------------------------------
2382 INTEGER IADN(*),IFIX(*),IADK(*) ,JDIK(*),I,IR,KC
2383 my_real
2384 . skew(3),skew1(3),diag_k(*),lt_k(*)
2385C-----------------------------------------------
2386C L o c a l V a r i a b l e s
2387C-----------------------------------------------
2388 INTEGER J,K,J1,L,ND
2389 my_real
2390 . ej(3),ej1(3),s,ea,eb
2391C-----------------------------------------------
2392 ej(1)=skew(1)
2393 ej(2)=skew(2)
2394 ej(3)=skew(3)
2395c CALL L_DIR(EJ,J)
2396 ej1(1)=skew1(1)
2397 ej1(2)=skew1(2)
2398 ej1(3)=skew1(3)
2399 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
2400 CALL dir_rbe2(j ,j1 ,k )
2401c S=ONE/(ONE-EJ(J1)*EJ1(J))
2402C------------signe due to the subroutine BC_UPDK2
2403c EA=-S*(EJ(J1)*EJ1(K)-EJ(K))
2404c EB=-S*(EJ1(J)*EJ(K)-EJ1(K))
2405 CALL bc_updk2(i ,iadn ,j ,j1 ,k ,
2406 1 ir ,ea ,eb ,iadk ,jdik ,
2407 2 diag_k,lt_k )
2408 ifix(j) = kc
2409 ifix(j1) = kc
2410C
2411 RETURN
bc_updk2
subroutine bc_updk2(n, iddl, j, l, k, ir, ej, el, iadk, jdik, diag_k, lt_k)
Definition rbe2_imp0.F:1320

◆ bcl_frk()

subroutine bcl_frk ( integer n,
integer, dimension(*) iddl,
integer, dimension(*) iddlm,
integer ict,
integer isk,
skew,
integer, dimension(*) ikc,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
lb,
a,
kss,
ksm,
integer idlm,
integer ifss,
integer ifsm )

Definition at line 1410 of file bc_imp0.F.

1414C-----------------------------------------------
1415C I m p l i c i t T y p e s
1416C-----------------------------------------------
1417#include "implicit_f.inc"
1418C-----------------------------------------------
1419C C o m m o n B l o c k s
1420C-----------------------------------------------
1421#include "param_c.inc"
1422C-----------------------------------------------
1423C D u m m y A r g u m e n t s
1424C-----------------------------------------------
1425 INTEGER ICT,IKC(*),IDDL(*),IDDLM(*),IADK(*) ,JDIK(*),
1426 . N,ISK,IDLM ,IFSS ,IFSM
1427 my_real
1428 . skew(lskew,*),diag_k(*),lt_k(*),lb(*),a(3,*),kss(*),ksm(*)
1429C-----------------------------------------------
1430C L o c a l V a r i a b l e s
1431C-----------------------------------------------
1432 INTEGER J,K,J1,L
1433 my_real
1434 . ej(3)
1435C----------------BC-------------------------
1436 IF (ict == 4 ) THEN
1437 ej(1)=skew(1,isk)
1438 ej(2)=skew(2,isk)
1439 ej(3)=skew(3,isk)
1440 CALL l_dir2(ej,j,1)
1441 CALL bc_updfr(n ,iddl ,ej ,j ,iddlm ,
1442 1 ikc ,iadk ,jdik ,diag_k,lt_k ,
1443 2 lb ,a ,kss ,ksm ,idlm ,
1444 3 ifss ,ifsm )
1445 ELSEIF (ict == 2) THEN
1446 ej(1)=skew(4,isk)
1447 ej(2)=skew(5,isk)
1448 ej(3)=skew(6,isk)
1449 CALL l_dir2(ej,j,2)
1450 CALL bc_updfr(n ,iddl ,ej ,j ,iddlm ,
1451 1 ikc ,iadk ,jdik ,diag_k,lt_k ,
1452 2 lb ,a ,kss ,ksm ,idlm ,
1453 3 ifss ,ifsm )
1454 ELSEIF (ict == 1) THEN
1455 ej(1)=skew(7,isk)
1456 ej(2)=skew(8,isk)
1457 ej(3)=skew(9,isk)
1458 CALL l_dir2(ej,j,3)
1459 CALL bc_updfr(n ,iddl ,ej ,j ,iddlm ,
1460 1 ikc ,iadk ,jdik ,diag_k,lt_k ,
1461 2 lb ,a ,kss ,ksm ,idlm ,
1462 3 ifss ,ifsm )
1463C---------------------
1464 ELSEIF (ict == 3) THEN
1465 CALL bc_updfr2(n ,iddl ,skew(7,isk),skew(4,isk),iddlm ,
1466 1 ikc ,iadk ,jdik ,diag_k,lt_k ,
1467 2 lb ,a ,kss ,ksm ,idlm ,
1468 3 ifss ,ifsm )
1469 ELSEIF (ict == 5) THEN
1470 CALL bc_updfr2(n ,iddl ,skew(7,isk),skew(1,isk),iddlm ,
1471 1 ikc ,iadk ,jdik ,diag_k,lt_k ,
1472 2 lb ,a ,kss ,ksm ,idlm ,
1473 3 ifss ,ifsm )
1474 ELSEIF (ict == 6) THEN
1475 CALL bc_updfr2(n ,iddl ,skew(4,isk),skew(1,isk),iddlm ,
1476 1 ikc ,iadk ,jdik ,diag_k,lt_k ,
1477 2 lb ,a ,kss ,ksm ,idlm ,
1478 3 ifss ,ifsm )
1479 ENDIF
1480C
1481 RETURN
bc_updfr2
subroutine bc_updfr2(n, iddl, skew, skew1, iddlm, ikc, iadk, jdik, diag_k, lt_k, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition bc_imp0.F:2613
bc_updfr
subroutine bc_updfr(n, iddl, ej, jj, iddlm, ikc, iadk, jdik, diag_k, lt_k, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition bc_imp0.F:1332

◆ bcl_impb()

subroutine bcl_impb ( integer ict,
integer isk,
skew,
integer nd,
lb,
integer ir )

Definition at line 1264 of file bc_imp0.F.

1266C-----------------------------------------------
1267C I m p l i c i t T y p e s
1268C-----------------------------------------------
1269#include "implicit_f.inc"
1270C-----------------------------------------------
1271C C o m m o n B l o c k s
1272C-----------------------------------------------
1273#include "param_c.inc"
1274C-----------------------------------------------
1275C D u m m y A r g u m e n t s
1276C-----------------------------------------------
1277 INTEGER ICT,ND,ISK,IR
1278 my_real
1279 . skew(lskew,*),lb(*)
1280C-----------------------------------------------
1281C L o c a l V a r i a b l e s
1282C-----------------------------------------------
1283 INTEGER J,K,J1,L
1284 my_real
1285 . ej(3)
1286C----------------BC-------------------------
1287 IF (ict == 4 ) THEN
1288 ej(1)=skew(1,isk)
1289 ej(2)=skew(2,isk)
1290 ej(3)=skew(3,isk)
1291 CALL l_dir2(ej,j,1)
1292 CALL bc_updb(nd ,ej ,j ,ir ,lb )
1293 ELSEIF (ict == 2) THEN
1294 ej(1)=skew(4,isk)
1295 ej(2)=skew(5,isk)
1296 ej(3)=skew(6,isk)
1297 CALL l_dir2(ej,j,2)
1298 CALL bc_updb(nd ,ej ,j ,ir ,lb )
1299 ELSEIF (ict == 1) THEN
1300 ej(1)=skew(7,isk)
1301 ej(2)=skew(8,isk)
1302 ej(3)=skew(9,isk)
1303 CALL l_dir2(ej,j,3)
1304 CALL bc_updb(nd ,ej ,j ,ir ,lb )
1305 ELSEIF (ict == 3) THEN
1306C
1307 CALL bc_updf2d(nd ,skew(7,isk),skew(4,isk),ir ,lb )
1308 ELSEIF (ict == 5) THEN
1309C
1310 CALL bc_updf2d(nd ,skew(7,isk),skew(1,isk),ir ,lb )
1311 ELSEIF (ict == 6) THEN
1312C
1313 CALL bc_updf2d(nd ,skew(4,isk),skew(1,isk),ir ,lb )
1314 ENDIF
1315C
1316 RETURN

◆ bcl_impd()

subroutine bcl_impd ( integer ict,
integer isk,
skew,
integer i,
d )

Definition at line 720 of file bc_imp0.F.

721C-----------------------------------------------
722C I m p l i c i t T y p e s
723C-----------------------------------------------
724#include "implicit_f.inc"
725C-----------------------------------------------
726C C o m m o n B l o c k s
727C-----------------------------------------------
728#include "param_c.inc"
729C-----------------------------------------------
730C D u m m y A r g u m e n t s
731C-----------------------------------------------
732 INTEGER ICT,I, ISK
733 my_real
734 . skew(lskew,*),d(3,*)
735C-----------------------------------------------
736C L o c a l V a r i a b l e s
737C-----------------------------------------------
738 INTEGER J,K,J1,L
739 my_real
740 . ej(3),ej1(3),max_e,ea,eb
741C----------------BC-------negative ICT only possible with 2 dirs------------------
742 IF (ict == 4 ) THEN
743 ej(1)=skew(1,isk)
744 ej(2)=skew(2,isk)
745 ej(3)=skew(3,isk)
746 CALL l_dir2(ej,j,1)
747 d(j,i) = zero
748 CALL bc_updd(i ,ej ,j ,d )
749 ELSEIF (ict == 2) THEN
750 ej(1)=skew(4,isk)
751 ej(2)=skew(5,isk)
752 ej(3)=skew(6,isk)
753 CALL l_dir2(ej,j,2)
754 d(j,i) = zero
755 CALL bc_updd(i ,ej ,j ,d )
756 ELSEIF (ict == 1) THEN
757 ej(1)=skew(7,isk)
758 ej(2)=skew(8,isk)
759 ej(3)=skew(9,isk)
760 CALL l_dir2(ej,j,3)
761 d(j,i) = zero
762 CALL bc_updd(i ,ej ,j ,d )
763 ELSEIF (iabs(ict) == 3) THEN
764 ej(1)=skew(7,isk)
765 ej(2)=skew(8,isk)
766 ej(3)=skew(9,isk)
767C CALL L_DIR2(EJ,J,3)
768 ej1(1)=skew(4,isk)
769 ej1(2)=skew(5,isk)
770 ej1(3)=skew(6,isk)
771 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
772 CALL dir_rbe2(j, j1 ,k)
773C-----FV-BCS coupling
774 IF (ict<0) THEN
775 d(j,i) =d(j,i)- ea*d(k,i)
776 d(j1,i) =d(j1,i)- eb*d(k,i)
777 ELSE
778 d(j,i) = -ea*d(k,i)
779 d(j1,i) = -eb*d(k,i)
780 END IF !(ICT>0) THEN
781C CALL L_DIR2(EJ1,J1,2)
782c IF (J1==J) THEN
783c EJ1(J)=ZERO
784c CALL L_DIR(EJ1,J1)
785c MAX_E=ONE/SKEW(J1+3,ISK)
786c DO K = 1, 3
787c EJ1(K) = MAX_E*SKEW(K+3,ISK)
788c ENDDO
789c ENDIF
790c D(J,I) = ZERO
791c D(J1,I) = ZERO
792c CALL BC_UPDD2(I ,EJ ,J ,EJ1 ,J1 ,D )
793 ELSEIF (iabs(ict) == 5) THEN
794 ej(1)=skew(7,isk)
795 ej(2)=skew(8,isk)
796 ej(3)=skew(9,isk)
797c CALL L_DIR2(EJ,J,3)
798 ej1(1)=skew(1,isk)
799 ej1(2)=skew(2,isk)
800 ej1(3)=skew(3,isk)
801c CALL L_DIR2(EJ1,J1,1)
802 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
803 CALL dir_rbe2(j, j1 ,k)
804 IF (ict<0) THEN
805 d(j,i) =d(j,i)- ea*d(k,i)
806 d(j1,i) =d(j1,i)- eb*d(k,i)
807 ELSE
808 d(j,i) = -ea*d(k,i)
809 d(j1,i) = -eb*d(k,i)
810 END IF !(ICT>0) THEN
811 ELSEIF (iabs(ict) == 6) THEN
812 ej(1)=skew(4,isk)
813 ej(2)=skew(5,isk)
814 ej(3)=skew(6,isk)
815c CALL L_DIR2(EJ,J,2)
816 ej1(1)=skew(1,isk)
817 ej1(2)=skew(2,isk)
818 ej1(3)=skew(3,isk)
819 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
820 CALL dir_rbe2(j, j1 ,k)
821 IF (ict<0) THEN
822 d(j,i) =d(j,i)- ea*d(k,i)
823 d(j1,i) =d(j1,i)- eb*d(k,i)
824 ELSE
825 d(j,i) = -ea*d(k,i)
826 d(j1,i) = -eb*d(k,i)
827 END IF !(ICT>0) THEN
828 ENDIF
829C
830 RETURN

◆ bcl_impk()

subroutine bcl_impk ( integer ict,
integer isk,
skew,
integer, dimension(*) ifix,
integer, dimension(*) iadn,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer i,
integer nd,
integer ir )

Definition at line 265 of file bc_imp0.F.

268C-----------------------------------------------
269C I m p l i c i t T y p e s
270C-----------------------------------------------
271#include "implicit_f.inc"
272C-----------------------------------------------
273C C o m m o n B l o c k s
274C-----------------------------------------------
275#include "param_c.inc"
276C-----------------------------------------------
277C D u m m y A r g u m e n t s
278C-----------------------------------------------
279 INTEGER ICT,IFIX(*),IADN(*),IADK(*) ,JDIK(*),
280 . I, ND,ISK,IR
281 my_real
282 . skew(lskew,*),diag_k(*),lt_k(*)
283C-----------------------------------------------
284C L o c a l V a r i a b l e s
285C-----------------------------------------------
286 INTEGER J,K,J1,L,KC
287 my_real
288 . ej(3)
289C----------------BC-------------------------
290 kc = 8
291 IF (ict == 4 ) THEN
292 ej(1)=skew(1,isk)
293 ej(2)=skew(2,isk)
294 ej(3)=skew(3,isk)
295 CALL l_dir2(ej,j,1)
296 CALL bc_updk(i ,iadn ,ej ,j ,ir ,
297 1 iadk ,jdik ,diag_k,lt_k )
298 ifix(nd +j) = kc
299 ELSEIF (ict == 2) THEN
300 ej(1)=skew(4,isk)
301 ej(2)=skew(5,isk)
302 ej(3)=skew(6,isk)
303 CALL l_dir2(ej,j,2)
304 CALL bc_updk(i ,iadn ,ej ,j ,ir ,
305 1 iadk ,jdik ,diag_k,lt_k )
306 ifix(nd +j) = kc
307 ELSEIF (ict == 1) THEN
308 ej(1)=skew(7,isk)
309 ej(2)=skew(8,isk)
310 ej(3)=skew(9,isk)
311 CALL l_dir2(ej,j,3)
312 CALL bc_updk(i ,iadn ,ej ,j ,ir ,
313 1 iadk ,jdik ,diag_k,lt_k )
314 ifix(nd +j) = kc
315 ELSEIF (ict == 3) THEN
316C
317 CALL bc_updk2d(iadn ,ifix(nd+1),skew(7,isk),skew(4,isk),
318 1 i ,ir ,kc ,iadk ,jdik ,diag_k,
319 2 lt_k )
320 ELSEIF (ict == 5) THEN
321 CALL bc_updk2d(iadn ,ifix(nd+1),skew(7,isk),skew(1,isk),
322 1 i ,ir ,kc ,iadk ,jdik ,diag_k,
323 2 lt_k )
324 ELSEIF (ict == 6) THEN
325C
326 CALL bc_updk2d(iadn ,ifix(nd+1),skew(4,isk),skew(1,isk),
327 1 i ,ir ,kc ,iadk ,jdik ,diag_k,
328 2 lt_k )
329 ELSEIF (ict == 7) THEN
330 ifix(nd +1) = 1
331 ifix(nd +2) = 1
332 ifix(nd +3) = 1
333 ENDIF
334C
335 RETURN

◆ bcl_impkd()

subroutine bcl_impkd ( integer ict,
integer isk,
skew,
kdd,
diag_k )

Definition at line 913 of file bc_imp0.F.

914C-----------------------------------------------
915C I m p l i c i t T y p e s
916C-----------------------------------------------
917#include "implicit_f.inc"
918C-----------------------------------------------
919C C o m m o n B l o c k s
920C-----------------------------------------------
921#include "param_c.inc"
922C-----------------------------------------------
923C D u m m y A r g u m e n t s
924C-----------------------------------------------
925 INTEGER ICT,ISK
926 my_real
927 . skew(lskew,*),diag_k(*),kdd(3,3)
928C-----------------------------------------------
929C L o c a l V a r i a b l e s
930C-----------------------------------------------
931 INTEGER J,K,J1,L
932 my_real
933 . ej(3)
934C----------------BC-------------------------
935 IF (ict == 4 ) THEN
936 ej(1)=skew(1,isk)
937 ej(2)=skew(2,isk)
938 ej(3)=skew(3,isk)
939 CALL l_dir2(ej,j,1)
940 CALL fv_updkd(ej ,j ,kdd ,diag_k)
941 ELSEIF (ict == 2) THEN
942 ej(1)=skew(4,isk)
943 ej(2)=skew(5,isk)
944 ej(3)=skew(6,isk)
945 CALL l_dir2(ej,j,2)
946 CALL fv_updkd(ej ,j ,kdd ,diag_k)
947 ELSEIF (ict == 1) THEN
948 ej(1)=skew(7,isk)
949 ej(2)=skew(8,isk)
950 ej(3)=skew(9,isk)
951 CALL l_dir2(ej,j,3)
952 CALL fv_updkd(ej ,j ,kdd ,diag_k)
953 ELSEIF (ict == 3) THEN
954 CALL fv_updkd2(skew(7,isk),skew(4,isk),kdd ,diag_k)
955 ELSEIF (ict == 5) THEN
956 CALL fv_updkd2(skew(7,isk),skew(1,isk),kdd ,diag_k)
957 ELSEIF (ict == 6) THEN
958 CALL fv_updkd2(skew(4,isk),skew(1,isk),kdd ,diag_k)
959 ENDIF
960C
961 RETURN
fv_updkd2
subroutine fv_updkd2(skew, skew1, kdd, diag_k)
Definition bc_imp0.F:2515
fv_updkd
subroutine fv_updkd(ej, j, kdd, diag_k)
Definition fv_imp0.F:1519

◆ clceig()

subroutine clceig ( amtx,
eigval,
eigvec,
small,
integer nmtx,
integer ierr )

Definition at line 1556 of file bc_imp0.F.

1557C PURPOSE:
1558C
1559C CALCULATE THE EIGENVALUES AND EIGEN VECTORS OF A SYMMETRIC
1560C (N X N) MATRIX USING JACOBI'S METHOD (REF: COMPUTER
1561C APPLICATIONS OF NUMERICAL METHODS - SHAN S. KUO)
1562C
1563C INPUT:
1564C
1565C AMTX(NMTX,NMTX) - MATRIX WHOSE EIGENVALUES AND EIGEN VECTORS
1566C ARE TO BE CALCULATED
1567C SMALL - IF THE RATIO OF MAXIMUM OFF-DIAGONAL
1568C TERM TO CORRESPONDING DIAGONAL TERMS IS
1569C BELOW THIS VALUE, JACOBI METHOD HAS
1570C CONVERGED
1571C NMTX - DIMENSION OF AMTX
1572C
1573C OUTPUT:
1574C
1575C EIGVAL(NMTX) - THE EIGENVALUES OF AMTX
1576C EIGVEC(NMTX,NMTX) - THE EIGEN VECTORS OF AMTX
1577C IERR - ERROR SWITCH
1578C = 0 - NO ERROR ENCOUNTERED
1579C > 0 - ERROR ENCOUNTERED
1580C
1581C-----------------------------------------------
1582C I m p l i c i t T y p e s
1583C-----------------------------------------------
1584#include "implicit_f.inc"
1585C-----------------------------------------------
1586C D u m m y A r g u m e n t s
1587C-----------------------------------------------
1588 INTEGER NMTX, IERR
1589 my_real
1590 * small
1591 my_real
1592 * amtx(nmtx,nmtx), eigval(nmtx), eigvec(nmtx,nmtx)
1593C-----------------------------------------------
1594C L o c a l V a r i a b l e s
1595C-----------------------------------------------
1596 INTEGER I, J, IB, JB, ITN, ITMAX
1597 my_real
1598 * rotn(nmtx,nmtx), work(nmtx,nmtx)
1599 my_real
1600 * big, bratio, bsave, den, tt, ct, st
1601 DATA itmax /50/
1602C
1603C IF AMTX IS A 1 X 1 MATRIX
1604C
1605 IF (nmtx == 1) THEN
1606 eigval(1) = amtx(1,1)
1607 eigvec(1,1) = one
1608 GOTO 999
1609 ENDIF
1610C
1611C INITIALIZE EIGEN VECTOR TO IDENTITY MATRIX
1612C
1613 CALL zero1(eigvec,nmtx*nmtx)
1614 DO 10 i = 1, nmtx
1615 eigvec(i,i) = one
1616 10 CONTINUE
1617C
1618C FIND LARGEST OFF-DIAGONAL TERM IN AMTX THAT NEEDS TO BE ZEROED OUT
1619C
1620 itn = 0
1621 40 big = zero
1622 bsave = zero
1623 DO 60 i = 1, (nmtx - 1)
1624 DO 50 j = (i+1), nmtx
1625C
1626C CALCULATE MAXIMUM NONZERO RATIO BETWEEN OFF-DIAGONAL AND
1627C DIAGONAL TERMS OF THE AMTX IN ROW I
1628C
1629 IF (abs(amtx(i,i)) >= abs(amtx(j,j))) THEN
1630 IF (abs(amtx(i,i)) > small) THEN
1631 bratio = abs(amtx(i,j)/amtx(i,i))
1632 ELSE
1633 bratio = abs(amtx(i,j))/small
1634 ENDIF
1635 ELSE
1636 IF (abs(amtx(j,j)) > small) THEN
1637 bratio = abs(amtx(i,j)/amtx(j,j))
1638 ELSE
1639 bratio = abs(amtx(i,j))/small
1640 ENDIF
1641 ENDIF
1642C
1643 IF (bratio > bsave) THEN
1644 bsave = bratio
1645 ENDIF
1646C
1647C LARGEST OFF-DIAGONAL ELEMENT TO BE ZEROED OUT
1648C
1649 IF (abs(amtx(i,j)) > big) THEN
1650 big = abs(amtx(i,j))
1651 ib = i
1652 jb = j
1653 ENDIF
1654 50 CONTINUE
1655 60 CONTINUE
1656C
1657 IF (bsave <= small) THEN
1658C
1659C JACOBI METHOD HAS CONVERGED; UPDATE EIGENVALUES AND RETURN
1660C
1661 DO 70 i = 1, nmtx
1662 eigval(i) = amtx(i,i)
1663 70 CONTINUE
1664 ELSE
1665C
1666C PERFORM JACOBI ITERATION IF AMTX IS NOT DIAGONALIZED OUT
1667C
1668 itn = itn + 1
1669C
1670C CHECK LIMIT ON NUMBER OF JACOBI ITERATIONS
1671C
1672 IF (itn > itmax) THEN
1673 ierr = 277
1674C CALL OSERR3(IERR,ITMAX,BIG,'CLCEIG',' ',LUNOUT)
1675 GOTO 999
1676 ENDIF
1677C
1678C CALCULATE TANGENT, COSINE AND SINE OF ROTATION ANGLE (THETA)
1679C
1680 den = abs(amtx(ib,ib) - amtx(jb,jb)) +
1681 * sqrt( (amtx(ib,ib) - amtx(jb,jb))**2 +
1682 * four*amtx(ib,jb)**2 )
1683 IF (den > zero) THEN
1684 IF (amtx(ib,ib) >= amtx(jb,jb)) THEN
1685 tt = two*amtx(ib,jb)/den
1686 ELSE
1687 tt = -two*amtx(ib,jb)/den
1688 ENDIF
1689C
1690 ct = one/sqrt(one + tt**2)
1691 st = ct*tt
1692 ELSE
1693 IF (amtx(ib,ib) >= amtx(jb,jb)) THEN
1694 ct = zero
1695 st = one
1696 ELSE
1697 ct = zero
1698 st = -one
1699 ENDIF
1700 ENDIF
1701C
1702C CONSTRUCT ROTATION MATRIX
1703C
1704 CALL zero1(rotn,nmtx*nmtx)
1705 DO 90 i = 1, nmtx
1706 rotn(i,i) = one
1707 90 CONTINUE
1708C
1709 rotn(ib,ib) = ct
1710 rotn(ib,jb) = -st
1711 rotn(jb,ib) = st
1712 rotn(jb,jb) = ct
1713C
1714C CALCULATE TRIPLE PRODUCT, TRANSPOSE(ROTN) X AMTX X ROTN
1715C
1716 DO 130 i = 1, nmtx
1717 DO 120 j = 1, nmtx
1718 IF (j == ib) THEN
1719 work(i,j) = amtx(i,ib)*ct + amtx(i,jb)*st
1720 ELSEIF (j == jb) THEN
1721 work(i,j) = -amtx(i,ib)*st + amtx(i,jb)*ct
1722 ELSE
1723 work(i,j) = amtx(i,j)
1724 ENDIF
1725 120 CONTINUE
1726 130 CONTINUE
1727C
1728 DO 150 i = 1, nmtx
1729 DO 140 j = 1, nmtx
1730 IF (i == ib) THEN
1731 amtx(i,j) = work(ib,j)*ct + work(jb,j)*st
1732 ELSEIF (i == jb) THEN
1733 amtx(i,j) = -work(ib,j)*st + work(jb,j)*ct
1734 ELSE
1735 amtx(i,j) = work(i,j)
1736 ENDIF
1737 140 CONTINUE
1738 150 CONTINUE
1739C
1740C MAKE AMTX SYMMETRIX BY AVERAGING OFF-DIAGONAL TERMS - TO
1741C TAKE CARE OF ROUND-OFF ERRORS IN CALCULATION
1742C
1743 DO 170 i = 1, nmtx
1744 DO 160 j = (i+1), nmtx
1745 amtx(i,j) = half*(amtx(i,j) + amtx(j,i))
1746 amtx(j,i) = amtx(i,j)
1747 160 CONTINUE
1748 170 CONTINUE
1749C
1750C CALCULATE CONTRIBUTION TO EIGEN VECTOR MATRIX
1751C
1752 DO 190 i = 1, nmtx
1753 DO 180 j = 1, nmtx
1754 IF (j == ib) THEN
1755 work(i,j) = eigvec(i,ib)*ct + eigvec(i,jb)*st
1756 ELSEIF (j == jb) THEN
1757 work(i,j) = -eigvec(i,ib)*st + eigvec(i,jb)*ct
1758 ELSE
1759 work(i,j) = eigvec(i,j)
1760 ENDIF
1761 180 CONTINUE
1762 190 CONTINUE
1763 CALL cp_real(nmtx*nmtx,work,eigvec)
1764C
1765 GOTO 40
1766 ENDIF
1767C
1768 999 RETURN
cp_real
subroutine cp_real(n, x, xc)
Definition produt_v.F:871

◆ fv_updkd2()

subroutine fv_updkd2 ( skew,
skew1,
kdd,
diag_k )

Definition at line 2514 of file bc_imp0.F.

2515C-----------------------------------------------
2516C I m p l i c i t T y p e s
2517C-----------------------------------------------
2518#include "implicit_f.inc"
2519C-----------------------------------------------
2520C D u m m y A r g u m e n t s
2521C-----------------------------------------------
2522 my_real
2523 . skew(3),skew1(3),diag_k(3),kdd(3,3)
2524C-----------------------------------------------
2525C L o c a l V a r i a b l e s
2526C-----------------------------------------------
2527 INTEGER I,ND,K,L,J1,K1,L1,J
2528 my_real
2529 . ej(3),ej1(3),s,ea,eb
2530C-----------------------------------------------
2531 ej(1)=skew(1)
2532 ej(2)=skew(2)
2533 ej(3)=skew(3)
2534c CALL L_DIR(EJ,J)
2535 ej1(1)=skew1(1)
2536 ej1(2)=skew1(2)
2537 ej1(3)=skew1(3)
2538c S=ONE/(ONE-EJ(J1)*EJ1(J))
2539c EA=S*(EJ(J1)*EJ1(K)-EJ(K))
2540c EB=S*(EJ1(J)*EJ(K)-EJ1(K))
2541 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
2542 CALL dir_rbe2(j ,j1 ,k )
2543 ea = -ea
2544 eb = -eb
2545 diag_k(k)=diag_k(k)+
2546 . ea*(kdd(j,j)*ea+two*eb*kdd(j,j1)-two*kdd(j,k))
2547 . +eb*(kdd(j1,j1)*eb-two*kdd(j1,k))
2548C
2549 RETURN

◆ get_nspc()

subroutine get_nspc ( integer nspc)

Definition at line 2682 of file bc_imp0.F.

2683C-----------------------------------------------
2684C M o d u l e s
2685C-----------------------------------------------
2686 USE imp_aspc
2687C-----------------------------------------------
2688C I m p l i c i t T y p e s
2689C-----------------------------------------------
2690#include "implicit_f.inc"
2691C-----------------------------------------------
2692C D u m m y A r g u m e n t s
2693C-----------------------------------------------
2694 INTEGER NSPC
2695C
2696 nspc=nspcnt
2697C
2698 RETURN
imp_aspc::nspcnt
integer nspcnt
Definition impbufdef_mod.F:527

◆ l_dir()

subroutine l_dir ( ej,
integer j )

Definition at line 404 of file bc_imp0.F.

405C-----------------------------------------------
406C I m p l i c i t T y p e s
407C-----------------------------------------------
408#include "implicit_f.inc"
409C-----------------------------------------------
410C D u m m y A r g u m e n t s
411C-----------------------------------------------
412 INTEGER J
413 my_real
414 . ej(*)
415C-----------------------------------------------
416C L o c a l V a r i a b l e s
417C-----------------------------------------------
418 INTEGER I
419 my_real
420 . max_e
421C-----------------------------------------------
422 CALL l_dir0(ej ,j)
423 max_e = one/ej(j)
424 DO i = 1, 3
425 ej(i) = max_e*ej(i)
426 ENDDO
427C
428 RETURN
l_dir0
subroutine l_dir0(ej, j)
Definition bc_imp0.F:346

◆ l_dir0()

subroutine l_dir0 ( ej,
integer j )

Definition at line 345 of file bc_imp0.F.

346C-----------------------------------------------
347C I m p l i c i t T y p e s
348C-----------------------------------------------
349#include "implicit_f.inc"
350C-----------------------------------------------
351C D u m m y A r g u m e n t s
352C-----------------------------------------------
353 INTEGER J
354 my_real
355 . ej(*)
356C-----------------------------------------------
357C L o c a l V a r i a b l e s
358C-----------------------------------------------
359 INTEGER I
360 my_real
361 . ej1,ej2,ej3
362C-----------------------------------------------
363 ej1 = abs(ej(1))
364 ej2 = abs(ej(2))
365 ej3 = abs(ej(3))
366 IF (ej1>=max(ej2,ej3)) THEN
367 j = 1
368 ELSEIF (ej2>=max(ej1,ej3)) THEN
369 j = 2
370 ELSE
371 j = 3
372 ENDIF
373C
374 RETURN

◆ l_dir2()

subroutine l_dir2 ( ej,
integer j,
integer j0 )

Definition at line 443 of file bc_imp0.F.

444C-----------------------------------------------
445C I m p l i c i t T y p e s
446C-----------------------------------------------
447#include "implicit_f.inc"
448C-----------------------------------------------
449C D u m m y A r g u m e n t s
450C-----------------------------------------------
451 INTEGER J,J0
452 my_real
453 . ej(*)
454C-----------------------------------------------
455C L o c a l V a r i a b l e s
456C-----------------------------------------------
457 INTEGER I
458 my_real
459 . max_e
460C-----------------------------------------------
461C------- will be same than L_DIR, just not to change so much lines--
462 IF (j0<0 )THEN
463 IF (abs(ej(j0))>em6) THEN
464 j=j0
465 ELSE
466 CALL l_dir0(ej ,j)
467 ENDIF
468 ELSE
469 CALL l_dir0(ej ,j)
470 ENDIF
471 max_e = one/ej(j)
472 DO i = 1, 3
473 ej(i) = max_e*ej(i)
474 ENDDO
475C
476 RETURN

◆ nrmlzauspc()

subroutine nrmlzauspc ( vector,
smleig,
integer length,
integer nzero )

Definition at line 2003 of file bc_imp0.F.

2004
2005C PURPOSE:
2006C
2007C NORMALIZE A VECTOR WITH THE ELEMENT OF LARGEST MAGNITUDE
2008C
2009C DIFFERS FROM NRMLZE THAT IT ZEROS 'SMALL' VECTOR ENTRIES
2010
2011C-----------------------------------------------
2012C I m p l i c i t T y p e s
2013C-----------------------------------------------
2014#include "implicit_f.inc"
2015C-----------------------------------------------
2016C D u m m y A r g u m e n t s
2017C-----------------------------------------------
2018 INTEGER LENGTH,NZERO
2019 my_real
2020 * smleig, vector(length)
2021C-----------------------------------------------
2022C L o c a l V a r i a b l e s
2023C-----------------------------------------------
2024 INTEGER I
2025 my_real
2026 * high
2027
2028 DO i = 1, length
2029 vector(i) = abs(vector(i))
2030 ENDDO
2031 nzero = 0
2032
2033 high = max(vector(1),vector(2))
2034 IF ( length == 3 ) THEN
2035 high = max(high,vector(3))
2036 ENDIF
2037
2038 IF ( high < em10 ) THEN
2039 CALL zero1(vector,length)
2040 nzero = length
2041 ELSE
2042 DO i = 1,length
2043 vector(i) = vector(i)/high
2044 IF ( vector(i) < smleig ) THEN
2045 vector(i) = zero
2046 nzero = nzero + 1
2047 ENDIF
2048 ENDDO
2049 ENDIF
2050
2051 RETURN

◆ put_nspc()

subroutine put_nspc ( integer nspc)

Definition at line 2707 of file bc_imp0.F.

2708C-----------------------------------------------
2709C M o d u l e s
2710C-----------------------------------------------
2711 USE imp_aspc
2712C-----------------------------------------------
2713C I m p l i c i t T y p e s
2714C-----------------------------------------------
2715#include "implicit_f.inc"
2716C-----------------------------------------------
2717C D u m m y A r g u m e n t s
2718C-----------------------------------------------
2719 INTEGER NSPC
2720C
2721 nspcnt=nspc
2722C
2723 RETURN

◆ spc_dir()

subroutine spc_dir ( integer, dimension(3) ikc,
integer j,
integer j1 )

Definition at line 2059 of file bc_imp0.F.

2060C-----------------------------------------------
2061C I m p l i c i t T y p e s
2062C-----------------------------------------------
2063#include "implicit_f.inc"
2064C-----------------------------------------------
2065C D u m m y A r g u m e n t s
2066C-----------------------------------------------
2067 INTEGER IKC(3),J,J1
2068C-----------------------------------------------
2069C L o c a l V a r i a b l e s
2070C-----------------------------------------------
2071 INTEGER I,N,II(3)
2072 j = 0
2073 j1 =0
2074 n =0
2075 DO i = 1, 3
2076 IF (ikc(i) ==15) THEN
2077 n = n+1
2078 ii(n)=i
2079C---------reset in BC_IMPA ---
2080 ikc(i)=0
2081 ENDIF
2082 ENDDO
2083 IF (n>0) j =ii(1)
2084 IF (n>1) j1 =ii(2)
2085
2086 RETURN

◆ upd_aspc()

subroutine upd_aspc ( integer nddl,
integer, dimension(*) ndof,
integer, dimension(*) iddl,
integer, dimension(*) ikc,
integer, dimension(*) itab,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k )

Definition at line 2322 of file bc_imp0.F.

2324C-----------------------------------------------
2325C I m p l i c i t T y p e s
2326C-----------------------------------------------
2327#include "implicit_f.inc"
2328C-----------------------------------------------
2329C C o m m o n B l o c k s
2330C-----------------------------------------------
2331#include "com01_c.inc"
2332C-----------------------------------------------
2333C D u m m y A r g u m e n t s
2334C-----------------------------------------------
2335 INTEGER NDDL,NDOF(*),IDDL(*),IKC(*),ITAB(*),
2336 . IADK(*) ,JDIK(*)
2337 my_real
2338 . diag_k(*),lt_k(*)
2339C-----------------------------------------------
2340C L o c a l V a r i a b l e s
2341C-----------------------------------------------
2342 INTEGER IERR,NZ
2343 my_real,
2344 . DIMENSION(:),ALLOCATABLE :: diag_kp,lt_kp
2345C-----------------------------------------------
2346 IF (nspmd>1) THEN
2347 nz = iadk(nddl+1)-iadk(1)
2348 ALLOCATE(diag_kp(nddl),lt_kp(nz),stat=ierr)
2349 CALL cp_real(nddl,diag_k,diag_kp)
2350 CALL cp_real(nz,lt_k,lt_kp)
2351 CALL spmd_sumf_k(diag_kp ,lt_kp )
2352 CALL upd_aspc0(nddl ,ndof ,iddl ,ikc ,itab ,
2353 . iadk ,jdik ,diag_kp,lt_kp )
2354 DEALLOCATE(diag_kp,lt_kp)
2355 ELSE
2356 CALL upd_aspc0(nddl ,ndof ,iddl ,ikc ,itab ,
2357 . iadk ,jdik ,diag_k,lt_k )
2358 ENDIF
2359C
2360 RETURN
upd_aspc0
subroutine upd_aspc0(nddl, ndof, iddl, ikc, itab, iadk, jdik, diag_k, lt_k)
Definition bc_imp0.F:2105
spmd_sumf_k
subroutine spmd_sumf_k(diag_k, l_k)
Definition imp_spmd.F:1864

◆ upd_aspc0()

subroutine upd_aspc0 ( integer nddl,
integer, dimension(*) ndof,
integer, dimension(*) iddl,
integer, dimension(*) ikc,
integer, dimension(*) itab,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k )

Definition at line 2103 of file bc_imp0.F.

2105C-----------------------------------------------
2106C M o d u l e s
2107C-----------------------------------------------
2108 USE imp_aspc
2109 USE message_mod
2110C-----------------------------------------------
2111C I m p l i c i t T y p e s
2112C-----------------------------------------------
2113#include "implicit_f.inc"
2114C-----------------------------------------------
2115C C o m m o n B l o c k s
2116C-----------------------------------------------
2117#include "com01_c.inc"
2118#include "com04_c.inc"
2119#include "impl1_c.inc"
2120#include "task_c.inc"
2121#include "units_c.inc"
2122C-----------------------------------------------
2123C D u m m y A r g u m e n t s
2124C-----------------------------------------------
2125 INTEGER NDDL,NDOF(*),IDDL(*),IKC(*),ITAB(*),
2126 . IADK(*) ,JDIK(*)
2127 my_real
2128 . diag_k(*),lt_k(*)
2129C-----------------------------------------------
2130C L o c a l V a r i a b l e s
2131C-----------------------------------------------
2132 INTEGER NSPCLI,NSPCT,NSPCTI,I,J,K,N,
2133 . ID(3),IK,IDK,IER1,IER2,IERR,NSPC,IR,NDOFT,J1,NSPCR,
2134 . NSPCN,IKC3
2135C
2136 my_real
2137 * kii(3,3),kdd(6,6),smleig,kdiv3,rs
2138 INTEGER, DIMENSION(:),ALLOCATABLE :: ILT,ILR
2139 my_real, DIMENSION(:,:),ALLOCATABLE ::
2140 . skewt,skewr
2141C-----------------------------------------------
2142 nspcl = 0
2143 nspct = 0
2144 nspcr = 0
2145 nspcn = 0
2146 ierr = 0
2147 smleig = em8
2148 IF(iautspc>1) THEN
2149 ALLOCATE(ilt(numnod),skewt(6,numnod),stat=ier1)
2150 ilt=0
2151 skewt=zero
2152 IF (iroddl/=0) THEN
2153 ALLOCATE(ilr(numnod),skewr(6,numnod),stat=ier2)
2154 ilr=0
2155 skewr=zero
2156 ENDIF
2157 ENDIF
2158 DO i = 1, numnod
2159 IF (ndof(i)==0) cycle
2160 CALL get_kii(i ,iddl ,iadk,diag_k,lt_k ,kdd,ndof(i))
2161 ndoft = min(3,ndof(i))
2162 kdiv3=kdd(1,1)+kdd(2,2)+kdd(3,3)
2163 ik = iddl(i)+1
2164 ikc3=ikc(ik)+ikc(ik+1)+ikc(ik+2)
2165 IF (kdiv3<=em10.AND.ikc3==0) THEN
2166 DO j=1,ndoft
2167 k = iddl(i)+j
2168 ikc(k) = 14
2169 ENDDO
2170 nspct = nspct+3
2171 nspcn = nspcn + 1
2172 ELSEIF(iautspc>1) THEN
2173 DO j=1,ndoft
2174 DO k=j,ndoft
2175 kii(j,k) = kdd(j,k)
2176 ENDDO
2177 ENDDO
2178 DO j=1,ndoft
2179 DO k=j+1,ndoft
2180 kii(k,j) = kii(j,k)
2181 ENDDO
2182 ENDDO
2183 DO j=1,ndoft
2184 id(j) = iddl(i)+j
2185 ENDDO
2186 idk = id(1)
2187 CALL autspc(kii,id ,skewt(1,i),smleig,nddl ,
2188 * ikc(idk),ilt(i),nspcti ,ierr )
2189 IF (ierr > 0) THEN
2190 ierr = i
2191 GO TO 900
2192 ENDIF
2193 nspct = nspct+nspcti
2194 nspcl = nspcl + min(1,ilt(i))
2195 IF ((ilt(i)+nspcti)>0) nspcn = nspcn + 1
2196 ENDIF !((KDD(1,1)+KDD(2,2)+KDD(3,3))<=EM10) THEN
2197 IF (ndof(i)==6) THEN
2198 ik = iddl(i)+4
2199 ikc3=ikc(ik)+ikc(ik+1)+ikc(ik+2)
2200 IF ((kdd(4,4)+kdd(5,5)+kdd(6,6))<=em10.AND.ikc3==0) THEN
2201 DO j=1,ndoft
2202 k = iddl(i)+j + 3
2203 ikc(k) = 14
2204 ENDDO
2205 nspcr = nspcr+3
2206 IF (kdiv3>em10) nspcn = nspcn + 1
2207 ELSEIF(iautspc>1) THEN
2208 DO j=1,ndoft
2209 DO k=j,ndoft
2210 kii(j,k) = kdd(j+3,k+3)
2211 ENDDO
2212 ENDDO
2213 DO j=1,ndoft
2214 DO k=j+1,ndoft
2215 kii(k,j) = kii(j,k)
2216 ENDDO
2217 ENDDO
2218 DO j=1,ndoft
2219 id(j) = iddl(i)+j+3
2220 ENDDO
2221 idk = id(1)
2222 CALL autspc(kii,id ,skewr(1,i),smleig,nddl ,
2223 * ikc(idk) ,ilr(i),nspcti ,ierr )
2224 IF (ierr > 0) THEN
2225 ierr = i
2226 GO TO 900
2227 ENDIF
2228 nspcr = nspcr+nspcti
2229 nspcl = nspcl + min(1,ilr(i))
2230 IF ((ilr(i)+nspcti)>0) nspcn = nspcn + 1
2231 END IF !((KDD(4,4)+KDD(5,5)+KDD(6,6))<=EM10) THEN
2232 ENDIF
2233 ENDDO
2234C
2235 nspcnt = nspcn
2236 IF (nspcn>0.AND.iline/=0) THEN
2237 IF(ispmd==0)THEN
2238 WRITE(istdo,'(I10,A)')nspcn,
2239 . ' NODES TREATED BY AUTOSPC FOR :'
2240 WRITE(istdo,'(I10,A)')nspct,
2241 . ' TRANSLATIONAL DOFS'
2242 WRITE(istdo,'(I10,A)')nspcr,
2243 . ' ROTATIONAL DOFS'
2244 WRITE(iout,'(I10,A)')nspcn,
2245 . ' NODES TREATED BY AUTOSPC FOR :'
2246 WRITE(iout,'(I10,A)')nspct,
2247 . ' TRANSLATIONAL DOFS'
2248 WRITE(iout,'(I10,A)')nspcr,
2249 . ' ROTATIONAL DOFS'
2250 ENDIF
2251 ENDIF
2252C
2253 IF (nspcl>0) THEN
2254 IF(ALLOCATED(in_spc)) DEALLOCATE(in_spc)
2255 IF(ALLOCATED(ic_spc)) DEALLOCATE(ic_spc)
2256 ALLOCATE(in_spc(nspcl),ic_spc(nspcl),stat=ier1)
2257 IF(ALLOCATED(skew_spc)) DEALLOCATE(skew_spc)
2258 ALLOCATE(skew_spc(6*nspcl),stat=ier2)
2259 ic_spc =0
2260 in_spc =0
2261 skew_spc=zero
2262 nspc = 0
2263 DO i = 1, numnod
2264 IF (ilt(i)>0) THEN
2265 nspc = nspc +1
2266 ir = 0
2267 in_spc(nspc) = i
2268 CALL spc_dir(ikc(iddl(i)+1),j ,j1 )
2269 ic_spc(nspc) = ilt(i)
2270 j = 6*(nspc-1)+1
2271 skew_spc(j)=skewt(1,i)
2272 skew_spc(j+1)=skewt(2,i)
2273 skew_spc(j+2)=skewt(3,i)
2274 IF (ilt(i)==2) THEN
2275 skew_spc(j+3)=skewt(4,i)
2276 skew_spc(j+4)=skewt(5,i)
2277 skew_spc(j+5)=skewt(6,i)
2278 ENDIF
2279 ENDIF
2280 IF (ilr(i)>0) THEN
2281 ir = 1
2282 nspc = nspc +1
2283 in_spc(nspc) = i
2284 CALL spc_dir(ikc(iddl(i)+4),j ,j1 )
2285 ic_spc(nspc) = ilr(i) + 3
2286 j = 6*(nspc-1)+1
2287 skew_spc(j)=skewr(1,i)
2288 skew_spc(j+1)=skewr(2,i)
2289 skew_spc(j+2)=skewr(3,i)
2290 IF (ilr(i)==2) THEN
2291 skew_spc(j+3)=skewr(4,i)
2292 skew_spc(j+4)=skewr(5,i)
2293 skew_spc(j+5)=skewr(6,i)
2294 ENDIF
2295 ENDIF
2296 ENDDO
2297 ENDIF
2298C
2299 900 CONTINUE
2300 IF(iautspc>1) THEN
2301 DEALLOCATE(ilt,skewt)
2302 IF (iroddl/=0) DEALLOCATE(ilr,skewr)
2303 ENDIF
2304 IF (ierr>0) THEN
2305 IF(ispmd==0)THEN
2306 CALL ancmsg(msgid=102,anmode=aninfo,
2307 . i1=itab(ierr))
2308 ENDIF
2309 CALL arret(2)
2310 ENDIF
2311 RETURN
autspc
subroutine autspc(kii, ideg, raspcc, smleig, nddl, ikc, naspcc, lauspc, ierr)
Definition bc_imp0.F:1781
spc_dir
subroutine spc_dir(ikc, j, j1)
Definition bc_imp0.F:2060
min
#define min(a, b)
Definition macros.h:20
message_mod
Definition message_mod.F:1249
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
arret
subroutine arret(nn)
Definition arret.F:87