OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
trintfric.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| triintfric ../starter/source/interfaces/interf1/trintfric.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!||--- uses -----------------------------------------------------
29!|| message_mod ../starter/share/message_module/message_mod.F
30!||====================================================================
31 SUBROUTINE triintfric(
32 . TABCOUPLEPARTS_FRIC_TMP ,TABCOEF_FRIC_TMP ,INTBUF_FRIC_TAB ,
33 . TABPARTS_FRIC_TMP,NSETFRICTOT,NSETINIT,IORTHFRICMAX,IFRICORTH_TMP,
34 . NSETMAX )
35
36C============================================================================
37C M o d u l e s
38C-----------------------------------------------
39 USE message_mod
40 USE intbuf_fric_mod
41C-----------------------------------------------
42C I m p l i c i t T y p e s
43C-----------------------------------------------
44#include "implicit_f.inc"
45C-----------------------------------------------
46C C o m m o n B l o c k s
47C-----------------------------------------------
48#include "com04_c.inc"
49C-----------------------------------------------
50C D u m m y A r g u m e n t s
51C-----------------------------------------------
52 INTEGER NSETFRICTOT,IORTHFRICMAX,NSETMAX
53 INTEGER TABCOUPLEPARTS_FRIC_TMP(NINTERFRIC,*),NSETINIT(NINTERFRIC),
54 . TABPARTS_FRIC_TMP(NINTERFRIC,*),IFRICORTH_TMP(NINTERFRIC,*)
55
56 my_real
57 . tabcoef_fric_tmp(ninterfric,*)
58
59 TYPE(INTBUF_FRIC_STRUCT_) INTBUF_FRIC_TAB(*)
60C-----------------------------------------------
61C L o c a l V a r i a b l e s
62C-----------------------------------------------
63 INTEGER NIF , NSET ,I ,J ,K ,STAT ,NSETT ,IORTH ,
64 . WORK(70000)
65 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX ,ITRI2 ,INDEX2
66 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ITRI
67 INTEGER, DIMENSION(:), ALLOCATABLE :: TRIFRIORTH
68 my_real, DIMENSION(:,:), ALLOCATABLE :: tricoef
69C
70C--------------------------------------------
71
72 ALLOCATE(index(2*nsetmax), stat=stat)
73 ALLOCATE(itri(2,nsetmax), stat=stat)
74 IF(iorthfricmax == 0 ) THEN
75 ALLOCATE(tricoef(nsetmax,8), stat=stat)
76 ELSE
77 ALLOCATE(tricoef(nsetmax,16), stat=stat)
78 ENDIF
79 ALLOCATE(itri2(2*nsetmax), stat=stat)
80 ALLOCATE(index2(4*nsetmax), stat=stat)
81 ALLOCATE(trifriorth(nsetmax), stat=stat)
82
83C
84 DO nif=1,ninterfric
85 nset = intbuf_fric_tab(nif)%NSETPRTS
86 iorth = intbuf_fric_tab(nif)%IORTHFRIC
87 j = 1
88C------Copy-----------------------------
89 DO i=1,nset
90 itri(1,i) = tabcoupleparts_fric_tmp(nif,j)
91 itri(2,i) = tabcoupleparts_fric_tmp(nif,j+1)
92 index(i)=i
93 j = j+2
94 ENDDO
95 DO i=1,nset
96 trifriorth(i) = ifricorth_tmp(nif,i)
97 ENDDO
98 IF(iorth == 0 ) THEN
99 DO i=1,nset
100 DO j=1,8
101 tricoef(i,j) = tabcoef_fric_tmp(nif,i*8+j)
102 ENDDO
103 ENDDO
104 ELSEIF(iorth == 1 ) THEN
105 DO i=1,nset
106 DO j=1,16
107 tricoef(i,j) = tabcoef_fric_tmp(nif,8+16*(i-1)+j)
108 ENDDO
109 ENDDO
110 ENDIF
111C----------------------
112 CALL my_orders( 0, work, itri, index, nset , 2)
113C
114 j = 1
115 DO i=1,nset
116 tabcoupleparts_fric_tmp(nif,j)= itri(1,index(i))
117 tabcoupleparts_fric_tmp(nif,j+1)= itri(2,index(i))
118 j = j+2
119 ENDDO
120
121C------Delete duplicated parts pairs-----------------------------
122 nsetinit(nif) = nset
123 j = 1
124 k = nset
125 DO i=1,nset-1
126 IF(tabcoupleparts_fric_tmp(nif,j)==tabcoupleparts_fric_tmp(nif,j+2).AND.
127 . tabcoupleparts_fric_tmp(nif,j+1)==tabcoupleparts_fric_tmp(nif,j+3) ) THEN
128 tabcoupleparts_fric_tmp(nif,j) = 0
129 tabcoupleparts_fric_tmp(nif,j+1) = 0
130 k = k - 1
131 ENDIF
132 j = j + 2
133 ENDDO
134 intbuf_fric_tab(nif)%NSETPRTS = k
135
136C---------Tabs of tagged parts---------------------------------
137 k = 0
138 j = 1
139 DO i =1,nset
140 IF(tabcoupleparts_fric_tmp(nif,j) /= 0 ) THEN
141 k = k +1
142 tabparts_fric_tmp(nif,k) = tabcoupleparts_fric_tmp(nif,j)
143 ENDIF
144c
145 j = j +1
146 IF(tabcoupleparts_fric_tmp(nif,j) /= 0 ) THEN
147 k = k +1
148 tabparts_fric_tmp(nif,k) = tabcoupleparts_fric_tmp(nif,j)
149 ENDIF
150 j = j +1
151 ENDDO
152
153 nsett = k
154
155 DO i =1,nsett
156 itri2(i) = tabparts_fric_tmp(nif,i)
157 index2(i)=i
158 ENDDO
159 CALL my_orders( 0, work, itri2, index2, nsett , 1)
160
161 DO i =1,nsett
162 tabparts_fric_tmp(nif,i) = itri2(index2(i))
163 ENDDO
164
165 k = 1
166 DO i =1,nsett
167 IF(tabparts_fric_tmp(nif,k) /= tabparts_fric_tmp(nif,i)) THEN
168 k = k +1
169 tabparts_fric_tmp(nif,k) = tabparts_fric_tmp(nif,i)
170 ENDIF
171 ENDDO
172 IF(nsett > 0) THEN
173 intbuf_fric_tab(nif)%S_TABPARTS_FRIC = k
174 ELSE
175 intbuf_fric_tab(nif)%S_TABPARTS_FRIC = 0
176 ENDIF
177C------Coefs-----------------------------
178 DO i=1,nset
179 ifricorth_tmp(nif,i) = trifriorth(index(i))
180 ENDDO
181
182 IF(iorth == 0 ) THEN
183 DO i=1,nset
184 DO j=1,8
185 tabcoef_fric_tmp(nif,i*8+j) = tricoef(index(i),j)
186 ENDDO
187 ENDDO
188 ELSEIF(iorth == 1) THEN
189 DO i=1,nset
190 DO j=1,16
191 tabcoef_fric_tmp(nif,8+(i-1)*16+j) = tricoef(index(i),j)
192 ENDDO
193 ENDDO
194 ENDIF
195 ENDDO
196C
197 DEALLOCATE(index)
198 DEALLOCATE(itri)
199 DEALLOCATE(tricoef)
200 DEALLOCATE(itri2,index2)
201 DEALLOCATE(trifriorth)
202C
203 RETURN
204 END SUBROUTINE triintfric
205
206
my_real
#define my_real
Definition cppsort.cpp:32
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
message_mod
Definition message_mod.F:1249
triintfric
subroutine triintfric(tabcoupleparts_fric_tmp, tabcoef_fric_tmp, intbuf_fric_tab, tabparts_fric_tmp, nsetfrictot, nsetinit, iorthfricmax, ifricorth_tmp, nsetmax)
Definition trintfric.F:35