Numérotation des lignes :

C CREBAS    SOURCE    CHAT      09/10/09    21:16:42     6519*       SUBROUTINE CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,FREQ,*     >                          NUMODE2,MTAB3,I)       SUBROUTINE CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,     >                    NUMODE2,MTAB3,I)      IMPLICIT INTEGER(I-N)      IMPLICIT REAL*8 (A-H,O-Z)**************************************************************************                             C R E B A S*                             -----------** FONCTION:* ---------**     CREATION D'UNE BASE DE MODES PROPRES COMPLEXES POUR PROCHE** MODE D'APPEL:* -------------**     CALL CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,FREQ,NUMODE2,MTAB3)** PARAMETRES:   (E)=ENTREE   (S)=SORTIE* -----------**     PROPRE  REEL DP   (E)  TABLEAU DE CARACTERISTIQUES DU MODE PROPRE*                            CALCULE:*                            PROPRE(1) = FREQUENCE PROPRE REELLE,*                            PROPRE(2) = MASSE GENERALISEE,*                            PROPRE(3,4 ET 5) = DEPLACEMENTS GENERALISES*                            REELS*                            PROPRE(6) = FREQUENCE PROPRE IMAGINAIRE*                            PROPRE(8,9,10) = DEPL. GEN. IMAGINAIRES*     IPRX    ENTIER    (E)  POINTEUR DU 'CHPOINT' PROPRE REEL.*     IPIX    ENTIER    (E)  POINTEUR DU 'CHPOINT' PROPRE IMAGINAIRE.*     IPKW2M  ENTIER    (E)  POINTEUR DE LA 'RIGIDITE' "DECALEE" QUI A*                            SERVI AU CALCUL DU MODE PROPRE.*     INF0    ENTIER    (E)  NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA*                            'RIGIDITE' "K" NON "DECALEE" LORSQU'ELLE*                            EST DECOMPOSEE EN LT.D.L.*     FREQ    REEL DP   (E)  FREQUENCE QUI A ETE UTILISEE POUR LE*                            DECALAGE DE LA 'RIGIDITE' "K".*     MTAB3   TABLE    (S)  POINTEUR DE L'OBJET 'SOLUTION' REPRESENTANT*                            LA BASE DE MODE PROPRE.** SOUS-PROGRAMMES APPELES:* ------------------------**     DIAGN1, ECR..., LIR.ALL/LIMO.** AUTEUR, DATE DE CREATION:* -------------------------**     C. LE BIDEAU     JUILLET 2001*     MODIF: Benoit Prabel   Mars 2009** LANGAGE:* --------**     FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS.**************************************************************************-INC CCOPTIO-INC SMTABLE-INC CCREEL-INC SMLCHPO-INC SMLMOTS-INC SMCHPOI-INC SMRIGID*        REAL*8 PROPRE(*)*********************************************    Creation de la table BASE_DE_MODES   *********************************************      CALL CRTABL(IPTAB2)      CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,     &     'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0)  *********************************************     VERIFICATION DU MODES               **********************************************        NUMERO DU MODE         CALL DIAGN1(IPKW2M,NMODEN)*  BP :  Attention !!! le nombre de terme négatif de [K-wshift^2M]*        n'a pas vraiment le meme sens que dans le cas symetrique*        (qui est = au nombre de val propre &lt; shift) !!!         IF (IERR .NE. 0) RETURN         NUMODE = NMODEN + NUMODE2         NUMODE = NUMODE - INF0*         write(6,*)'crebas : (NMODEN + NUMODE2) - INFO = NUMODE'*         write(6,*) NMODEN,NUMODE2,INF0,NUMODE* selon CREMOD, INF0 est toujours nul car le traitement des LX a changé,* et le nbre de terme diag &lt;0 est bien celui des inconnues en depalcements*********************************************        CREATION DU MODE******************************************* *        si lambda_I = 0 (&lt;=> w Re ou Im pur),  alors vp réel*         IF ((PROPRE(6) .EQ. 0.) .or. (PROPRE(1) .EQ. 0.)) GOTO 1000  *------- Cas d'un mode Complexe ---------------------------------------*          ZERO = 0.D0         CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN)         CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'NUMERO_MODE',.TRUE.,0,     &        'ENTIER',NUMODE,0.D0,' ',.TRUE.,0)         CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'POINT_REPERE',.TRUE.,0,     &        'POINT',0,0.D0,' ',.TRUE.,IPOIN)          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'FREQUENCE_REELLE',.TRUE.,0,     &        'FLOTTANT',0,PROPRE(1),' ',.TRUE.,0)         CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'FREQUENCE_IMAGINAIRE',.TRUE.,0     &       ,'FLOTTANT',0,PROPRE(6),' ',.TRUE.,0)          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'MASSE_GENERALISEE',.TRUE.,0     &       ,'FLOTTANT',0,PROPRE(2),' ',.TRUE.,0)          if(IPRX .ne. 0)    then         CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_REELLE',     &        .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IPRX)         else         CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_REELLE',     &        .TRUE.,0,'MOT',0,0.D0,'NULLE',.TRUE.,0)         endif         if(IPIX .ne. 0)    then         CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_IMAGINAIRE',     &        .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IPIX)         else         CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_IMAGINAIRE',     &        .TRUE.,0,'MOT',0,0.D0,'NULLE',.TRUE.,0)         endif**        DEPLACEMENTS GENERALISES          if(IPRX .ne. 0)    then         CALL CRTABL(IPTDG11)         CALL ECCTAB(IPTDG11,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,     &   'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',.TRUE.,0)         CALL ECCTAB(IPTDG11,'ENTIER',1,0.0D0,' ',     &       .TRUE.,0,'FLOTTANT',0,PROPRE(3),' ',.TRUE.,0)         CALL ECCTAB(IPTDG11,'ENTIER',2,0.0D0,' ',     &       .TRUE.,0,'FLOTTANT',0,PROPRE(4),' ',.TRUE.,0)         CALL ECCTAB(IPTDG11,'ENTIER',3,0.0D0,' ',     &       .TRUE.,0,'FLOTTANT',0,PROPRE(5),' ',.TRUE.,0)         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,     &     'DEPLACEMENTS_GENERALISES_REELS',     &     .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG11)         endif          if(IPIX .ne. 0)    then         CALL CRTABL(IPTDG3)         CALL ECCTAB(IPTDG3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,     &   'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_IMAGINAIRES',.TRUE.,0)         CALL ECCTAB(IPTDG3,'ENTIER',1,0.0D0,' ',     &       .TRUE.,0,'FLOTTANT',0,PROPRE(8),' ',.TRUE.,0)         CALL ECCTAB(IPTDG3,'ENTIER',2,0.0D0,' ',     &       .TRUE.,0,'FLOTTANT',0,PROPRE(9),' ',.TRUE.,0)         CALL ECCTAB(IPTDG3,'ENTIER',3,0.0D0,' ',     &       .TRUE.,0,'FLOTTANT',0,PROPRE(10),' ',.TRUE.,0)         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,     &     'DEPLACEMENTS_GENERALISES_IMAGINAIRES',     &     .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG3)         endif c        Ecriture dans MTAB3 . I         CALL ECCTAB(MTAB3,'ENTIER',I,0.0D0,' ',     &        .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2)          GOTO 2000 **------- Cas des modes Reels ---------------------------------------**   L'ecriture specifique pour ce cas est abandonnée au profit de celle ci-dessus*   qui est plus générale pour l'utilisation des données résultats* 1000    CONTINUE**         ZERO = 0.D0*         CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN)*         CALL CRTABL(IPTAB2)*         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'NUMERO_MODE',.TRUE.,0,*     &        'ENTIER',NUMODE,0.0D0,' ',.TRUE.,0)*         CALL CREPO1(0.0D0,0.0D0,0.0D0,IPOIN)*         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0,*     &        'POINT',0,0.0D0,' ',.TRUE.,IPOIN)*         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'FREQUENCE_REELLE',.TRUE.*     &        ,0,'FLOTTANT',0,PROPRE(1),' ',.TRUE.,0)*         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MASSE_GENERALISEE',.TRUE.*     &        ,0,'FLOTTANT',0,PROPRE(2),' ',.TRUE.,0)*         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',*     &        .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,IPRX)*         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'COMPOSANTES_IMAGINAIRES',*     &        .TRUE.,0,'MOT',0,0.0D0,'NULLES',.TRUE.,0)****      DEPLACEMENTS GENERALISES***         CALL CRTABL(IPTDG11)*         CALL ECCTAB(IPTDG11,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,*     &   'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',.TRUE.,0)**         CALL ECCTAB(IPTDG11,'ENTIER',1,0.0D0,' ',*     &       .TRUE.,0,'FLOTTANT',0,PROPRE(3),' ',.TRUE.,0)*         CALL ECCTAB(IPTDG11,'ENTIER',2,0.0D0,' ',*     &       .TRUE.,0,'FLOTTANT',0,PROPRE(4),' ',.TRUE.,0)*         CALL ECCTAB(IPTDG11,'ENTIER',3,0.0D0,' ',*     &       .TRUE.,0,'FLOTTANT',0,PROPRE(5),' ',.TRUE.,0)****      CREATION DE L'OBJET SOLUTION REEL***      CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',*     &     .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG11)*         CALL ECCTAB(MTAB3,'ENTIER',I,0.0D0,' ',*     &        .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2)    2000 CONTINUE        END

© Cast3M 2003 - Tous droits réservés.
Mentions légales