Esope source files

   1 : C KSUBCR    SOURCE    CHAT      05/01/13    01:09:07     5004           
   2 :       SUBROUTINE KSUBCR(O1,KSUB,NSUB,AA,SHC3D,SPROGP,SPROJA)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)                                                 
   5 : C----------------------------------------------------------------------         
   6 : C Calcul des facteurs de forme en 3D
   7 : C Sp appele par Kprojf
   8 : C     Determination de la projection des sommets et des aretes
   9 : C
  10 : C     O1      : POINT DE VUE PRIS SUR K1                                        
  11 : C     AA      : SOMMETS DU TRIANGLE DE LA FACE K2                               
  12 : C     U2      : NORMALE A LA FACE K2                                            
  13 : C                                                                               
  14 : C----------------------------------------------------------------------         
  15 : C                                                                               
  16 :       DIMENSION U2(4),AA(3,3,4)                                                 
  17 :       DIMENSION X1(3),X2(3),KC1(2),KC2(2)                                       
  18 :       DIMENSION O1(3),O2(3),XG1(3),XG2(3)                                       
  19 :       DIMENSION KG(2),KH(2)                                                     
  20 : -INC TFFOR3D
  21 :       SEGMENT SPROGP                                                            
  22 :       INTEGER  KF(NPT),ICOO(2,NPT)                                              
  23 :       REAL*8   XR(3,NPT)                                                        
  24 :       ENDSEGMENT                                                                
  25 : C                                                                               
  26 :       NPT=KF(/1)                                                                
  27 :       NSE=NFA(/1)                                                               
  28 : C     WRITE(6,*) ' KSUBCR : NPT NSE KSUB NSUB ',NPT,NSE,KSUB,NSUB               
  29 :                                                                                 
  30 : C    SOMMETS                                                                    
  31 : C    -------                                                                    
  32 :             DO 320 I = 1,NPT                                                    
  33 :               DO 322 K=1,KES                                                    
  34 :               O2(K) = AA(K,I,KSUB)                                              
  35 :  322          CONTINUE                                                          
  36 :                                                                                 
  36 :               CALL KAPCUB(KES,O2,O1,NRES,X1,KF(I),ICOO(1,I),ICOO(2,I))          
  37 : C             WRITE(6,*) KF(I),ICOO(1,I),ICOO(2,I)                              
  38 : C             WRITE(6,*) ' XR ',(X1(I1),I1=1,KES)                               
  39 :                                                                                 
  40 :               DO 323 K = 1,KES                                                  
  41 :               XR(K,I) = X1(K)                                                   
  42 :  323          CONTINUE                                                          
  43 :  320        CONTINUE                                                            
  44 : C                                                                               
  45 : C   ARETES                                                                      
  46 : C   ------                                                                      
  47 :             DO 330 I = 1,NSE                                                    
  48 :               NP1 = I                                                           
  49 :               NP2 = I + 1                                                       
  50 :               IF(I.EQ.3) NP2 = 1                                                
  51 :               DO 331 K = 1,KES                                                  
  52 :               X1(K) = XR(K,NP1)                                                 
  53 :               X2(K) = XR(K,NP2)                                                 
  54 :               XG1(K) = AA(K,NP1,KSUB)                                           
  55 :               XG2(K) = AA(K,NP2,KSUB)                                           
  56 :  331          CONTINUE                                                          
  57 :                                                                                 
  58 :               KC1(1) = ICOO(1,NP1)                                              
  59 :               KC1(2) = ICOO(2,NP1)                                              
  60 :               KC2(1) = ICOO(1,NP2)                                              
  61 :               KC2(2) = ICOO(2,NP2)                                              
  62 :               KF1 = KF(NP1)                                                     
  63 :               KF2 = KF(NP2)                                                     
  63 :               CALL KPROJA(O1,XG1,XG2,X1,KF1,KC1,X2,KF2,KC2                      
  64 :      &                  ,I,SPROJA,SHC3D)
  65 :                                                                                 
  66 :  330        CONTINUE                                                            
  67 : C                                                                               
  68 : C     WRITE(6,*) '