Esope source files

   1 : C KREMPA    SOURCE    CHAT      05/01/13    01:06:26     5004           
   2 :       SUBROUTINE KREMPA (K2,KG,NG,NF,NA,NAL,C,U2,                               
   3 :      -         SHC3D,SKCEL,SPROJA,SKBUFF)                                       
   4 :       IMPLICIT INTEGER(I-N)
   5 :       IMPLICIT REAL*8 (A-H,O-Z)                                                 
   6 :       DIMENSION U2(1),KG(2)                                                     
   7 : C----------------------------------------------------------------------
   8 : C Calcul des facteurs de forme en 3D
   9 : C Sp appele par la famille KREMxG
  10 : C
  11 : C     CELLULES-ARETES                                                           
  12 : C     ---------------                                                           
  13 : C                                                                               
  14 : C     DETERMINATION DES CELLULES SITUEES SUR LA FACE 'NF' APPARTENANT           
  15 : C     A LA PROJECTION DE L'ARETE 'NA' DE L'ELEMENT 'K2'                         
  16 : C                                                                               
  17 : C     NA  : INDICE DE L'ARETE                                                   
  18 : C     U2  : NORMALE DE L'ELEMENT K2                                             
  19 : C                                                                               
  20 : C      NAL : INDICE DU NUMERO DE FACE DANS L'ARETE 1,2 OU 3                     
  21 : C            SI 3  ON CALCULE NF                                                
  22 : C                                                                               
  23 : C      SI NFA = 3 : SEUL CAS OU ON CALCULE NF                                   
  24 : C----------------------------------------------------------------------
  25 : 
  26 : -INC TFFOR3D
  27 :       SEGMENT SKCEL                                                             
  28 :       INTEGER  KBCEL(NR,NR),IINT(2,NSTAC),IS(NSTAC),JS(NSTAC)                   
  29 :       REAL*8   RMAX                                                             
  30 :       ENDSEGMENT                                                                
  31 : C                                                                               
  32 :         IF(NAL.NE.3) THEN                                                       
  33 :                                                                                 
  34 :                IF(NF.EQ.IFA(NAL,NA)) THEN                                       
  35 :                   LF = 1                                                        
  36 :                ELSE                                                             
  37 :                   LF = 2                                                        
  38 :                ENDIF                                                            
  39 :         ELSE                                                                    
  40 :            IF (NFA(NA).EQ.3) THEN                                               
  41 :                LF = 3                                                           
  42 :                NF = IFA(3,NA)                                                   
  43 :            ELSE                                                                 
  44 :                IF (IFA(3,NA).EQ.NF) THEN                                        
  45 :                    LF = 3                                                       
  46 :                ELSE                                                             
  47 :                    LF = 4                                                       
  48 :                ENDIF                                                            
  49 :            ENDIF                                                                
  50 :         ENDIF                                                                   
  51 : C                                                                               
  52 :         KG(1) = KG(1) + IG(LF,1,NA)                                             
  53 :         KG(2) = KG(2) + IG(LF,2,NA)                                             
  54 :         NG = NG + 1                                                             
  55 : C                                                                               
  56 :         NOC = NUMF(/2)                                                          
  57 :         DO 403 KC = 1,NCEL(LF,NA)                                               
  58 :             I = ICEL(LF,1,KC,NA)                                                
  59 :             J = ICEL(LF,2,KC,NA)                                                
  60 :             KBCEL(I,J) = 1                                                      
  61 : C                                                                               
  62 :                                                                                 
  63 :          IF (PSC(NF,I,J).GT.-1.) THEN                                           
  64 :             B = 0.                                                              
  65 :             DO 40   IES = 1,KES                                                 
  66 :             B = B + U2(IES)*KSI(NF,IES)*V(KRO(NF,IES),I,J)                      
  67 :  40         CONTINUE                                                            
  68 : C                                                                               
  69 : C           CELLULE SOMMET OU ARETE                                             
  70 : C                                                                               
  71 :             IF (DABS(B).GT.0.0001) THEN                                         
  72 :                Z = -  C / B                                                     
  73 :                DFF = Z - ZB(NF,I,J)                                             
  74 :                DIFF = DABS(DFF)                                                 
  75 :                NTY = NTYP(NF,I,J)                                               
  76 :                IF (DIFF.LT.1E-4.AND.NTY.LT.NOC) THEN                            
  77 :                  DO 100 KT=1,NTY                                                
  78 :                  K = NUMF(NF,KT,I,J)                                            
  79 :                  IF (K.EQ.K2) GOTO 101                                          
  80 :  100             CONTINUE                                                       
  81 :                   NTY = NTY + 1                                                 
  82 :                   NUMF(NF,NTY,I,J) = K2                                         
  83 :                   NTYP(NF,I,J) = NTY                                            
  84 :  101             CONTINUE                                                       
  85 :                ELSE                                                             
  86 :                    IF (DFF.LT.-1E-3.AND.Z.GT.1E-4)  THEN                        
  87 :                        ZB(NF,I,J) = Z                                           
  88 :                        NUMF(NF,1,I,J) = K2                                      
  89 :                        NTYP(NF,I,J) = 1                                         
  90 :                     ENDIF                                                       
  91 :                ENDIF                                                            
  92 :             ENDIF                                                               
  93 :          ENDIF                                                                  
  94 :  403  CONTINUE                                                                  
  95 :                                                                                 
  96 :       RETURN                                                                    
  97 :       END                                                                       
  98 :  
  99 :