1 : C CREBAS SOURCE CHAT 09/10/09 21:16:42 6519 2 : * SUBROUTINE CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,FREQ, 3 : * > NUMODE2,MTAB3,I) 4 : SUBROUTINE CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0, 5 : > NUMODE2,MTAB3,I) 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8 (A-H,O-Z) 8 : ************************************************************************ 9 : * 10 : * C R E B A S 11 : * ----------- 12 : * 13 : * FONCTION: 14 : * --------- 15 : * 16 : * CREATION D'UNE BASE DE MODES PROPRES COMPLEXES POUR PROCHE 17 : * 18 : * MODE D'APPEL: 19 : * ------------- 20 : * 20 : * CALL CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,FREQ,NUMODE2,MTAB3) 21 : * 22 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 23 : * ----------- 24 : * 25 : * PROPRE REEL DP (E) TABLEAU DE CARACTERISTIQUES DU MODE PROPRE 26 : * CALCULE: 27 : * PROPRE(1) = FREQUENCE PROPRE REELLE, 28 : * PROPRE(2) = MASSE GENERALISEE, 29 : * PROPRE(3,4 ET 5) = DEPLACEMENTS GENERALISES 30 : * REELS 31 : * PROPRE(6) = FREQUENCE PROPRE IMAGINAIRE 32 : * PROPRE(8,9,10) = DEPL. GEN. IMAGINAIRES 33 : * IPRX ENTIER (E) POINTEUR DU 'CHPOINT' PROPRE REEL. 34 : * IPIX ENTIER (E) POINTEUR DU 'CHPOINT' PROPRE IMAGINAIRE. 35 : * IPKW2M ENTIER (E) POINTEUR DE LA 'RIGIDITE' "DECALEE" QUI A 36 : * SERVI AU CALCUL DU MODE PROPRE. 37 : * INF0 ENTIER (E) NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA 38 : * 'RIGIDITE' "K" NON "DECALEE" LORSQU'ELLE 39 : * EST DECOMPOSEE EN LT.D.L. 40 : * FREQ REEL DP (E) FREQUENCE QUI A ETE UTILISEE POUR LE 41 : * DECALAGE DE LA 'RIGIDITE' "K". 42 : * MTAB3 TABLE (S) POINTEUR DE L'OBJET 'SOLUTION' REPRESENTANT 43 : * LA BASE DE MODE PROPRE. 44 : * 45 : * SOUS-PROGRAMMES APPELES: 46 : * ------------------------ 47 : * 48 : * DIAGN1, ECR..., LIR.ALL/LIMO. 49 : * 50 : * AUTEUR, DATE DE CREATION: 51 : * ------------------------- 52 : * 53 : * C. LE BIDEAU JUILLET 2001 54 : * MODIF: Benoit Prabel Mars 2009 55 : * 56 : * LANGAGE: 57 : * -------- 58 : * 59 : * FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS. 60 : * 61 : ************************************************************************ 62 : * 63 : -INC CCOPTIO 64 : -INC SMTABLE 65 : -INC CCREEL 66 : -INC SMLCHPO 67 : -INC SMLMOTS 68 : -INC SMCHPOI 69 : -INC SMRIGID 70 : * 71 : REAL*8 PROPRE(*) 72 : * 73 : ******************************************* 74 : * Creation de la table BASE_DE_MODES * 75 : ******************************************* 76 : * 76 : CALL CRTABL(IPTAB2) 76 : CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 77 : & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0) 78 : 79 : 80 : * 81 : ******************************************* 82 : * VERIFICATION DU MODES * 83 : ******************************************* 84 : * 85 : * NUMERO DU MODE 85 : CALL DIAGN1(IPKW2M,NMODEN) 86 : * BP : Attention !!! le nombre de terme négatif de [K-wshift^2M] 87 : * n'a pas vraiment le meme sens que dans le cas symetrique 88 : * (qui est = au nombre de val propre < shift) !!! 89 : IF (IERR .NE. 0) RETURN 90 : NUMODE = NMODEN + NUMODE2 91 : NUMODE = NUMODE - INF0 92 : * write(6,*)'crebas : (NMODEN + NUMODE2) - INFO = NUMODE' 93 : * write(6,*) NMODEN,NUMODE2,INF0,NUMODE 94 : * selon CREMOD, INF0 est toujours nul car le traitement des LX a changé, 95 : * et le nbre de terme diag <0 est bien celui des inconnues en depalcements 96 : * 97 : ******************************************* 98 : * CREATION DU MODE 99 : ******************************************* 100 : 101 : * si lambda_I = 0 (<=> w Re ou Im pur), alors vp réel 102 : * IF ((PROPRE(6) .EQ. 0.) .or. (PROPRE(1) .EQ. 0.)) GOTO 1000 103 : 104 : 105 : *------- Cas d'un mode Complexe ---------------------------------------* 106 : 107 : ZERO = 0.D0 107 : CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN) 107 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'NUMERO_MODE',.TRUE.,0, 108 : & 'ENTIER',NUMODE,0.D0,' ',.TRUE.,0) 108 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'POINT_REPERE',.TRUE.,0, 109 : & 'POINT',0,0.D0,' ',.TRUE.,IPOIN) 110 : 110 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'FREQUENCE_REELLE',.TRUE.,0, 111 : & 'FLOTTANT',0,PROPRE(1),' ',.TRUE.,0) 111 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'FREQUENCE_IMAGINAIRE',.TRUE.,0 112 : & ,'FLOTTANT',0,PROPRE(6),' ',.TRUE.,0) 113 : 113 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'MASSE_GENERALISEE',.TRUE.,0 114 : & ,'FLOTTANT',0,PROPRE(2),' ',.TRUE.,0) 115 : 116 : if(IPRX .ne. 0) then 116 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_REELLE', 117 : & .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IPRX) 118 : else 118 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_REELLE', 119 : & .TRUE.,0,'MOT',0,0.D0,'NULLE',.TRUE.,0) 120 : endif 121 : if(IPIX .ne. 0) then 121 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_IMAGINAIRE', 122 : & .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IPIX) 123 : else 123 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_IMAGINAIRE', 124 : & .TRUE.,0,'MOT',0,0.D0,'NULLE',.TRUE.,0) 125 : endif 126 : * 127 : * DEPLACEMENTS GENERALISES 128 : 129 : if(IPRX .ne. 0) then 129 : CALL CRTABL(IPTDG11) 129 : CALL ECCTAB(IPTDG11,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 130 : & 'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',.TRUE.,0) 130 : CALL ECCTAB(IPTDG11,'ENTIER',1,0.0D0,' ', 131 : & .TRUE.,0,'FLOTTANT',0,PROPRE(3),' ',.TRUE.,0) 131 : CALL ECCTAB(IPTDG11,'ENTIER',2,0.0D0,' ', 132 : & .TRUE.,0,'FLOTTANT',0,PROPRE(4),' ',.TRUE.,0) 132 : CALL ECCTAB(IPTDG11,'ENTIER',3,0.0D0,' ', 133 : & .TRUE.,0,'FLOTTANT',0,PROPRE(5),' ',.TRUE.,0) 133 : CALL ECCTAB(IPTAB2,'MOT',0,0.0D0, 134 : & 'DEPLACEMENTS_GENERALISES_REELS', 135 : & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG11) 136 : endif 137 : 138 : if(IPIX .ne. 0) then 138 : CALL CRTABL(IPTDG3) 138 : CALL ECCTAB(IPTDG3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 139 : & 'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_IMAGINAIRES',.TRUE.,0) 139 : CALL ECCTAB(IPTDG3,'ENTIER',1,0.0D0,' ', 140 : & .TRUE.,0,'FLOTTANT',0,PROPRE(8),' ',.TRUE.,0) 140 : CALL ECCTAB(IPTDG3,'ENTIER',2,0.0D0,' ', 141 : & .TRUE.,0,'FLOTTANT',0,PROPRE(9),' ',.TRUE.,0) 141 : CALL ECCTAB(IPTDG3,'ENTIER',3,0.0D0,' ', 142 : & .TRUE.,0,'FLOTTANT',0,PROPRE(10),' ',.TRUE.,0) 142 : CALL ECCTAB(IPTAB2,'MOT',0,0.0D0, 143 : & 'DEPLACEMENTS_GENERALISES_IMAGINAIRES', 144 : & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG3) 145 : endif 146 : 147 : c Ecriture dans MTAB3 . I 147 : CALL ECCTAB(MTAB3,'ENTIER',I,0.0D0,' ', 148 : & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2) 149 : 150 : GOTO 2000 151 : 152 : * 153 : *------- Cas des modes Reels ---------------------------------------* 154 : * L'ecriture specifique pour ce cas est abandonnée au profit de celle ci-dessus 155 : * qui est plus générale pour l'utilisation des données résultats 156 : * 1000 CONTINUE 157 : * 158 : * ZERO = 0.D0 158 : * CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN) 158 : * CALL CRTABL(IPTAB2) 158 : * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'NUMERO_MODE',.TRUE.,0, 159 : * & 'ENTIER',NUMODE,0.0D0,' ',.TRUE.,0) 159 : * CALL CREPO1(0.0D0,0.0D0,0.0D0,IPOIN) 159 : * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0, 160 : * & 'POINT',0,0.0D0,' ',.TRUE.,IPOIN) 160 : * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'FREQUENCE_REELLE',.TRUE. 161 : * & ,0,'FLOTTANT',0,PROPRE(1),' ',.TRUE.,0) 161 : * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MASSE_GENERALISEE',.TRUE. 162 : * & ,0,'FLOTTANT',0,PROPRE(2),' ',.TRUE.,0) 162 : * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE', 163 : * & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,IPRX) 163 : * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'COMPOSANTES_IMAGINAIRES', 164 : * & .TRUE.,0,'MOT',0,0.0D0,'NULLES',.TRUE.,0) 165 : ** 166 : ** DEPLACEMENTS GENERALISES 167 : ** 167 : * CALL CRTABL(IPTDG11) 167 : * CALL ECCTAB(IPTDG11,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 168 : * & 'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',.TRUE.,0) 169 : * 169 : * CALL ECCTAB(IPTDG11,'ENTIER',1,0.0D0,' ', 170 : * & .TRUE.,0,'FLOTTANT',0,PROPRE(3),' ',.TRUE.,0) 170 : * CALL ECCTAB(IPTDG11,'ENTIER',2,0.0D0,' ', 171 : * & .TRUE.,0,'FLOTTANT',0,PROPRE(4),' ',.TRUE.,0) 171 : * CALL ECCTAB(IPTDG11,'ENTIER',3,0.0D0,' ', 172 : * & .TRUE.,0,'FLOTTANT',0,PROPRE(5),' ',.TRUE.,0) 173 : ** 174 : ** CREATION DE L'OBJET SOLUTION REEL 175 : ** 175 : * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS', 176 : * & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG11) 176 : * CALL ECCTAB(MTAB3,'ENTIER',I,0.0D0,' ', 177 : * & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2) 178 : 179 : 180 : 181 : 2000 CONTINUE 182 : 183 : END 184 : 185 : 186 : 187 : 188 : 189 : 190 : 191 :
© Cast3M 2003 - All rights reserved.
Disclaimer