OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
intbuf_fric_copy.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!|| intbuf_fric_copy ../starter/source/interfaces/interf1/intbuf_fric_copy.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- uses -----------------------------------------------------
28!|| message_mod ../starter/share/message_module/message_mod.F
29!||====================================================================
30 SUBROUTINE intbuf_fric_copy(
31 . TABCOUPLEPARTS_FRIC_TMP ,TABCOEF_FRIC_TMP ,
32 . TABPARTS_FRIC_TMP,NSETINIT,IFRICORTH_TMP,INTBUF_FRIC_TAB)
33C============================================================================
34C M o d u l e s
35C-----------------------------------------------
36 USE message_mod
37 USE intbuf_fric_mod
38C-----------------------------------------------
39C I m p l i c i t T y p e s
40C-----------------------------------------------
41#include "implicit_f.inc"
42C-----------------------------------------------
43C C o m m o n B l o c k s
44C-----------------------------------------------
45#include "com04_c.inc"
46C-----------------------------------------------
47C D u m m y A r g u m e n t s
48C-----------------------------------------------
49 INTEGER TABCOUPLEPARTS_FRIC_TMP(NINTERFRIC,*),TABPARTS_FRIC_TMP(NINTERFRIC,*),
50 . NSETINIT(NINTERFRIC) ,IFRICORTH_TMP(NINTERFRIC,*)
51 my_real
52 . tabcoef_fric_tmp(ninterfric,*)
53
54 TYPE(intbuf_fric_struct_), TARGET, DIMENSION(NINTERFRIC) :: INTBUF_FRIC_TAB(*)
55C-----------------------------------------------
56C L o c a l V a r i a b l e s
57C-----------------------------------------------
58 INTEGER NIF , NSET ,I ,J ,K ,N ,IP ,NSETT ,NPARTF ,IORTH ,MFROT ,LENC
59 INTEGER, DIMENSION(:) ,POINTER :: TABCOUPLEPARTS_FRIC
60 INTEGER, DIMENSION(:) ,POINTER :: TABPARTS_FRIC
61 INTEGER, DIMENSION(:) ,POINTER :: ADPART_FRIC
62 INTEGER, DIMENSION(:) ,POINTER :: IFRICORTH
63 my_real, DIMENSION(:) ,POINTER :: tabcoef_fric
64C
65C--------------------------------------------
66C=======================================================================
67
68 DO nif = 1, ninterfric
69 tabcoupleparts_fric => intbuf_fric_tab(nif)%TABCOUPLEPARTS_FRIC
70 tabcoef_fric => intbuf_fric_tab(nif)%TABCOEF_FRIC
71 tabparts_fric => intbuf_fric_tab(nif)%TABPARTS_FRIC
72 adpart_fric => intbuf_fric_tab(nif)%ADPARTS_FRIC
73 nset = intbuf_fric_tab(nif)%NSETPRTS
74 nsett = nsetinit(nif)
75 npartf = intbuf_fric_tab(nif)%S_TABPARTS_FRIC
76 iorth = intbuf_fric_tab(nif)%IORTHFRIC
77 ifricorth => intbuf_fric_tab(nif)%IFRICORTH
78 mfrot = intbuf_fric_tab(nif)%FRICMOD
79
80 IF(mfrot ==0 ) THEN
81 lenc =2
82 ELSE
83 lenc = 8
84 ENDIF
85
86C----------Copying default values of friction in the top of the Tab TABCOEF_FRIC_TMP
87 DO j=1,lenc
88 tabcoef_fric(j) =tabcoef_fric_tmp(nif,j)
89 ENDDO
90C----------Copying parts numbers and coefficient in the new structure and omitting duplicated couple of parts
91 j = 1
92 k = 0
93 IF(iorth == 0) THEN
94 DO i=1,nsett
95 IF( tabcoupleparts_fric_tmp(nif,j)/= 0) THEN
96 k = k +1
97C
98 tabcoupleparts_fric(k) = tabcoupleparts_fric_tmp(nif,j+1)
99C
100 DO n=1,lenc
101 tabcoef_fric(lenc*k+n) =tabcoef_fric_tmp(nif,i*8+n)
102 ENDDO
103C
104 ifricorth(k) = ifricorth_tmp(nif,i)
105 ENDIF
106 j = j+2
107 ENDDO
108 ELSEIF(iorth==1) THEN
109 DO i=1,nsett
110 IF( tabcoupleparts_fric_tmp(nif,j)/= 0) THEN
111 k = k +1
112C
113 tabcoupleparts_fric(k) = tabcoupleparts_fric_tmp(nif,j+1)
114C
115 DO n=1,lenc
116 tabcoef_fric(lenc+2*lenc*(k-1)+n) =tabcoef_fric_tmp(nif,8+16*(i-1)+n)
117 tabcoef_fric(2*k*lenc+n) =tabcoef_fric_tmp(nif,16*i+n)
118 ENDDO
119 ifricorth(k) = ifricorth_tmp(nif,i)
120 ENDIF
121C
122
123 j = j+2
124 ENDDO
125
126 ENDIF
127
128C----------Copying parts tab tagged by friction model
129 DO i=1,npartf
130 tabparts_fric(i) = tabparts_fric_tmp(nif,i)
131 ENDDO
132
133C----------Computation of the address of each part in the tabs TABPARTSFRIC TABCOEF_FRIC_TMP
134 adpart_fric(1) = 1
135 adpart_fric(2:npartf+1) = 0
136 DO i=1,npartf
137 k = 0
138 j = 1
139 DO n=1,nsett
140 IF( tabcoupleparts_fric_tmp(nif,j)/= 0) THEN
141 k = k + 1
142 IF(tabcoupleparts_fric_tmp(nif,j) == tabparts_fric(i)) THEN
143 adpart_fric(i+1) = adpart_fric(i+1) + 1
144 ENDIF
145 ENDIF
146 j = j +2
147 ENDDO
148 ENDDO
149 DO i=1,npartf
150 k = i +1
151 adpart_fric(k) =adpart_fric(k) +adpart_fric(i)
152 ENDDO
153
154 ENDDO
155C
156 RETURN
157
158 END SUBROUTINE intbuf_fric_copy
159
160
my_real
#define my_real
Definition cppsort.cpp:32
intbuf_fric_copy
subroutine intbuf_fric_copy(tabcoupleparts_fric_tmp, tabcoef_fric_tmp, tabparts_fric_tmp, nsetinit, ifricorth_tmp, intbuf_fric_tab)
Definition intbuf_fric_copy.F:33
message_mod
Definition message_mod.F:1249