Esope source files

   1 : C POUPAS    SOURCE    CHAT      05/01/13    02:19:29     5004           
   2 :       SUBROUTINE POUPAS(XE,YE,ZE,VECT,P,KERRE)                                  
   3 : C-----------------------------------------------------------------------        
   4 : C  ROUTINE DE CALCUL DE LA MATRICE DE PASSAGE P DES AXES LOCAUX AUX AXES        
   5 : C  GLOBAUX :       DEPLOC= P * DEPGLO                                           
   6 : C                                                                               
   7 : C  ENTREE                                                                       
   8 : C         XE YE ZE  COORDONNEES DES 2 NOEUDS                                    
   9 : C         VECT   VECTEUR DEFINISSANT LE REPERE LOCAL DE LA POUTRE               
  10 : C                                                                               
  11 : C  SORTIE                                                                       
  12 : C         P      MATRICE DE CHANGEMENT DE BASE                                  
  13 : C         KERRE  = 0 SI PAS DE PB                                               
  14 : C                = 1 SI POINTS CONFONDUS                                        
  15 : C                = 2 SI LE VECTEUR LOCAL EST COLINEAIRE A L'ELEMENT             
  16 : C                                                                               
  17 : C-----------------------------------------------------------------------        
  18 :       IMPLICIT INTEGER(I-N)
  19 :       IMPLICIT REAL*8(A-H,O-Z)                                                  
  20 :       DIMENSION XE(*),YE(*),ZE(*),P(3,*),VECT(*),A(3)                           
  21 : C                                                                               
  22 :       KERRE=0                                                                   
  23 :       A(1)=XE(2)-XE(1)                                                          
  24 :       A(2)=YE(2)-YE(1)                                                          
  25 :       A(3)=ZE(2)-ZE(1)                                                          
  26 :       XL=SQRT(A(1)**2+A(2)**2+A(3)**2)                                          
  27 :       IF(XL.EQ.0.D0) THEN                                                       
  28 :       KERRE=1                                                                   
  29 :       RETURN                                                                    
  30 :       ENDIF                                                                     
  31 :       RL=1.D00/XL                                                               
  32 : C                                                                               
  33 : C-----------------------------------------------------------------------        
  34 : C   ON CHOISIT DE DETERMINER ICI LE VECTEUR DEFINISSANT LE                      
  35 : C   REPERE LOCAL DE LA POUTRE SI IL N A PAS ETE DONNE PAR L UTILISATEUR         
  36 : C-----------------------------------------------------------------------        
  37 : C                                                                               
  38 :       IDEF=0                                                                    
  39 :       IF(VECT(1).NE.0..OR.VECT(2).NE.0..OR.VECT(3).NE.0.) GO TO 10              
  40 : C                                                                               
  41 : C  DEFINITION DU VECTEUR LOCAL PAR DEFAUT   ( NON NORME )                       
  42 : C                                                                               
  43 :       VECT(1)=-A(2)*RL                                                          
  44 :       VECT(2)=A(1)*RL                                                           
  45 :       VECT(3)=0.D00                                                             
  46 :       IDEF=1                                                                    
  47 :   10  CONTINUE                                                                  
  48 :       DO 22 I=1,3                                                               
  49 :   22  P(1,I)=A(I)*RL                                                            
  50 :       RLP=0.                                                                    
  51 :       DO 1 I=1,3                                                                
  52 :    1  RLP=RLP+VECT(I)**2                                                        
  53 :       RLP= SQRT(RLP)                                                            
  54 : C                                                                               
  55 : C  TEST DE COLINEARITE                                                          
  56 : C                                                                               
  57 :       PROD=0.D00                                                                
  58 :       DO 4 I=1,3                                                                
  59 :    4  PROD=PROD+VECT(I)*P(1,I)                                                  
  60 :       IF(ABS(PROD).LT.0.99D00*RLP) GO TO 5                                      
  61 :       IF(IDEF.EQ.0) GOTO 41                                                     
  62 :       VECT(1)= 0.D0                                                             
  63 :       VECT(2)= -A(3)*RL                                                         
  64 :       VECT(3)=  A(2)*RL                                                         
  65 :       GOTO 5                                                                    
  66 :   41  CONTINUE                                                                  
  67 :       KERRE=2                                                                   
  68 :       RETURN                                                                    
  69 : C                                                                               
  70 : C  ORTHOGONALISATION ET REMPLISSAGE DE LA MATRICE P                             
  71 : C                                                                               
  72 :   5   CONTINUE                                                                  
  73 :       RLP=0.D00                                                                 
  74 :       DO 6 I=1,3                                                                
  75 :       VECT(I)=VECT(I)-PROD*P(1,I)                                               
  76 :   6   RLP=RLP+VECT(I)**2                                                        
  77 :       RLP=1.D00/SQRT(RLP)                                                       
  78 :       DO 2 I=1,3                                                                
  79 :    2  P(2,I)=VECT(I)*RLP                                                        
  80 :       P(3,1)= P(1,2)*P(2,3)- P(2,2)*P(1,3)                                      
  81 :       P(3,2)=P(1,3)*P(2,1)-P(1,1)*P(2,3)                                        
  82 :       P(3,3)= P(1,1)*P(2,2)-P(1,2)*P(2,1)                                       
  83 :       RETURN                                                                    
  84 :       END                                                                       
  85 :