trintfric.F File Reference

#include "implicit_f.inc"
#include "com04_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	triintfric (tabcoupleparts_fric_tmp, tabcoef_fric_tmp, intbuf_fric_tab, tabparts_fric_tmp, nsetfrictot, nsetinit, iorthfricmax, ifricorth_tmp, nsetmax)

Function/Subroutine Documentation

triintfric()

subroutine triintfric	(	integer, dimension(ninterfric,*)	tabcoupleparts_fric_tmp,
			tabcoef_fric_tmp,
		type(intbuf_fric_struct_), dimension(*)	intbuf_fric_tab,
		integer, dimension(ninterfric,*)	tabparts_fric_tmp,
		integer	nsetfrictot,
		integer, dimension(ninterfric)	nsetinit,
		integer	iorthfricmax,
		integer, dimension(ninterfric,*)	ifricorth_tmp,
		integer	nsetmax )

Definition at line 31 of file trintfric.F.

 
C============================================================================
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE intbuf_fric_mod                     
C-----------------------------------------------      
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NSETFRICTOT,IORTHFRICMAX,NSETMAX
      INTEGER TABCOUPLEPARTS_FRIC_TMP(NINTERFRIC,*),NSETINIT(NINTERFRIC),
     .        TABPARTS_FRIC_TMP(NINTERFRIC,*),IFRICORTH_TMP(NINTERFRIC,*)
 
      my_real
     .   tabcoef_fric_tmp(ninterfric,*)
 
      TYPE(INTBUF_FRIC_STRUCT_) INTBUF_FRIC_TAB(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NIF , NSET ,I ,J ,K ,STAT ,NSETT ,IORTH ,
     . WORK(70000)
      INTEGER, DIMENSION(:),   ALLOCATABLE :: INDEX ,ITRI2 ,INDEX2
      INTEGER, DIMENSION(:,:),   ALLOCATABLE :: ITRI
      INTEGER, DIMENSION(:),   ALLOCATABLE :: TRIFRIORTH
      my_real, DIMENSION(:,:),   ALLOCATABLE :: tricoef
C
C--------------------------------------------
 
      ALLOCATE(index(2*nsetmax), stat=stat)
      ALLOCATE(itri(2,nsetmax), stat=stat)
      IF(iorthfricmax == 0 ) THEN
        ALLOCATE(tricoef(nsetmax,8), stat=stat)
      ELSE
        ALLOCATE(tricoef(nsetmax,16), stat=stat)
      ENDIF
      ALLOCATE(itri2(2*nsetmax), stat=stat)
      ALLOCATE(index2(4*nsetmax), stat=stat)
      ALLOCATE(trifriorth(nsetmax), stat=stat)    
 
C
       DO nif=1,ninterfric
          nset  = intbuf_fric_tab(nif)%NSETPRTS
          iorth = intbuf_fric_tab(nif)%IORTHFRIC
          j = 1
C------Copy-----------------------------
          DO i=1,nset
             itri(1,i) = tabcoupleparts_fric_tmp(nif,j)
             itri(2,i) = tabcoupleparts_fric_tmp(nif,j+1)
             index(i)=i
             j = j+2
          ENDDO
          DO i=1,nset
             trifriorth(i) = ifricorth_tmp(nif,i)
          ENDDO
          IF(iorth == 0 ) THEN
             DO i=1,nset
                DO j=1,8
                   tricoef(i,j) = tabcoef_fric_tmp(nif,i*8+j)
                ENDDO
             ENDDO
          ELSEIF(iorth == 1 ) THEN
             DO i=1,nset
                DO j=1,16
                   tricoef(i,j) = tabcoef_fric_tmp(nif,8+16*(i-1)+j)
                ENDDO
             ENDDO     
         ENDIF
C----------------------
          CALL my_orders( 0, work, itri, index, nset , 2)
C
           j = 1 
          DO i=1,nset
             tabcoupleparts_fric_tmp(nif,j)= itri(1,index(i))
             tabcoupleparts_fric_tmp(nif,j+1)= itri(2,index(i))
             j = j+2
          ENDDO 
 
C------Delete duplicated parts pairs-----------------------------
          nsetinit(nif) = nset
          j = 1
          k = nset
          DO i=1,nset-1
             IF(tabcoupleparts_fric_tmp(nif,j)==tabcoupleparts_fric_tmp(nif,j+2).AND. 
     .          tabcoupleparts_fric_tmp(nif,j+1)==tabcoupleparts_fric_tmp(nif,j+3)  ) THEN
                tabcoupleparts_fric_tmp(nif,j) = 0
                tabcoupleparts_fric_tmp(nif,j+1) = 0
                k = k - 1
             ENDIF  
            j = j + 2
          ENDDO 
          intbuf_fric_tab(nif)%NSETPRTS = k
 
C---------Tabs of tagged parts--------------------------------- 
          k = 0 
          j = 1
          DO i =1,nset
             IF(tabcoupleparts_fric_tmp(nif,j) /= 0 ) THEN
                k = k +1
                tabparts_fric_tmp(nif,k) = tabcoupleparts_fric_tmp(nif,j)
             ENDIF
c
             j = j +1
             IF(tabcoupleparts_fric_tmp(nif,j) /= 0 ) THEN
                k = k +1
                tabparts_fric_tmp(nif,k) = tabcoupleparts_fric_tmp(nif,j)
             ENDIF
             j = j +1
          ENDDO
 
          nsett = k
 
          DO i =1,nsett
             itri2(i) = tabparts_fric_tmp(nif,i)
             index2(i)=i
          ENDDO
          CALL my_orders( 0, work, itri2, index2, nsett , 1)
 
          DO i =1,nsett
             tabparts_fric_tmp(nif,i) = itri2(index2(i)) 
          ENDDO
 
          k = 1
          DO i =1,nsett
             IF(tabparts_fric_tmp(nif,k) /= tabparts_fric_tmp(nif,i)) THEN
                k = k +1
                tabparts_fric_tmp(nif,k) = tabparts_fric_tmp(nif,i)  
              ENDIF
          ENDDO
          IF(nsett > 0) THEN
             intbuf_fric_tab(nif)%S_TABPARTS_FRIC = k
          ELSE
             intbuf_fric_tab(nif)%S_TABPARTS_FRIC = 0
          ENDIF
C------Coefs-----------------------------
          DO i=1,nset
            ifricorth_tmp(nif,i) = trifriorth(index(i))
          ENDDO
  
          IF(iorth == 0 ) THEN
            DO i=1,nset
               DO j=1,8
                  tabcoef_fric_tmp(nif,i*8+j) = tricoef(index(i),j)
               ENDDO
             ENDDO
          ELSEIF(iorth == 1) THEN
            DO i=1,nset
               DO j=1,16
                  tabcoef_fric_tmp(nif,8+(i-1)*16+j) = tricoef(index(i),j)
               ENDDO
             ENDDO
          ENDIF
       ENDDO
C
       DEALLOCATE(index)
       DEALLOCATE(itri)
       DEALLOCATE(tricoef)
       DEALLOCATE(itri2,index2)
       DEALLOCATE(trifriorth)    
C
       RETURN