Esope source files

   1 : C KPROJG    SOURCE    CHAT      05/01/13    01:05:17     5004           
   2 :       SUBROUTINE KPROJG(K2,NS1,NS2,NS3,NF1,NF2,NF3,NA1,NA2,NA3                  
   3 :      * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROJP,KERR)                             
   4 :       IMPLICIT INTEGER(I-N)
   5 :       IMPLICIT REAL*8 (A-H,O-Z)                                                 
   6 : C----------------------------------------------------------------------         
   7 : C Calcul des facteurs de forme en 3D
   8 : C Sp appele par KPROJF
   9 : C                                                                               
  10 : C                                                                               
  11 : C----------------------------------------------------------------------         
  12 : C                                                                               
  13 :       DIMENSION U2(4)                                                           
  14 : C                                                                               
  15 : -INC TFFOR3D
  16 :       SEGMENT SKSEGM                                                            
  17 :         INTEGER  KKSEGM(2,NSEGM)                                                
  18 :       ENDSEGMENT                                                                
  19 : C                                                                               
  20 : C     DESCRIPTION DES ARETES                                                    
  21 : C                                                                               
  22 :       SEGMENT SPROJP                                                            
  23 :       INTEGER  KF(NPT),ICOO(2,NPT)                                              
  24 :       REAL*8   XR(3,NPT)                                                        
  25 :       ENDSEGMENT                                                                
  26 :       SEGMENT SKCEL                                                             
  27 :       INTEGER  KBCEL(NR,NR),IINT(2,NSTAC),IS(NSTAC),JS(NSTAC)                   
  28 :       REAL*8   RMAX                                                             
  29 :       ENDSEGMENT                                                                
  30 : C                                                                               
  31 : C--------------------------------------------------------------------           
  32 :        NR = IR(/1)                                                              
  33 : C                                                                               
  34 :             IF(NF1.EQ.NF2) THEN                                                 
  35 :               IF(NF2.EQ.NF3) THEN                                               
  36 : C                                                                               
  37 : C     1  FACE                                                                   
  38 : C     -------                                                                   
  39 : C                                                                               
  39 :       CALL KREM1G(K2,NF1,NF2,NF3,NA1,NA2,NA3                                    
  40 :      * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF)                                         
  41 :               ELSE                                                              
  42 : C                                                                               
  43 : C      2 FACES DIFFERENTES NON PARALLELES                                       
  44 : C      ----------------------------------                                       
  45 : C                                                                               
  46 :       IF (KA(NF2).EQ.KA(NF3)) GOTO 500                                          
  46 :       CALL KREM2G(K2,NF2,NF3,NA2,NA3,NA1,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF)        
  47 :               ENDIF                                                             
  48 :                                                                                 
  49 :                ELSE                                                             
  50 :            IF (NF3.EQ.NF2) THEN                                                 
  51 :       IF (KA(NF1).EQ.KA(NF2)) GOTO 500                                          
  51 :       CALL KREM2G(K2,NF2,NF1,NA1,NA3,NA2,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF)        
  52 :                                                                                 
  53 :              ELSE                                                               
  54 :            IF (NF3.EQ.NF1) THEN                                                 
  55 :       IF (KA(NF1).EQ.KA(NF2)) GOTO 500                                          
  55 :       CALL KREM2G(K2,NF1,NF2,NA1,NA2,NA3,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF)        
  56 :                                                                                 
  57 :            ELSE                                                                 
  58 : C                                                                               
  59 : C   3 FACES DIFFERENTES NON PARALLELES                                          
  60 : C   ----------------------------------                                          
  61 :                                                                                 
  62 :       IF (KA(NF1).EQ.KA(NF2)) GOTO 600                                          
  63 :       IF (KA(NF2).EQ.KA(NF3)) GOTO 600                                          
  64 :       IF (KA(NF3).EQ.KA(NF1)) GOTO 600                                          
  64 :       CALL KREM3G(K2,NS1,NS2,NS3,NF1,NF2,NF3,NA1,NA2,NA3                        
  65 :      * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROJP)                                  
  66 : C                                                                               
  67 :         ENDIF                                                                   
  68 :              ENDIF                                                              
  69 :              ENDIF                                                              
  70 :       KERR = 0                                                                  
  71 :       RETURN                                                                    
  72 : C                                                                               
  73 :  500  CONTINUE                                                                  
  74 :       KERR =2                                                                   
  75 :       RETURN                                                                    
  76 :  600  CONTINUE                                                                  
  77 :       KERR =3                                                                   
  78 :       RETURN                                                                    
  79 :       END                                                                       
  80 :  
  81 :