OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_friction.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!|| hm_read_friction ../starter/source/interfaces/friction/reader/hm_read_friction.F
25!||--- called by ------------------------------------------------------
26!|| hm_read_friction_models ../starter/source/interfaces/friction/reader/hm_read_friction_models.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| fretitl ../starter/source/starter/freform.F
30!|| hm_get_float_array_index ../starter/source/devtools/hm_reader/hm_get_float_array_index.F
31!|| hm_get_floatv ../starter/source/devtools/hm_reader/hm_get_floatv.F
32!|| hm_get_int_array_index ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
33!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
34!||--- uses -----------------------------------------------------
35!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
36!|| message_mod ../starter/share/message_module/message_mod.F
37!|| submodel_mod ../starter/share/modules1/submodel_mod.f
38!||====================================================================
39 SUBROUTINE hm_read_friction(
40 1 NIF ,NOM_OPT ,TITR ,UNITAB ,IGRPART ,
41 2 IPART ,NSET ,TAGPRT_FRIC,TABCOUPLEPARTS_FRIC_TMP ,
42 . TABCOEF_FRIC_TMP ,
43 3 MFROT ,IFQ ,XFILTR ,FRICFORM ,
44 4 IFLAG ,ORTHFRIC ,IFRICORTH_TMP,NGRPF ,
45 4 LENGRPF ,LENG ,NOINTF ,LSUBMODEL )
46
47C============================================================================
48C-----------------------------------------------
49C M o d u l e s
50C-----------------------------------------------
51 USE unitab_mod
52 USE message_mod
53 USE groupdef_mod
54 USE submodel_mod
55 USE hm_option_read_mod
56 USE names_and_titles_mod , ONLY : nchartitle
57C-----------------------------------------------
58C I m p l i c i t T y p e s
59C-----------------------------------------------
60#include "implicit_f.inc"
61C-----------------------------------------------
62C C o m m o n B l o c k s
63C-----------------------------------------------
64#include "scr17_c.inc"
65C-----------------------------------------------
66C D u m m y A r g u m e n t s
67C-----------------------------------------------
68 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
69 INTEGER NOM_OPT(LNOPT1,*)
70 INTEGER NIF ,IFLAG ,MFROT ,IFQ ,FRICFORM ,NSET ,ORTHFRIC , NGRPF,LENG,NOINTF
71 INTEGER IPART(LIPART1,*) ,TAGPRT_FRIC(*),
72 . TABCOUPLEPARTS_FRIC_TMP(NINTERFRIC,*),IFRICORTH_TMP(NINTERFRIC,*),
73 . LENGRPF(*)
74 my_real xfiltr
75 my_real tabcoef_fric_tmp(ninterfric,*)
76 CHARACTER(LEN=NCHARTITLE)::TITR
77C-----------------------------------------------
78 TYPE (GROUP_) , DIMENSION(NGRPART) :: IGRPART
79 TYPE (SUBMODEL_DATA), DIMENSION(*),INTENT(IN) :: LSUBMODEL
80C-----------------------------------------------
81C C o m m o n B l o c k s
82C-----------------------------------------------
83#include "com04_c.inc"
84#include "units_c.inc"
85C-----------------------------------------------
86C L o c a l V a r i a b l e s
87C-----------------------------------------------
88 INTEGER I ,J ,IP ,N ,N1 ,N2 ,KK ,NL ,
89 . GRPART1 ,GRPART2 ,IPART1 ,IPART2 ,FLAGP1 ,FLAGP2,FLAGGRP1,
90 . FLAGGRP2 ,IDTGRS1 ,IDTGRS2 ,NCOUPLE ,
91 . IPP ,IPP1 ,IPP2 ,IDIR ,NTAB ,LENF ,GRPN ,GRPN1 ,GRPN2 ,
92 . NP0 ,NGR0 ,K ,NGR ,J1 ,J2 ,STAT ,WORK(70000),NINPUT
93 INTEGER, DIMENSION(:), ALLOCATABLE ::
94 . trigrpt ,index ,newgrp ,tagg1 ,tagg2
95 my_real
96 . c1 ,c2 ,c3 ,c4 ,c5 ,c6 ,alpha ,c11 ,c22 ,c33 ,c44 ,c55 ,c66 ,
97 . fric ,viscf ,fric2 ,viscf2
98 LOGICAL IS_AVAILABLE
99
100C=======================================================================
101C READING FRICTION Model /FRICTION
102C=======================================================================
103 ip = -huge(ip)
104 idtgrs1 = -huge(idtgrs1)
105 idtgrs2 = -huge(idtgrs2)
106
107 is_available = .false.
108
109 ALLOCATE (trigrpt(leng),stat=stat)
110 ALLOCATE (index(2*leng),stat=stat)
111 ALLOCATE (newgrp(leng+1),stat=stat)
112 ALLOCATE (tagg1(leng),stat=stat)
113 ALLOCATE (tagg2(leng),stat=stat)
114
115 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,nif),ltitr)
116C
117 nom_opt(1,nif)=nointf
118C
119 nset = 0
120 ncouple = 0
121C
122 lenf = 0
123 IF(iflag==0 ) THEN
124 orthfric = 0
125 ELSE
126 IF(orthfric ==0) THEN
127 lenf= 1
128 ELSE
129 lenf = 2
130 ENDIF
131 ENDIF
132
133C--------------------------------------------------
134C DEFAULT VALUES
135C--------------------------------------------------
136
137C EXTRACT DATAS (INTEGER VALUES)
138 CALL hm_get_intv('ifric',mfrot,is_available,lsubmodel)
139 CALL hm_get_intv('ifiltr',ifq,is_available,lsubmodel)
140 CALL hm_get_intv('iform',fricform,is_available,lsubmodel)
141C
142C EXTRACT DATAS (REAL VALUES)
143 CALL hm_get_floatv('xfreq',alpha,is_available,lsubmodel,unitab)
144 CALL hm_get_floatv('c1',c1,is_available,lsubmodel,unitab)
145 CALL hm_get_floatv('c2',c2,is_available,lsubmodel,unitab)
146 CALL hm_get_floatv('c3',c3,is_available,lsubmodel,unitab)
147 CALL hm_get_floatv('c4',c4,is_available,lsubmodel,unitab)
148
149 CALL hm_get_floatv('c5',c5,is_available,lsubmodel,unitab)
150 CALL hm_get_floatv('c6',c6,is_available,lsubmodel,unitab)
151 CALL hm_get_floatv('fric',fric,is_available,lsubmodel,unitab)
152 CALL hm_get_floatv('vis_f',viscf,is_available,lsubmodel,unitab)
153C
154C CHECKS
155C
156 IF (alpha==0.) ifq = 0
157 alpha = alpha
158
159 IF (fricform==0) fricform = 1
160 IF (fricform==2.AND.ifq<10) ifq = ifq + 10
161C
162 IF (ifq>0) THEN
163 IF (ifq==10) xfiltr = one
164 IF (mod(ifq,10)==1) xfiltr = alpha
165 IF (mod(ifq,10)==2) xfiltr=four*atan2(one,zero) / alpha
166 IF (mod(ifq,10)==3) xfiltr=four*atan2(one,zero) * alpha
167 IF (xfiltr<zero) THEN
168 CALL ancmsg(msgid=1591, msgtype=msgerror, anmode=aninfo_blind_1, i1=nointf, c1=titr, r1=alpha)
169 ELSEIF (xfiltr>1.AND.mod(ifq,10)<=2) THEN
170 CALL ancmsg(msgid=1591, msgtype=msgerror, anmode=aninfo_blind_1, i1=nointf, c1=titr, r1=alpha)
171 ENDIF
172 ELSE
173 xfiltr = zero
174 ENDIF
175
176C
177C STORAGE IN TEMPORARY INTBUF_FRIC_TAB
178C
179 IF(iflag == 1 ) THEN
180
181 IF((fric/=zero.OR.mfrot/=0).AND.viscf==zero)viscf=one
182
183 IF (fricform==2)viscf=zero
184
185 tabcoef_fric_tmp(nif,1) = fric
186 tabcoef_fric_tmp(nif,2) = viscf
187 IF( mfrot > 0) THEN
188 tabcoef_fric_tmp(nif,3) = c1
189 tabcoef_fric_tmp(nif,4) = c2
190 tabcoef_fric_tmp(nif,5) = c3
191 tabcoef_fric_tmp(nif,6) = c4
192 tabcoef_fric_tmp(nif,7) = c5
193 tabcoef_fric_tmp(nif,8) = c6
194 ENDIF
195 ENDIF
196C
197C- OUTPUT DESCRIPTION OF THE MODEL
198C 1st defaults
199
200 IF(iflag==1) THEN
201 WRITE(iout,1500) nointf, trim(titr)
202 IF(fricform ==2) THEN
203 WRITE(iout,1508)
204 ELSE
205 WRITE(iout,1509)
206 ENDIF
207 IF(mfrot==0)THEN
208 WRITE(iout,1503)
209 ELSEIF(mfrot==1)THEN
210 WRITE(iout,3505)
211 ELSEIF(mfrot==2)THEN
212 WRITE(iout,3506)
213 ELSEIF(mfrot==3)THEN
214 WRITE(iout,3507)
215 ELSEIF(mfrot==4)THEN
216 WRITE(iout,3508)
217 ENDIF
218 WRITE(iout,1502)mod(ifq,10), xfiltr
219 WRITE(iout,1501)
220
221 IF(mfrot==0)THEN
222 WRITE(iout,3503) fric
223 IF(fricform /= 2) WRITE(iout,3504) viscf
224 ELSEIF(mfrot==1)THEN
225 WRITE(iout,1504) fric,c1,c2,c3,c4,c5,c6
226 ELSEIF(mfrot==2)THEN
227 WRITE(iout,1505) fric,c1,c2,c3,c4,c5,c6
228 ELSEIF(mfrot==3)THEN
229 WRITE(iout,1506) c1,c2,c3,c4,c5,c6
230 ELSEIF(mfrot==4)THEN
231 WRITE(iout,1514) fric,c1,c2
232 ENDIF
233 ENDIF
234C
235
236C--------------------------------------------------
237C FRICION COEFFICIENTS TABLE FOR CONNECTED PARTS
238C--------------------------------------------------
239
240
241C- OUTPUT DESCRIPTION OF THE MODEL
242C Coefficients table
243
244 IF(iflag==1) WRITE(iout,1507)
245
246C EXTRACT DATAS (INTEGER VALUES) : Number of connected parts as defined by user
247 CALL hm_get_intv('N',ninput,is_available,lsubmodel)
248
249 DO nl=1,ninput
250
251C EXTRACT DATAS (INTEGER VALUES)
252
253 CALL hm_get_int_array_index('grpart_ID1',grpart1,nl,is_available,lsubmodel)
254 CALL hm_get_int_array_index('grpart_ID2',grpart2,nl,is_available,lsubmodel)
255 CALL hm_get_int_array_index('part_ID1',ipart1,nl,is_available,lsubmodel)
256 CALL hm_get_int_array_index('part_ID2',ipart2,nl,is_available,lsubmodel)
257 CALL hm_get_int_array_index('Idir',idir,nl,is_available,lsubmodel)
258
259C EXTRACT DATAS (REAL VALUES)
260
261 CALL hm_get_float_array_index('c1_part',c1,nl,is_available,lsubmodel,unitab)
262 CALL hm_get_float_array_index('c2_part',c2,nl,is_available,lsubmodel,unitab)
263 CALL hm_get_float_array_index('c3_part',c3,nl,is_available,lsubmodel,unitab)
264 CALL hm_get_float_array_index('c4_part',c4,nl,is_available,lsubmodel,unitab)
265 CALL hm_get_float_array_index('c5_part',c5,nl,is_available,lsubmodel,unitab)
266 CALL hm_get_float_array_index('c6_part',c6,nl,is_available,lsubmodel,unitab)
267 CALL hm_get_float_array_index('fric_part',fric,nl,is_available,lsubmodel,unitab)
268 CALL hm_get_float_array_index('vis_f_part',viscf,nl,is_available,lsubmodel,unitab)
269
270 IF(idir ==1) THEN
271 orthfric =1
272 CALL hm_get_float_array_index('c1_2',c11,nl,is_available,lsubmodel,unitab)
273 CALL hm_get_float_array_index('c2_2',c22,nl,is_available,lsubmodel,unitab)
274 CALL hm_get_float_array_index('c3_2',c33,nl,is_available,lsubmodel,unitab)
275 CALL hm_get_float_array_index('c4_2',c44,nl,is_available,lsubmodel,unitab)
276 CALL hm_get_float_array_index('c5_2',c55,nl,is_available,lsubmodel,unitab)
277 CALL hm_get_float_array_index('c6_2',c66,nl,is_available,lsubmodel,unitab)
278 CALL hm_get_float_array_index('fric_2',fric2,nl,is_available,lsubmodel,unitab)
279 CALL hm_get_float_array_index('vis_f_2',viscf2,nl,is_available,lsubmodel,unitab)
280
281 ENDIF
282
283C
284C----CHECKS PARTS
285C
286 flagp1 = 0
287 flagp2 = 0
288 flaggrp1 = 0
289 flaggrp2 = 0
290 n1 = -huge(n1)
291 IF(ipart1/=0)THEN
292 DO n=1,npart
293 IF(ipart1 == ipart(4,n))THEN
294 flagp1 = 1
295 n1 = n
296 EXIT
297 ENDIF
298 ENDDO
299
300 IF(flagp1 == 0)THEN
301 CALL ancmsg(msgid=1590,
302 . msgtype=msgerror,
303 . anmode=aninfo_blind_1,
304 . i1=nointf,
305 . c1=titr,
306 . i2=ipart1)
307 ENDIF
308 ENDIF
309C
310 n2 = -huge(n2)
311 IF(ipart2/=0)THEN
312 DO n=1,npart
313 IF(ipart2 == ipart(4,n))THEN
314 flagp2 = 1
315 n2 = n
316 EXIT
317 ENDIF
318 ENDDO
319
320 IF(flagp2 == 0)THEN
321 CALL ancmsg(msgid=1590,
322 . msgtype=msgerror,
323 . anmode=aninfo_blind_1,
324 . i1=nointf,
325 . c1=titr,
326 . i2=ipart2)
327 ENDIF
328 ENDIF
329C
330C--- CHECK PARTS Group
331C
332 IF(grpart1/=0)THEN
333 flaggrp1 = 0
334 kk=ngrnod+
335 + ngrbric+ngrquad+ngrshel+ngrsh3n+ngrtrus+ngrbeam+ngrspri
336 DO n=1,ngrpart
337 IF (igrpart(n)%ID == grpart1) THEN
338 idtgrs1=n
339 flaggrp1 = 1
340 EXIT
341 END IF
342 END DO
343 IF(flaggrp1 == 0) THEN
344 CALL ancmsg(msgid=1590,
345 . msgtype=msgerror,
346 . anmode=aninfo_blind_1,
347 . i1=nointf,
348 . c1=titr,
349 . i2=grpart1)
350 ENDIF
351 ENDIF
352C
353 IF(grpart2/=0)THEN
354 flaggrp2 = 0
355 kk=ngrnod+
356 + ngrbric+ngrquad+ngrshel+ngrsh3n+ngrtrus+ngrbeam+ngrspri
357 DO n=1,ngrpart
358 IF (igrpart(n)%ID == grpart2) THEN
359 idtgrs2=n
360 flaggrp2 = 1
361 EXIT
362 END IF
363 END DO
364 IF(flaggrp2 == 0) THEN
365 CALL ancmsg(msgid=1590,
366 . msgtype=msgerror,
367 . anmode=aninfo_blind_1,
368 . i1=nointf,
369 . c1=titr,
370 . i2=grpart2)
371 ENDIF
372 ENDIF
373
374C
375C----CHECK coefficient values
376C
377 IF(iflag == 1 ) THEN
378 IF((fric/=zero.OR.mfrot/=0).AND.viscf==zero)viscf=one
379
380 IF (fricform==2)viscf=zero
381
382 IF(idir > 0) THEN
383
384 IF((fric2/=zero.OR.mfrot/=0).AND.viscf2==zero)viscf2=one
385
386 IF (fricform==2)viscf2=zero
387
388 IF((fric2/=zero.OR.mfrot/=0).AND.viscf2==zero)viscf2=one
389
390 IF (fricform==2)viscf2=zero
391
392 ENDIF
393 ENDIF
394
395C
396C COUNTING AND STORAGE IN TEMPORARY INTBUF_FRIC_TAB
397C
398 IF(flagp1 /= 0.AND.flagp2 /= 0)THEN
399C
400 IF(iflag ==0 ) THEN
401 IF(tagprt_fric(n1) ==0 ) THEN
402 ngrpf = ngrpf + 1
403 tagprt_fric(n1)=ngrpf ! tag parts
404 lengrpf(ngrpf) = 1
405 ELSE
406! If part is already read : look to group of parts belonging and it and split it to ensure group of parts are not lapped
407 grpn = tagprt_fric(n1)
408 IF(lengrpf(grpn)/=1) THEN
409 ngrpf = ngrpf + 1
410 tagprt_fric(n1)=ngrpf ! tag parts
411 lengrpf(ngrpf) = 1
412 lengrpf(grpn) =lengrpf(grpn) - 1
413 ENDIF
414 ENDIF
415 IF(tagprt_fric(n2) ==0 ) THEN
416 ngrpf = ngrpf + 1
417 tagprt_fric(n2)=ngrpf ! tag parts
418 lengrpf(ngrpf) = 1
419 ELSE
420! If part is already read : look to group of parts belonging and it and split it to ensure group of parts are not lapped
421 grpn = tagprt_fric(n2)
422 IF(lengrpf(grpn)/=1) THEN
423 ngrpf = ngrpf + 1
424 tagprt_fric(n2)=ngrpf ! tag parts
425 lengrpf(ngrpf) = 1
426 lengrpf(grpn) =lengrpf(grpn) - 1
427 ENDIF
428 ENDIF
429 ENDIF
430C
431 IF(iflag == 1 ) THEN
432C
433 grpn1 = tagprt_fric(n1)
434 grpn2 = tagprt_fric(n2)
435
436 IF(grpn1 > grpn2 ) THEN
437 n = grpn1
438 grpn1 = grpn2
439 grpn2 = n
440 ENDIF
441 nset = nset + 1
442 ncouple = ncouple + 1
443 tabcoupleparts_fric_tmp(nif,ncouple) = grpn1
444 ncouple = ncouple + 1
445 tabcoupleparts_fric_tmp(nif,ncouple) = grpn2
446
447 ntab = lenf*8*(nset-1)+8
448 tabcoef_fric_tmp(nif,ntab+1) = fric
449 tabcoef_fric_tmp(nif,ntab+2) = viscf
450 IF(mfrot > 0) THEN
451 tabcoef_fric_tmp(nif,ntab+3) = c1
452 tabcoef_fric_tmp(nif,ntab+4) = c2
453 tabcoef_fric_tmp(nif,ntab+5) = c3
454 tabcoef_fric_tmp(nif,ntab+6) = c4
455 tabcoef_fric_tmp(nif,ntab+7) = c5
456 tabcoef_fric_tmp(nif,ntab+8) = c6
457 ENDIF
458 ifricorth_tmp(nif,nset) = idir
459 IF(idir > 0) THEN
460 ntab = 16*nset
461 tabcoef_fric_tmp(nif,ntab+1) = fric2
462 tabcoef_fric_tmp(nif,ntab+2) = viscf2
463 IF(mfrot > 0) THEN
464 tabcoef_fric_tmp(nif,ntab+3) = c11
465 tabcoef_fric_tmp(nif,ntab+4) = c22
466 tabcoef_fric_tmp(nif,ntab+5) = c33
467 tabcoef_fric_tmp(nif,ntab+6) = c44
468 tabcoef_fric_tmp(nif,ntab+7) = c55
469 tabcoef_fric_tmp(nif,ntab+8) = c66
470 ENDIF
471 ENDIF
472
473C--Output--
474C
475 WRITE (iout,2001) ipart(4,n1),ipart(4,n2)
476 IF(idir==0) THEN
477 WRITE(iout,1510)
478 IF(mfrot==0)THEN
479 WRITE(iout,3503) fric
480 IF(fricform /= 2) WRITE(iout,3504) viscf
481 ELSEIF(mfrot==1)THEN
482 WRITE(iout,1504) fric,c1,c2,c3,c4,c5,c6
483 ELSEIF(mfrot==2)THEN
484 WRITE(iout,1505)fric,c1,c2,c3,c4,c5,c6
485 ELSEIF(mfrot==3)THEN
486 WRITE(iout,1506)c1,c2,c3,c4,c5,c6
487 ELSEIF(mfrot==4)THEN
488 WRITE(iout,1514) fric,c1,c2
489 ENDIF
490 ELSE
491 WRITE(iout,1511)
492 WRITE(iout,1512)
493 IF(mfrot==0)THEN
494 WRITE(iout,3503) fric
495 IF(fricform /= 2) WRITE(iout,3504) viscf
496 ELSEIF(mfrot==1)THEN
497 WRITE(iout,1504) fric,c1,c2,c3,c4,c5,c6
498 ELSEIF(mfrot==2)THEN
499 WRITE(iout,1505)fric,c1,c2,c3,c4,c5,c6
500 ELSEIF(mfrot==3)THEN
501 WRITE(iout,1506)c1,c2,c3,c4,c5,c6
502 ELSEIF(mfrot==4)THEN
503 WRITE(iout,1514) fric,c1,c2
504 ENDIF
505 WRITE(iout,1513)
506 IF(mfrot==0)THEN
507 WRITE(iout,3503) fric2
508 IF(fricform /= 2) WRITE(iout,3504) viscf2
509 ELSEIF(mfrot==1)THEN
510 WRITE(iout,1504) fric2,c11,c22,c33,c44,c55,c66
511 ELSEIF(mfrot==2)THEN
512 WRITE(iout,1505)fric2,c11,c22,c33,c44,c55,c66
513 ELSEIF(mfrot==3)THEN
514 WRITE(iout,1506)c11,c22,c33,c44,c55,c66
515 ELSEIF(mfrot==4)THEN
516 WRITE(iout,1514) fric2,c11,c22
517 ENDIF
518 ENDIF
519C
520 ENDIF
521C
522 ENDIF
523C
524 IF(flagp1 /= 0.AND.flaggrp2 /= 0)THEN
525C
526 IF(iflag ==0 ) THEN
527 IF(tagprt_fric(n1) ==0 ) THEN
528 ngrpf = ngrpf + 1
529 tagprt_fric(n1)=ngrpf ! tag parts
530 lengrpf(ngrpf) = 1
531 ELSE
532 grpn = tagprt_fric(n1)
533 IF(lengrpf(grpn)/=1) THEN
534 ngrpf = ngrpf + 1
535 lengrpf(ngrpf) = 1
536 tagprt_fric(n1)=ngrpf ! tag parts
537 lengrpf(grpn) =lengrpf(grpn) - 1
538 ENDIF
539 ENDIF
540
541 np0 = 0
542 DO i=1,igrpart(idtgrs2)%NENTITY
543 ip=igrpart(idtgrs2)%ENTITY(i)
544 IF(tagprt_fric(ip) ==0 ) THEN
545 np0 = np0 +1
546 ENDIF
547 ENDDO
548 IF(np0 == igrpart(idtgrs2)%NENTITY) THEN
549 ngrpf = ngrpf + 1
550 lengrpf(ngrpf) = np0
551 DO i=1,igrpart(idtgrs2)%NENTITY
552 ip=igrpart(idtgrs2)%ENTITY(i)
553 tagprt_fric(ip)=ngrpf ! tag parts
554 ENDDO
555
556 j2 = 1
557 tagg2(1) = ngrpf
558 ELSE
559 IF(np0 >0 ) THEN
560 ngrpf = ngrpf + 1
561 lengrpf(ngrpf) = np0
562 DO i=1,igrpart(idtgrs2)%NENTITY
563 ip=igrpart(idtgrs2)%ENTITY(i)
564 IF(tagprt_fric(ip) ==0 ) tagprt_fric(ip) = ngrpf
565 ENDDO
566 ENDIF
567 index(1:2*leng) = 0
568 trigrpt(1:leng) = 0
569 DO i=1,igrpart(idtgrs2)%NENTITY
570 ip=igrpart(idtgrs2)%ENTITY(i)
571 IF(tagprt_fric(ip)==0) tagprt_fric(ip)=ngrpf ! tag parts
572 trigrpt(i) = tagprt_fric(ip)
573 index(i) = i
574 ENDDO
575 CALL my_orders( 0, work, trigrpt, index, igrpart(idtgrs2)%NENTITY , 1)
576
577 ngr0 = trigrpt(index(1))
578 j= 1
579 newgrp(1:leng+1) = 0
580 tagg2(1:leng) = 0
581
582 DO i=2,igrpart(idtgrs2)%NENTITY
583 ngr = trigrpt(index(i))
584 IF(ngr/=ngr0) THEN
585 IF(lengrpf(ngr0) /= i-newgrp(j)-1) THEN
586 tagg2(j) =1
587 ENDIF
588 j = j +1
589 ngr0 = ngr
590 newgrp( j) = i-1
591 ENDIF
592 ENDDO
593 IF(lengrpf(ngr0) /= igrpart(idtgrs2)%NENTITY-newgrp(j)) THEN
594 tagg2(j) =1
595 ENDIF
596 newgrp( j+1) = i-1
597 DO k=1,j
598 IF(tagg2(k)==1) THEN
599 ngrpf = ngrpf + 1
600 lengrpf(ngrpf) = newgrp( k+1) - newgrp( k)
601 ip=igrpart(idtgrs2)%ENTITY(index(newgrp( k)+1))
602 ngr0 = tagprt_fric(ip)
603 lengrpf(ngr0) =lengrpf(ngr0) -lengrpf(ngrpf)
604 DO i =newgrp( k)+1,newgrp( k+1)
605 ip=igrpart(idtgrs2)%ENTITY(index(i))
606 tagprt_fric(ip) =ngrpf
607 ENDDO
608 ENDIF
609 ENDDO
610
611 ENDIF
612 ENDIF
613
614
615 IF(iflag == 1 ) THEN
616C
617 grpn1 = tagprt_fric(n1)
618C
619! If part or group of parts is already read : look to group of parts belonging and it and split it to ensure group of parts are not lapped
620 index(1:2*leng) = 0
621 trigrpt(1:leng) = 0
622 tagg2(1:leng) = 0
623 DO i=1,igrpart(idtgrs2)%NENTITY
624 ip=igrpart(idtgrs2)%ENTITY(i)
625 trigrpt(i) = tagprt_fric(ip)
626 index(i) = i
627 ENDDO
628 CALL my_orders( 0, work, trigrpt, index, igrpart(idtgrs2)%NENTITY , 1)
629
630 ngr0 = trigrpt(index(1))
631 j= 1
632 tagg2(1) = ngr0
633 DO i=2,igrpart(idtgrs2)%NENTITY
634 ngr = trigrpt(index(i))
635 IF(ngr/=ngr0) THEN
636 j = j +1
637 ngr0 = ngr
638 tagg2(j) = ngr0
639 ENDIF
640 ENDDO
641 j2 = j
642C
643 DO k=1,j2
644 grpn2 = tagg2(k)
645
646 IF(n1 > grpn2 ) THEN
647 n = grpn1
648 ipp = grpn2
649 ip = grpn1
650 ELSE
651 ipp = grpn1
652 ip = grpn2
653 ENDIF
654
655 nset = nset + 1
656 ncouple = ncouple + 1
657 tabcoupleparts_fric_tmp(nif,ncouple) = ipp
658 ncouple = ncouple + 1
659 tabcoupleparts_fric_tmp(nif,ncouple) = ip
660C
661 ntab = lenf*8*(nset-1)+8
662 tabcoef_fric_tmp(nif,ntab+1) = fric
663 tabcoef_fric_tmp(nif,ntab+2) = viscf
664 IF(mfrot > 0) THEN
665 tabcoef_fric_tmp(nif,ntab+3) = c1
666 tabcoef_fric_tmp(nif,ntab+4) = c2
667 tabcoef_fric_tmp(nif,ntab+5) = c3
668 tabcoef_fric_tmp(nif,ntab+6) = c4
669 tabcoef_fric_tmp(nif,ntab+7) = c5
670 tabcoef_fric_tmp(nif,ntab+8) = c6
671 ENDIF
672 ifricorth_tmp(nif,nset) = idir
673
674c
675 IF(idir==1) THEN
676
677 ntab = 16*nset
678 tabcoef_fric_tmp(nif,ntab+1) = fric2
679 tabcoef_fric_tmp(nif,ntab+2) = viscf2
680 IF(mfrot > 0) THEN
681 tabcoef_fric_tmp(nif,ntab+3) = c11
682 tabcoef_fric_tmp(nif,ntab+4) = c22
683 tabcoef_fric_tmp(nif,ntab+5) = c33
684 tabcoef_fric_tmp(nif,ntab+6) = c44
685 tabcoef_fric_tmp(nif,ntab+7) = c55
686 tabcoef_fric_tmp(nif,ntab+8) = c66
687 ENDIF
688
689 ENDIF
690 ENDDO
691 ENDIF
692
693c
694
695C--Output--
696 IF(iflag == 1 ) THEN
697 WRITE (iout,2003)
698 . ipart(4,n1),grpart2
699 IF(idir==0) THEN
700 WRITE(iout,1510)
701 IF(mfrot==0)THEN
702 WRITE(iout,3503) fric
703 IF(fricform /= 2) WRITE(iout,3504) viscf
704 ELSEIF(mfrot==1)THEN
705 WRITE(iout,1504) fric,c1,c2,c3,c4,c5,c6
706 ELSEIF(mfrot==2)THEN
707 WRITE(iout,1505)fric,c1,c2,c3,c4,c5,c6
708 ELSEIF(mfrot==3)THEN
709 WRITE(iout,1506)c1,c2,c3,c4,c5,c6
710 ELSEIF(mfrot==4)THEN
711 WRITE(iout,1514) fric,c1,c2
712 ENDIF
713 ELSE
714 WRITE(iout,1511)
715 WRITE(iout,1512)
716 IF(mfrot==0)THEN
717 WRITE(iout,3503) fric
718 IF(fricform /= 2) WRITE(iout,3504) viscf
719 ELSEIF(mfrot==1)THEN
720 WRITE(iout,1504) fric,c1,c2,c3,c4,c5,c6
721 ELSEIF(mfrot==2)THEN
722 WRITE(iout,1505)fric,c1,c2,c3,c4,c5,c6
723 ELSEIF(mfrot==3)THEN
724 WRITE(iout,1506)c1,c2,c3,c4,c5,c6
725 ELSEIF(mfrot==4)THEN
726 WRITE(iout,1514) fric,c1,c2
727 ENDIF
728 WRITE(iout,1513)
729 IF(mfrot==0)THEN
730 WRITE(iout,3503) fric2
731 IF(fricform /= 2) WRITE(iout,3504) viscf2
732 ELSEIF(mfrot==1)THEN
733 WRITE(iout,1504) fric2,c11,c22,c33,c44,c55,c66
734 ELSEIF(mfrot==2)THEN
735 WRITE(iout,1505)fric2,c11,c22,c33,c44,c55,c66
736 ELSEIF(mfrot==3)THEN
737 WRITE(iout,1506)c11,c22,c33,c44,c55,c66
738 ELSEIF(mfrot==4)THEN
739 WRITE(iout,1514) fric2,c11,c22
740 ENDIF
741 ENDIF
742 ENDIF
743
744 ENDIF
745C
746 IF(flagp2 /= 0.AND.flaggrp1 /= 0)THEN
747
748 IF(iflag==0) THEN
749 IF(tagprt_fric(n2) ==0 ) THEN
750 ngrpf = ngrpf + 1
751 tagprt_fric(n2)=ngrpf ! tag parts
752 lengrpf(ngrpf) = 1
753 ELSE
754 grpn = tagprt_fric(n2)
755 IF(lengrpf(grpn)/=1) THEN
756 ngrpf = ngrpf + 1
757 lengrpf(ngrpf) = 1
758 tagprt_fric(n2)=ngrpf ! tag parts
759 lengrpf(grpn) =lengrpf(grpn) - 1
760 ENDIF
761 ENDIF
762
763 np0 = 0
764 DO i=1,igrpart(idtgrs1)%NENTITY
765 ip=igrpart(idtgrs1)%ENTITY(i)
766 IF(tagprt_fric(ip) ==0 ) THEN
767 np0 = np0 +1
768 ENDIF
769 ENDDO
770
771
772
773 IF(np0 == igrpart(idtgrs1)%NENTITY) THEN
774 ngrpf = ngrpf + 1
775 lengrpf(ngrpf) = np0
776 DO i=1,igrpart(idtgrs1)%NENTITY
777 ip=igrpart(idtgrs1)%ENTITY(i)
778 tagprt_fric(ip)=ngrpf ! tag parts
779 ENDDO
780
781 ELSE
782 IF(np0 >0 ) THEN
783 ngrpf = ngrpf + 1
784 lengrpf(ngrpf) = np0
785 DO i=1,igrpart(idtgrs1)%NENTITY
786 ip=igrpart(idtgrs1)%ENTITY(i)
787 IF(tagprt_fric(ip) ==0 ) tagprt_fric(ip) = ngrpf
788 ENDDO
789 ENDIF
790 index(1:2*leng) = 0
791 trigrpt(1:leng) = 0
792 DO i=1,igrpart(idtgrs1)%NENTITY
793 ip=igrpart(idtgrs1)%ENTITY(i)
794 IF(tagprt_fric(ip)==0) tagprt_fric(ip)=ngrpf ! tag parts
795 trigrpt(i) = tagprt_fric(ip)
796 index(i) = i
797 ENDDO
798 CALL my_orders( 0, work, trigrpt, index, igrpart(idtgrs1)%NENTITY , 1)
799
800 ngr0 = trigrpt(index(1))
801 j= 1
802 newgrp(1:leng+1) = 0
803 tagg1(1:leng) = 0
804 DO i=2,igrpart(idtgrs1)%NENTITY
805 ngr = trigrpt(index(i))
806 IF(ngr/=ngr0) THEN
807 IF(lengrpf(ngr0) /= i-newgrp(j)-1) THEN
808 tagg1(j) =1
809 ENDIF
810 j = j +1
811 ngr0 = ngr
812 newgrp( j) = i-1
813 ENDIF
814 ENDDO
815
816 IF(lengrpf(ngr0) /= igrpart(idtgrs1)%NENTITY-newgrp(j)) THEN
817 tagg1(j) =1
818 ENDIF
819 newgrp( j+1) = i-1
820
821
822 DO k=1,j
823 IF(tagg1(k)==1) THEN
824 ngrpf = ngrpf + 1
825 lengrpf(ngrpf) = newgrp( k+1) - newgrp( k)
826 ip=igrpart(idtgrs1)%ENTITY(index(newgrp( k)+1))
827 ngr0 = tagprt_fric(ip)
828 lengrpf(ngr0) =lengrpf(ngr0) -lengrpf(ngrpf)
829 DO i =newgrp( k)+1,newgrp( k+1)
830 ip=igrpart(idtgrs1)%ENTITY(index(i))
831 tagprt_fric(ip) =ngrpf
832 ENDDO
833 ENDIF
834 ENDDO
835 ENDIF
836 ENDIF
837C
838 IF(iflag == 1 ) THEN
839C
840 grpn2 = tagprt_fric(n2)
841C
842 index(1:2*leng) = 0
843 trigrpt(1:leng) = 0
844 tagg1(1:leng) = 0
845 DO i=1,igrpart(idtgrs1)%NENTITY
846 ip=igrpart(idtgrs1)%ENTITY(i)
847 trigrpt(i) = tagprt_fric(ip)
848 index(i) = i
849 ENDDO
850 CALL my_orders( 0, work, trigrpt, index, igrpart(idtgrs1)%NENTITY , 1)
851
852 ngr0 = trigrpt(index(1))
853 j= 1
854 tagg1(1) = ngr0
855 DO i=2,igrpart(idtgrs1)%NENTITY
856 ngr = trigrpt(index(i))
857 IF(ngr/=ngr0) THEN
858 j = j +1
859 ngr0 = ngr
860 tagg1(j) = ngr0
861 ENDIF
862 ENDDO
863 j1 = j
864C
865 DO k=1,j1
866 grpn1 = tagg1(k)
867 IF(grpn1 > n2 ) THEN
868 n = n2
869 ipp = grpn1
870 ip = n2
871 ELSE
872 ipp = grpn1
873 ENDIF
874
875 nset = nset + 1
876 ncouple = ncouple + 1
877 tabcoupleparts_fric_tmp(nif,ncouple) = ipp
878 ncouple = ncouple + 1
879 tabcoupleparts_fric_tmp(nif,ncouple) = ip
880C
881 ntab = lenf*8*(nset-1)+8
882 tabcoef_fric_tmp(nif,ntab+1) = fric
883 tabcoef_fric_tmp(nif,ntab+2) = viscf
884 IF(mfrot > 0 ) THEN
885 tabcoef_fric_tmp(nif,ntab+3) = c1
886 tabcoef_fric_tmp(nif,ntab+4) = c2
887 tabcoef_fric_tmp(nif,ntab+5) = c3
888 tabcoef_fric_tmp(nif,ntab+6) = c4
889 tabcoef_fric_tmp(nif,ntab+7) = c5
890 tabcoef_fric_tmp(nif,ntab+8) = c6
891 ENDIF
892 ifricorth_tmp(nif,nset) = idir
893c
894 IF(idir==1) THEN
895
896 ntab = 2*8*nset
897 tabcoef_fric_tmp(nif,ntab+1) = fric2
898 tabcoef_fric_tmp(nif,ntab+2) = viscf2
899 tabcoef_fric_tmp(nif,ntab+3) = c11
900 tabcoef_fric_tmp(nif,ntab+4) = c22
901 tabcoef_fric_tmp(nif,ntab+5) = c33
902 tabcoef_fric_tmp(nif,ntab+6) = c44
903 tabcoef_fric_tmp(nif,ntab+7) = c55
904 tabcoef_fric_tmp(nif,ntab+8) = c66
905
906 ENDIF
907c
908 ENDDO
909
910 ENDIF
911
912C--Output--
913 IF(iflag == 1 ) THEN
914 WRITE (iout,2002)
915 . grpart1,ipart(4,n2)
916 IF(idir==0) THEN
917 WRITE(iout,1510)
918 IF(mfrot==0)THEN
919 WRITE(iout,3503) fric
920 IF(fricform /= 2) WRITE(iout,3504) viscf
921 ELSEIF(mfrot==1)THEN
922 WRITE(iout,1504) fric,c1,c2,c3,c4,c5,c6
923 ELSEIF(mfrot==2)THEN
924 WRITE(iout,1505)fric,c1,c2,c3,c4,c5,c6
925 ELSEIF(mfrot==3)THEN
926 WRITE(iout,1506)c1,c2,c3,c4,c5,c6
927 ELSEIF(mfrot==4)THEN
928 WRITE(iout,1514) fric,c1,c2
929 ENDIF
930 ELSE
931 WRITE(iout,1511)
932 WRITE(iout,1512)
933 IF(mfrot==0)THEN
934 WRITE(iout,3503) fric
935 IF(fricform /= 2) WRITE(iout,3504) viscf
936 ELSEIF(mfrot==1)THEN
937 WRITE(iout,1504) fric,c1,c2,c3,c4,c5,c6
938 ELSEIF(mfrot==2)THEN
939 WRITE(iout,1505)fric,c1,c2,c3,c4,c5,c6
940 ELSEIF(mfrot==3)THEN
941 WRITE(iout,1506)c1,c2,c3,c4,c5,c6
942 ELSEIF(mfrot==4)THEN
943 WRITE(iout,1514) fric,c1,c2
944 ENDIF
945 WRITE(iout,1513)
946 IF(mfrot==0)THEN
947 WRITE(iout,3503) fric2
948 IF(fricform /= 2) WRITE(iout,3504) viscf2
949 ELSEIF(mfrot==1)THEN
950 WRITE(iout,1504) fric2,c11,c22,c33,c44,c55,c66
951 ELSEIF(mfrot==2)THEN
952 WRITE(iout,1505)fric2,c11,c22,c33,c44,c55,c66
953 ELSEIF(mfrot==3)THEN
954 WRITE(iout,1506)c11,c22,c33,c44,c55,c66
955 ELSEIF(mfrot==4)THEN
956 WRITE(iout,1514) fric2,c11,c22
957 ENDIF
958 ENDIF
959 ENDIF
960
961 ENDIF
962C
963 IF(flaggrp1 /= 0.AND.flaggrp2 /=0)THEN
964
965 IF(iflag==0) THEN
966 np0 = 0
967 DO i=1,igrpart(idtgrs1)%NENTITY
968 ip=igrpart(idtgrs1)%ENTITY(i)
969 IF(tagprt_fric(ip) ==0 ) THEN
970 np0 = np0 +1
971 ENDIF
972 ENDDO
973
974
975
976 IF(np0 == igrpart(idtgrs1)%NENTITY) THEN
977 ngrpf = ngrpf + 1
978 lengrpf(ngrpf) = np0
979 DO i=1,igrpart(idtgrs1)%NENTITY
980 ip=igrpart(idtgrs1)%ENTITY(i)
981 tagprt_fric(ip)=ngrpf ! tag parts
982 ENDDO
983
984 ELSE
985 IF(np0 >0 ) THEN
986 ngrpf = ngrpf + 1
987 lengrpf(ngrpf) = np0
988 DO i=1,igrpart(idtgrs1)%NENTITY
989 ip=igrpart(idtgrs1)%ENTITY(i)
990 IF(tagprt_fric(ip) ==0 ) tagprt_fric(ip) = ngrpf
991 ENDDO
992 ENDIF
993 index(1:2*leng) = 0
994 trigrpt(1:leng) = 0
995 DO i=1,igrpart(idtgrs1)%NENTITY
996 ip=igrpart(idtgrs1)%ENTITY(i)
997 IF(tagprt_fric(ip)==0) tagprt_fric(ip)=ngrpf ! tag parts
998 trigrpt(i) = tagprt_fric(ip)
999 index(i) = i
1000 ENDDO
1001 CALL my_orders( 0, work, trigrpt, index, igrpart(idtgrs1)%NENTITY , 1)
1002
1003 ngr0 = trigrpt(index(1))
1004 j= 1
1005 newgrp(1:leng+1) = 0
1006 tagg1(1:leng) = 0
1007 DO i=2,igrpart(idtgrs1)%NENTITY
1008 ngr = trigrpt(index(i))
1009 IF(ngr/=ngr0) THEN
1010 IF(lengrpf(ngr0) /= i-newgrp(j)-1) THEN
1011 tagg1(j) =1
1012 ENDIF
1013 j = j +1
1014 ngr0 = ngr
1015 newgrp( j) = i-1
1016 ENDIF
1017 ENDDO
1018
1019 IF(lengrpf(ngr0) /= igrpart(idtgrs1)%NENTITY-newgrp(j)) THEN
1020 tagg1(j) =1
1021 ENDIF
1022 newgrp( j+1) = i-1
1023
1024
1025 DO k=1,j
1026 IF(tagg1(k)==1) THEN
1027 ngrpf = ngrpf + 1
1028 lengrpf(ngrpf) = newgrp( k+1) - newgrp( k)
1029 ip=igrpart(idtgrs1)%ENTITY(index(newgrp( k)+1))
1030 ngr0 = tagprt_fric(ip)
1031 lengrpf(ngr0) =lengrpf(ngr0) -lengrpf(ngrpf)
1032 DO i =newgrp( k)+1,newgrp( k+1)
1033 ip=igrpart(idtgrs1)%ENTITY(index(i))
1034 tagprt_fric(ip) =ngrpf
1035 ENDDO
1036 ENDIF
1037 ENDDO
1038 ENDIF
1039
1040 np0 = 0
1041 DO i=1,igrpart(idtgrs2)%NENTITY
1042 ip=igrpart(idtgrs2)%ENTITY(i)
1043 IF(tagprt_fric(ip) ==0 ) THEN
1044 np0 = np0 +1
1045 ENDIF
1046 ENDDO
1047 IF(np0 == igrpart(idtgrs2)%NENTITY) THEN
1048 ngrpf = ngrpf + 1
1049 lengrpf(ngrpf) = np0
1050 DO i=1,igrpart(idtgrs2)%NENTITY
1051 ip=igrpart(idtgrs2)%ENTITY(i)
1052 tagprt_fric(ip)=ngrpf ! tag parts
1053 ENDDO
1054
1055
1056 j2 = 1
1057 tagg2(1) = ngrpf
1058 ELSE
1059 IF(np0 >0 ) THEN
1060 ngrpf = ngrpf + 1
1061 lengrpf(ngrpf) = np0
1062 DO i=1,igrpart(idtgrs2)%NENTITY
1063 ip=igrpart(idtgrs2)%ENTITY(i)
1064 IF(tagprt_fric(ip) ==0 ) tagprt_fric(ip) = ngrpf
1065 ENDDO
1066 ENDIF
1067 index(1:2*leng) = 0
1068 trigrpt(1:leng) = 0
1069 DO i=1,igrpart(idtgrs2)%NENTITY
1070 ip=igrpart(idtgrs2)%ENTITY(i)
1071 IF(tagprt_fric(ip)==0) tagprt_fric(ip)=ngrpf ! tag parts
1072 trigrpt(i) = tagprt_fric(ip)
1073 index(i) = i
1074 ENDDO
1075 CALL my_orders( 0, work, trigrpt, index, igrpart(idtgrs2)%NENTITY , 1)
1076
1077 ngr0 = trigrpt(index(1))
1078 j= 1
1079 newgrp(1:leng+1) = 0
1080 tagg2(1:leng) = 0
1081
1082 DO i=2,igrpart(idtgrs2)%NENTITY
1083 ngr = trigrpt(index(i))
1084 IF(ngr/=ngr0) THEN
1085 IF(lengrpf(ngr0) /= i-newgrp(j)-1) THEN
1086 tagg2(j) =1
1087 ENDIF
1088 j = j +1
1089 ngr0 = ngr
1090 newgrp( j) = i-1
1091 ENDIF
1092 ENDDO
1093 IF(lengrpf(ngr0) /= igrpart(idtgrs2)%NENTITY-newgrp(j)) THEN
1094 tagg2(j) =1
1095 ENDIF
1096 newgrp( j+1) = i-1
1097 DO k=1,j
1098 IF(tagg2(k)==1) THEN
1099 ngrpf = ngrpf + 1
1100 lengrpf(ngrpf) = newgrp( k+1) - newgrp( k)
1101 ip=igrpart(idtgrs2)%ENTITY(index(newgrp( k)+1))
1102 ngr0 = tagprt_fric(ip)
1103 lengrpf(ngr0) =lengrpf(ngr0) -lengrpf(ngrpf)
1104 DO i =newgrp( k)+1,newgrp( k+1)
1105 ip=igrpart(idtgrs2)%ENTITY(index(i))
1106 tagprt_fric(ip) =ngrpf
1107 ENDDO
1108 ENDIF
1109 ENDDO
1110
1111 ENDIF
1112 ENDIF
1113
1114 IF(iflag == 1 ) THEN
1115
1116C
1117 index(1:2*leng) = 0
1118 trigrpt(1:leng) = 0
1119 tagg1(1:leng) = 0
1120 DO i=1,igrpart(idtgrs1)%NENTITY
1121 ip=igrpart(idtgrs1)%ENTITY(i)
1122 trigrpt(i) = tagprt_fric(ip)
1123 index(i) = i
1124 ENDDO
1125 CALL my_orders( 0, work, trigrpt, index, igrpart(idtgrs1)%NENTITY , 1)
1126
1127 ngr0 = trigrpt(index(1))
1128 j= 1
1129 tagg1(1) = ngr0
1130 DO i=2,igrpart(idtgrs1)%NENTITY
1131 ngr = trigrpt(index(i))
1132 IF(ngr/=ngr0) THEN
1133 j = j +1
1134 ngr0 = ngr
1135 tagg1(j) = ngr0
1136 ENDIF
1137 ENDDO
1138 j1 = j
1139C
1140 index(1:2*leng) = 0
1141 trigrpt(1:leng) = 0
1142 tagg2(1:leng) = 0
1143 DO i=1,igrpart(idtgrs2)%NENTITY
1144 ip=igrpart(idtgrs2)%ENTITY(i)
1145 trigrpt(i) = tagprt_fric(ip)
1146 index(i) = i
1147 ENDDO
1148 CALL my_orders( 0, work, trigrpt, index, igrpart(idtgrs2)%NENTITY , 1)
1149
1150 ngr0 = trigrpt(index(1))
1151 j= 1
1152 tagg2(1) = ngr0
1153 DO i=2,igrpart(idtgrs2)%NENTITY
1154 ngr = trigrpt(index(i))
1155 IF(ngr/=ngr0) THEN
1156 j = j +1
1157 ngr0 = ngr
1158 tagg2(j) = ngr0
1159 ENDIF
1160 ENDDO
1161 j2 = j
1162C
1163 DO k=1,j1
1164 grpn1 = tagg1(k)
1165 DO j=1,j2
1166 grpn2 = tagg2(j)
1167 IF(grpn1 > grpn2 ) THEN
1168 n = grpn2
1169 ipp2 = grpn1
1170 ipp1 = n
1171 ELSE
1172 ipp1 = grpn1
1173 ipp2 = grpn2
1174 ENDIF
1175 nset = nset + 1
1176
1177 ncouple = ncouple + 1
1178 tabcoupleparts_fric_tmp(nif,ncouple) = ipp1
1179 ncouple = ncouple + 1
1180 tabcoupleparts_fric_tmp(nif,ncouple) = ipp2
1181C
1182 ntab = lenf*8*(nset-1)+8
1183 tabcoef_fric_tmp(nif,ntab+1) = fric
1184 tabcoef_fric_tmp(nif,ntab+2) = viscf
1185 IF(mfrot >0) THEN
1186 tabcoef_fric_tmp(nif,ntab+3) = c1
1187 tabcoef_fric_tmp(nif,ntab+4) = c2
1188 tabcoef_fric_tmp(nif,ntab+5) = c3
1189 tabcoef_fric_tmp(nif,ntab+6) = c4
1190 tabcoef_fric_tmp(nif,ntab+7) = c5
1191 tabcoef_fric_tmp(nif,ntab+8) = c6
1192 ENDIF
1193 ifricorth_tmp(nif,nset) = idir
1194c
1195 IF(idir==1) THEN
1196
1197 ntab = 16*nset
1198 tabcoef_fric_tmp(nif,ntab+1) = fric2
1199 tabcoef_fric_tmp(nif,ntab+2) = viscf2
1200 IF(mfrot >0) THEN
1201 tabcoef_fric_tmp(nif,ntab+3) = c11
1202 tabcoef_fric_tmp(nif,ntab+4) = c22
1203 tabcoef_fric_tmp(nif,ntab+5) = c33
1204 tabcoef_fric_tmp(nif,ntab+6) = c44
1205 tabcoef_fric_tmp(nif,ntab+7) = c55
1206 tabcoef_fric_tmp(nif,ntab+8) = c66
1207 ENDIF
1208 ENDIF
1209c
1210 ENDDO
1211c
1212 END DO
1213
1214 ENDIF
1215
1216C--Output--
1217 IF(iflag == 1 ) THEN
1218 WRITE (iout,2004)
1219 . grpart1,grpart2
1220 IF(idir==0) THEN
1221 WRITE(iout,1510)
1222 IF(mfrot==0)THEN
1223 WRITE(iout,3503) fric
1224 IF(fricform /= 2) WRITE(iout,3504) viscf
1225 ELSEIF(mfrot==1)THEN
1226 WRITE(iout,1504) fric,c1,c2,c3,c4,c5,c6
1227 ELSEIF(mfrot==2)THEN
1228 WRITE(iout,1505)fric,c1,c2,c3,c4,c5,c6
1229 ELSEIF(mfrot==3)THEN
1230 WRITE(iout,1506)c1,c2,c3,c4,c5,c6
1231 ELSEIF(mfrot==4)THEN
1232 WRITE(iout,1514) fric,c1,c2
1233 ENDIF
1234 ELSE
1235 WRITE(iout,1511)
1236 WRITE(iout,1512)
1237 IF(mfrot==0)THEN
1238 WRITE(iout,3503) fric
1239 IF(fricform /= 2) WRITE(iout,3504) viscf
1240 ELSEIF(mfrot==1)THEN
1241 WRITE(iout,1504) fric,c1,c2,c3,c4,c5,c6
1242 ELSEIF(mfrot==2)THEN
1243 WRITE(iout,1505)fric,c1,c2,c3,c4,c5,c6
1244 ELSEIF(mfrot==3)THEN
1245 WRITE(iout,1506)c1,c2,c3,c4,c5,c6
1246 ELSEIF(mfrot==4)THEN
1247 WRITE(iout,1514) fric,c1,c2
1248 ENDIF
1249 WRITE(iout,1513)
1250 IF(mfrot==0)THEN
1251 WRITE(iout,3503) fric2
1252 IF(fricform /= 2) WRITE(iout,3504) viscf2
1253 ELSEIF(mfrot==1)THEN
1254 WRITE(iout,1504) fric2,c11,c22,c33,c44,c55,c66
1255 ELSEIF(mfrot==2)THEN
1256 WRITE(iout,1505)fric2,c11,c22,c33,c44,c55,c66
1257 ELSEIF(mfrot==3)THEN
1258 WRITE(iout,1506)c11,c22,c33,c44,c55,c66
1259 ELSEIF(mfrot==4)THEN
1260 WRITE(iout,1514) fric2,c11,c22
1261 ENDIF
1262 ENDIF
1263 ENDIF
1264
1265c ENDDO
1266c
1267 ENDIF
1268C
1269
1270 ENDDO ! N=1,NLINE
1271
1272 DEALLOCATE (trigrpt,index,newgrp,tagg1,tagg2)
1273
1274C
1275 RETURN
1276
1277
1278
1279 1500 FORMAT(/1x,' FRICTION INTERFACE MODEL NUMBER :',i10,1x,a/
1280 . 1x,' ------------------------------- '/)
1281 1501 FORMAT( /1x,' DEFAULT VALUES ' /
1282 . 1x,' -------------- ' )
1283
1284 1502 FORMAT(
1285 . ' FRICTION FILTERING FLAG. . . . . . . . . ',i10/,
1286 . ' FILTERING FACTOR . . . . . . . . . . . . ',1pg20.13/)
1287 1503 FORMAT(/
1288 . ' FRICTION MODEL 0 (Coulomb Law) ')
1289 3503 FORMAT(/
1290 . ' FRICTION COEFFICIENT . . . . . . . . . . ',1pg20.13/)
1291 3504 FORMAT(
1292 . ' FRICTION CRITICAL DAMPING FACTOR. . . . .',1pg20.13/)
1293 3505 FORMAT(//
1294 . ' FRICTION MODEL 1 (Viscous Polynomial)'/
1295 . ' MU = MUo + C1 p + C2 v + C3 pv + C4 p^2 + C5 v^2'/)
1296 1504 FORMAT(//
1297 . ' Muo. . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1298 . ' C1 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1299 . ' C2 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1300 . ' C3 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1301 . ' C4 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1302 . ' C5 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1303 . ' TANGENTIAL PRESSURE LIMIT. . .. . . . . .',1pg20.13/)
1304 3506 FORMAT(/
1305 . ' FRICTION MODEL 2 (Darmstad Law) :'/
1306 . ' MU = MUo+c1*exp(c2*v)*p^2+c3*exp(c4*v)*p+c5*exp(c6*v)')
1307 1505 FORMAT(/
1308 . ' Muo. . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1309 . ' C1 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1310 . ' C2 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1311 . ' C3 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1312 . ' C4 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1313 . ' C5 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1314 . ' C6 . . . . . . . . . . . . . . . . . . . ',1pg20.13/)
1315 3507 FORMAT(/
1316 . ' FRICTION MODEL 3 (Renard law) ')
1317 1506 FORMAT(/
1318 . ' C1 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1319 . ' C2 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1320 . ' C3 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1321 . ' C4 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1322 . ' C5 . . . . . . . . . . . . . . . . . . . ',1pg20.13/,
1323 . ' C6 . . . . . . . . . . . . . . . . . . . ',1pg20.13/)
1324 3508 FORMAT(/
1325 . ' EXPONENTIAL DECAY FRICTION LAW '/
1326 . ' MU = c1+(MUo-c1)*exp(-c2*v)')
1327 1514 FORMAT(/
1328 . ' STATIC COEFFICIENT MUo . . . . . . . . . ',1pg20.13/,
1329 . ' DYNAMIC COEFFICIENT C1 . . . . . . . . . ',1pg20.13/,
1330 . ' exponential decay coefficient c2 . . . . ',1PG20.13/)
1331c 2503 FORMAT(/
1332c . ' FRICTION COEFFICIENT . . . . . . . . . . . ',1PG20.13/
1333c . ' FRICTION CRITICAL DAMPING FACTOR. . . . . . ',1PG20.13)
1334
1335 2001 FORMAT(/
1336 . ' part 1 . . . . . . . . . . . . . . . . . ',I10/,
1337 . ' part 2 . . . . . . . . . . . . . . . . . ',I10)
1338 2002 FORMAT(/
1339 . ' gr_part 1 . . . . . . . . . . . . . . . .',I10/,
1340 . ' part 2 . . . . . . . . . . . . . . . . . ',I10)
1341 2003 FORMAT(/
1342 . ' part 1 . . . . . . . . . . . . . . . . . ',I10/,
1343 . ' gr_part 2 . . . . . . . . . . . . . . . .',I10)
1344 2004 FORMAT(/
1345 . ' gr_part 1 . . . . . . . . . . . . . . . . ',I10/,
1346 . ' gr_part 2 . . . . . . . . . . . . . . . . ',I10)
1347
1348
1349 1507 FORMAT( /1X,' friction coefficients table ' /
1350 . 1X,' --------------------------- '/)
1351
1352 1508 FORMAT( ' friction formulation: incremental(stiffness) ',
1353 . 'formulation')
1354 1509 FORMAT( ' friction formulation: total(viscous) ',
1355 . 'formulation')
1356 1510 FORMAT(/
1357 . ' isotropic friction ')
1358 1511 FORMAT(/
1359 . ' orthotropic friction ')
1360 1512 FORMAT(/
1361 . ' friction direction 1 : ')
1362 1513 FORMAT(/
1363 . ' friction direction 2 : ')
1364
1365 END SUBROUTINE HM_READ_FRICTION
1366
my_real
#define my_real
Definition cppsort.cpp:32
alpha
#define alpha
Definition eval.h:35
hm_get_float_array_index
subroutine hm_get_float_array_index(name, rval, index, is_available, lsubmodel, unitab)
Definition hm_get_float_array_index.F:105
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:418
hm_get_int_array_index
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
Definition hm_get_int_array_index.F:164
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:528
hm_read_friction
subroutine hm_read_friction(nif, nom_opt, titr, unitab, igrpart, ipart, nset, tagprt_fric, tabcoupleparts_fric_tmp, tabcoef_fric_tmp, mfrot, ifq, xfiltr, fricform, iflag, orthfric, ifricorth_tmp, ngrpf, lengrpf, leng, nointf, lsubmodel)
Definition hm_read_friction.F:46
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
groupdef_mod
Definition groupdef_mod.F:668
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
submodel_mod
Definition submodel_mod.F:717
unitab_mod
Definition unitab_mod.F:517
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:895
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:615
starter
program starter
Definition starter.F:39