intbuf_fric_copy.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	intbuf_fric_copy (tabcoupleparts_fric_tmp, tabcoef_fric_tmp, tabparts_fric_tmp, nsetinit, ifricorth_tmp, intbuf_fric_tab)

Function/Subroutine Documentation

intbuf_fric_copy()

subroutine intbuf_fric_copy	(	integer, dimension(ninterfric,*)	tabcoupleparts_fric_tmp,
			tabcoef_fric_tmp,
		integer, dimension(ninterfric,*)	tabparts_fric_tmp,
		integer, dimension(ninterfric)	nsetinit,
		integer, dimension(ninterfric,*)	ifricorth_tmp,
		type(intbuf_fric_struct_), dimension(*), target	intbuf_fric_tab )

Definition at line 30 of file intbuf_fric_copy.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 TABCOUPLEPARTS_FRIC_TMP(NINTERFRIC,*),TABPARTS_FRIC_TMP(NINTERFRIC,*),
     .        NSETINIT(NINTERFRIC)  ,IFRICORTH_TMP(NINTERFRIC,*) 
      my_real
     .   tabcoef_fric_tmp(ninterfric,*)
 
      TYPE(INTBUF_FRIC_STRUCT_), TARGET, DIMENSION(NINTERFRIC) ::  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 ,N ,IP ,NSETT ,NPARTF ,IORTH ,MFROT ,LENC
      INTEGER, DIMENSION(:)   ,POINTER  :: TABCOUPLEPARTS_FRIC
      INTEGER, DIMENSION(:)   ,POINTER  :: TABPARTS_FRIC
      INTEGER, DIMENSION(:)   ,POINTER  :: ADPART_FRIC
      INTEGER, DIMENSION(:)   ,POINTER  :: IFRICORTH
      my_real, DIMENSION(:)   ,POINTER  :: tabcoef_fric
C
C--------------------------------------------
C=======================================================================
 
       DO nif = 1, ninterfric
           tabcoupleparts_fric  => intbuf_fric_tab(nif)%TABCOUPLEPARTS_FRIC
           tabcoef_fric  => intbuf_fric_tab(nif)%TABCOEF_FRIC 
           tabparts_fric  => intbuf_fric_tab(nif)%TABPARTS_FRIC
           adpart_fric   => intbuf_fric_tab(nif)%ADPARTS_FRIC  
           nset  = intbuf_fric_tab(nif)%NSETPRTS
           nsett  = nsetinit(nif)
           npartf = intbuf_fric_tab(nif)%S_TABPARTS_FRIC 
           iorth = intbuf_fric_tab(nif)%IORTHFRIC
           ifricorth => intbuf_fric_tab(nif)%IFRICORTH
           mfrot = intbuf_fric_tab(nif)%FRICMOD
 
           IF(mfrot ==0 ) THEN   
              lenc =2  
           ELSE
              lenc = 8
           ENDIF 
 
C----------Copying default values of friction in the top of the Tab TABCOEF_FRIC_TMP
           DO j=1,lenc
              tabcoef_fric(j) =tabcoef_fric_tmp(nif,j)
           ENDDO
C----------Copying parts numbers and coefficient in the new structure and omitting duplicated couple of parts
           j = 1
           k = 0
           IF(iorth == 0) THEN
              DO i=1,nsett
                 IF( tabcoupleparts_fric_tmp(nif,j)/= 0) THEN
                    k = k +1
C
                    tabcoupleparts_fric(k) = tabcoupleparts_fric_tmp(nif,j+1)
C
                    DO n=1,lenc
                       tabcoef_fric(lenc*k+n) =tabcoef_fric_tmp(nif,i*8+n)
                    ENDDO
C
                    ifricorth(k) = ifricorth_tmp(nif,i)
                  ENDIF
                  j = j+2
                ENDDO
            ELSEIF(iorth==1) THEN
              DO i=1,nsett
                 IF( tabcoupleparts_fric_tmp(nif,j)/= 0) THEN
                    k = k +1
C
                    tabcoupleparts_fric(k) = tabcoupleparts_fric_tmp(nif,j+1)
C
                    DO n=1,lenc
                       tabcoef_fric(lenc+2*lenc*(k-1)+n) =tabcoef_fric_tmp(nif,8+16*(i-1)+n)
                       tabcoef_fric(2*k*lenc+n) =tabcoef_fric_tmp(nif,16*i+n)
                    ENDDO
                    ifricorth(k) = ifricorth_tmp(nif,i)
                  ENDIF
C
 
                  j = j+2
                ENDDO
 
            ENDIF     
 
C----------Copying parts tab tagged by friction model
           DO i=1,npartf
                tabparts_fric(i) = tabparts_fric_tmp(nif,i)
           ENDDO    
 
C----------Computation of the address of each part in the tabs TABPARTSFRIC TABCOEF_FRIC_TMP
           adpart_fric(1) = 1
           adpart_fric(2:npartf+1) = 0
           DO i=1,npartf 
              k = 0
              j = 1 
              DO n=1,nsett
                IF( tabcoupleparts_fric_tmp(nif,j)/= 0) THEN
                 k = k + 1                  
                 IF(tabcoupleparts_fric_tmp(nif,j) == tabparts_fric(i)) THEN  
                    adpart_fric(i+1) = adpart_fric(i+1) + 1
                 ENDIF  
                ENDIF
                j = j +2
              ENDDO
           ENDDO
           DO i=1,npartf 
               k = i +1
              adpart_fric(k) =adpart_fric(k) +adpart_fric(i)
           ENDDO
 
        ENDDO
C
       RETURN