dfunc0.F File Reference

#include "implicit_f.inc"
#include "vect01_c.inc"
#include "mvsiz_p.inc"
#include "sphcom.inc"
#include "com01_c.inc"
#include "scr17_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	dfunc0 (elbuf_tab, func, ifunc, iparg, pm, el2fa, nbf, spbuf, ipart, ipartsp)

Function/Subroutine Documentation

dfunc0()

subroutine dfunc0	(	type (elbuf_struct_), dimension(ngroup), target	elbuf_tab,
			func,
		integer	ifunc,
		integer, dimension(nparg,*)	iparg,
			pm,
		integer, dimension(*)	el2fa,
		integer	nbf,
			spbuf,
		integer, dimension(lipart1,*)	ipart,
		integer, dimension(*)	ipartsp )

Definition at line 30 of file dfunc0.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE elbufdef_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      "vect01_c.inc"                                            
#include      "mvsiz_p.inc"                                            
#include      "sphcom.inc"
#include      "com01_c.inc"                                             
#include      "scr17_c.inc"
#include      "param_c.inc"                                             
C-----------------------------------------------                        
C   D u m m y   A r g u m e n t s                                       
C-----------------------------------------------                        
C     REAL                                                    
      my_real                                                           
     .   func(*), pm(npropm,*),spbuf(nspbuf,*)                                                
      INTEGER IPARG(NPARG,*),EL2FA(*),IFUNC,NBF,                        
     .        IPART(LIPART1,*),IPARTSP(*)                                    
      TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB                                  
C-----------------------------------------------                        
C   L o c a l   V a r i a b l e s                                       
C-----------------------------------------------                        
      my_real                                                           
     .   evar(mvsiz),                                                   
     .   p, vonm2, vonm, s1, s2, s12, s3, VALUE
      INTEGER I,II(6),NG,NEL,N,MLW,NN,NN1,JTURB,MT,IALEL,IPRT           
      TYPE(G_BUFEL_) ,POINTER :: GBUF
      REAL R4,WA(NBF)                                                   
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
C La routine ne fonctionne que pour les IFUNC 3,6,7,14-19 (stress)      
C=======================================================================                                                                       
      nn1 = 1                                                           
c      NN2 = NN1 + (NUMSPH+MAXPJET)                                      
C                                                                       
C-----------------------------------------------                        
      DO 900 ng=1,ngroup                                                
        nel = iparg(2,ng)                                            
        nft = iparg(3,ng)
        ity = iparg(5,ng)
        lft=1                                                           
        llt=nel                                                         
!
        DO i=1,6
          ii(i) = (i-1)*nel
        ENDDO
!
C-----------------------------------------------                        
        IF (ity == 51) THEN                                               
C         PARTICULES SPH.                                                 
C-----------------------------------------------                        
          IF (ifunc == 0) THEN                                            
            DO i=lft,llt                                                
              n = i + nft                                                
              func(el2fa(nn1+n)) = spbuf(1,n)                            
            ENDDO                                                       
          ELSE                                                          
            gbuf => elbuf_tab(ng)%GBUF
            jturb= iparg(12,ng)*(iparg(7,ng)+iparg(11,ng))               
            ialel= iparg(7,ng)+iparg(11,ng)                           
c
            IF (ifunc == 3) THEN                                           
              DO i=lft,llt                                               
                n = i + nft                                              
                IF(ialel == 0)THEN                                       
                  iprt=ipartsp(n)                                        
                  mt  =ipart(1,iprt)                                     
                  VALUE = gbuf%EINT(i)/max(em30,pm(89,mt))
                ELSE                                                     
                 VALUE = gbuf%EINT(i)/max(em30,gbuf%RHO(i))
                ENDIF                                                    
                func(el2fa(nn1+n)) = VALUE                               
              ENDDO                                                      
c
            ELSEIF (ifunc == 6 .OR. ifunc == 7) THEN                         
              DO i=lft,llt                                               
!!                II = (I-1)*6
                n = i + nft                                              
                IF(el2fa(nn1+n)/=0)THEN                                
                  p = - (gbuf%SIG(ii(1) + i)                
     .                 + gbuf%SIG(ii(2) + i)                
     .                 + gbuf%SIG(ii(3) + i) ) * third
                  VALUE = p
                  IF(ifunc == 7) THEN                                   
                    s1=gbuf%SIG(ii(1) + i) + p          
                    s2=gbuf%SIG(ii(2) + i) + p          
                    s3=gbuf%SIG(ii(3) + i) + p          
                    vonm2= three*(gbuf%SIG(ii(4) + i)**2 +    
     .                            gbuf%SIG(ii(5) + i)**2 +    
     .                            gbuf%SIG(ii(6) + i)**2 +    
     .                     half*(s1*s1+s2*s2+s3*s3) )         
                    vonm= sqrt(vonm2) 
                    VALUE = vonm
                  ENDIF                                                 
                  func(el2fa(nn1+n)) = VALUE                            
                ENDIF                                                    
              ENDDO                                                      
c
            ELSEIF (ifunc >= 14 .AND. ifunc <= 19) THEN                      
              DO i=lft,llt                                               
!!                II = (I-1)*6
                n = i + nft                                               
                IF(el2fa(nn1+n)/=0)THEN                                 
                   func(el2fa(nn1+n)) = gbuf%SIG(ii(ifunc - 13) + i)
               ENDIF                                                     
              ENDDO                                                      
            ELSE                                                         
              DO i=lft,llt                                               
                n = i + nft                                               
                IF(el2fa(nn1+n)/=0)THEN                                 
                   func(el2fa(nn1+n)) = zero                             
                ENDIF                                                     
              ENDDO                                                      
            ENDIF                                                        
          ENDIF                                                         
        ENDIF                                                           
C-----------------------------------------------                        
C       FIN DE BOUCLE SUR LES GROUPES                                   
C-----------------------------------------------                        
 900  CONTINUE                                                          
C-----------------------------------------------                        
      DO n=1,nbf                                                        
         r4 = func(n)                                                   
         CALL write_r_c(r4,1)                                           
      ENDDO                                                             
C-----------                                                                      
      RETURN