1 : C CRTBAS SOURCE JC220346 12/09/13 21:15:07 7504 2 : SUBROUTINE CRTBAS(IPSOLU,IPMASS) 3 : C*********************************************************************** 4 : C 5 : C C R T B A S 6 : C ----------- 7 : C 8 : C SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "VIBRATION" 9 : C 10 : C FONCTION: 11 : C --------- 12 : C 13 : C CREATION D'UNE TABLE DE TYPE BASE_MODALE COMME SORTIE 14 : C DE L'OPERATEUR "VIBRATION" 15 : C 16 : C ARGUMENTS D'ENTREE: 17 : C ------------------ 18 : C 19 : C IPSOLU = POINTEUR SUR L'OBJET SOLUTION 20 : C IPMASS = POINTEUR SUR LA MATRICE MASSE 21 : C 22 : C DESCRIPTION DE LA TABLE BASE_MODALE CREE: 23 : C ---------------------------------------- 24 : C 25 : C TAB1 = 'TABLE' 'BASE_MODALE' ( POINTEUR IPTAB1 ) 26 : C TAB2 = 'TABLE' 'BASE_DE_MODES' ( POINTEUR IPTAB2 ) 27 : C DE MEME STRUCTURE QUE CELLE ISSUE DE LA PROCEDURE 28 : C TRADUIRE. 29 : C TAB3 = 'TABLE' 'MODE' ( POINTEUR IPTAB3 ) 30 : C TAB4 = 'TABLE' 'DEPLACEMENTS_GENERALISES' ( POINTEUR IPTAB4 ) 31 : C 32 : C ---------------------------------------- 33 : C 34 : C TAB1.'SOUSTYPE' = 'BASE_MODALE' 35 : C TAB1.'MODES' = IPTAB2 36 : C 37 : C TAB2.'SOUSTYPE' = 'BASE_DE_MODES' 38 : C TAB2.'MAILLAGE' = IPG1 ( POINTEUR SUR LE 39 : C MAILLAGE EXTRAIT DE LA MATRICE 40 : C MASSE ) 41 : C 42 : C PUIS POUR CHAQUE MODE IMOD1 CONTENU DANS L'OBJET SOLUTION 43 : C 44 : C TAB3.'SOUSTYPE' = 'MODE' 45 : C TAB4.'SOUSTYPE' = 'DEPLACEMENTS_GENERALISES' 46 : C 47 : C TAB4.1 = QX DU MODE 48 : C TAB4.2 = QY DU MODE 49 : C TAB4.3 = QZ DU MODE 50 : C 51 : C TAB3.'NUMERO_MODE' = NUME1 ( NUMERO DU MODE ) 52 : C TAB3.'POINT_REPERE' = IPOIN1 ( NUMERO DU POINT ASSOCIE 53 : C AU MODE ) 54 : C TAB3.'FREQUENCE' = FREQ1 DU MODE 55 : C TAB3.'MASSE_GENERALISEE' = XMGEN1 DU MODE 56 : C TAB3.'DEPLACEMENTS_GENERALISES' = IPTAB4 57 : C TAB3.'DEFORMEE_MODALE' = IPDEP1 ( POINTEUR SUR LE CHAMP 58 : C DE DEPLACEMENTS DU MODE ) 59 : C 60 : C TAB2.IMOD1 = IPTAB3 61 : C 62 : C 63 : C AUTEUR, DATE DE CREATION: 64 : C ------------------------- 65 : C 66 : C NADINE BLAY 21 OCTOBRE 1991 67 : C 68 : C*********************************************************************** 69 : C 70 : IMPLICIT INTEGER(I-N) 71 : IMPLICIT REAL*8 (A-H,O-Z) 72 : C 73 : -INC CCOPTIO 74 : C 75 : -INC SMSOLUT 76 : -INC SMRIGID 77 : -INC SMTABLE 78 : -INC SMELEME 79 : -INC SMLREEL 80 : -INC SMLENTI 81 : CHARACTER*8 letyp,charre 82 : LOGICAL boolin,ltelq 83 : C 84 : C--- RECUPERATION DU MAILLAGE DANS LA MATRICE MASSE 85 : C 86 : MRIGID=IPMASS 87 : SEGACT MRIGID 88 : NBSOUS=IRIGEL(/2) 89 : IPG1=IRIGEL(1,1) 90 : C 91 : IF(NBSOUS.GT.1) THEN 92 : DO 10 I=2,NBSOUS 93 : IPP2=IRIGEL(1,I) 94 : ltelq=.false. 94 : CALL FUSE(IPG1,IPP2,IRET,ltelq) 95 : IPG1=IRET 96 : 10 CONTINUE 97 : ENDIF 98 : SEGDES MRIGID 99 : C 100 : C--- CREATION DE LA TABLE BASE_DE_MODES 101 : C 101 : CALL CRTABL(IPTAB2) 101 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0, 102 : # 'MOT',0,0.D0,'BASE_DE_MODES',.TRUE.,0) 102 : CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0, 103 : # 'MAILLAGE',0,0.D0,' ',.TRUE.,IPG1) 104 : C 105 : C--- EXTRACTION DES INFORMATIONS DE L'OBJET SOLUTION 106 : C 107 : 108 : MSOLUT=IPSOLU 109 : SEGACT MSOLUT 110 : C 111 : MSOLE1=MSOLIS(4) 112 : * si l'objet solution n'est pas vide 113 : if (msole1.ne.0) then 114 : SEGACT MSOLE1 115 : NBMOD1=MSOLE1.ISOLEN(/1) 116 : C 117 : MSOLE2=MSOLIS(5) 118 : SEGACT MSOLE2 119 : C 120 : DO 20 I=1,NBMOD1 121 : IMOD1=I 122 : C 123 : C--- CREATION DE LA TABLE MODE 124 : C 124 : CALL CRTABL(IPTAB3) 124 : CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0, 125 : # 'MOT',0,0.D0,'MODE',.TRUE.,0) 126 : C 127 : C--- CREATION DE LA TABLE DEPLACEMENTS_GENERALISES 128 : C 128 : CALL CRTABL(IPTAB4) 128 : CALL ECCTAB(IPTAB4,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0, 129 : # 'MOT',0,0.D0,'DEPLACEMENTS_GENERALISES',.TRUE.,0) 130 : C 131 : MMODE=MSOLE1.ISOLEN(IMOD1) 132 : SEGACT MMODE 133 : C 134 : NUME1=IMMODD(1) 135 : FRQ1=FMMODD(1) 136 : XMGEN1=FMMODD(2) 137 : QX1=FMMODD(3) 138 : QY1=FMMODD(4) 139 : QZ1=FMMODD(5) 140 : C 141 : MELEME=MSOLIS(3) 142 : SEGACT MELEME 143 : IPOIN1=NUM(1,IMOD1) 144 : SEGDES MELEME 145 : C 146 : IPDEP1=MSOLE2.ISOLEN(IMOD1) 147 : C 148 : C--- REMPLISSAGE DE LA TABLE DEPLACEMENTS_GENERALISES 149 : C 149 : CALL ECCTAB(IPTAB4,'ENTIER',1,0.D0,' ',.TRUE.,0, 150 : # 'FLOTTANT',0,QX1,' ',.TRUE.,0) 150 : CALL ECCTAB(IPTAB4,'ENTIER',2,0.D0,' ',.TRUE.,0, 151 : # 'FLOTTANT',0,QY1,' ',.TRUE.,0) 151 : CALL ECCTAB(IPTAB4,'ENTIER',3,0.D0,' ',.TRUE.,0, 152 : # 'FLOTTANT',0,QZ1,' ',.TRUE.,0) 153 : C 154 : C--- REMPLISSAGE DE LA TABLE MODE 155 : C 155 : CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'NUMERO_MODE',.TRUE.,0, 156 : # 'ENTIER',NUME1,0.D0,' ',.TRUE.,0) 156 : CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'POINT_REPERE',.TRUE.,0, 157 : # 'POINT',0,0.D0,' ',.TRUE.,IPOIN1) 157 : CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'FREQUENCE',.TRUE.,0, 158 : # 'FLOTTANT',0,FRQ1,' ',.TRUE.,0) 158 : CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'MASSE_GENERALISEE',.TRUE.,0, 159 : # 'FLOTTANT',0,XMGEN1,' ',.TRUE.,0) 159 : CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'DEPLACEMENTS_GENERALISES', 160 : # .TRUE.,0,'TABLE',0,0.D0,' ',.TRUE.,IPTAB4) 160 : CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'DEFORMEE_MODALE',.TRUE.,0, 161 : # 'CHPOINT',0,0.D0,' ',.TRUE.,IPDEP1) 162 : C 163 : C--- SUITE DU REMPLISSAGE DE LA TABLE BASE_DE_MODES 164 : C 164 : CALL ECCTAB(IPTAB2,'ENTIER',IMOD1,0.D0,' ',.TRUE.,0, 165 : # 'TABLE',0,0.D0,' ',.TRUE.,IPTAB3) 166 : C 167 : SEGDES MMODE 168 : 20 CONTINUE 169 : C 170 : C 171 : SEGDES MSOLE1 172 : SEGDES MSOLE2 173 : SEGDES MSOLUT 174 : 175 : endif 176 : * 177 : * tri selon les frequences 178 : jg = 10000 179 : segini mlreel,mlenti 180 : do 350 i = 1, 10000 181 : letyp=' ' 181 : call acctab (iptab2,'ENTIER ',i,xva,charre,boolin,iobin, 182 : $ letyp,ivalre,xvalre,charre,boolin,mtab2) 183 : if(letyp.ne.'TABLE ') go to 351 184 : lect(i) = mtab2 184 : call acctab (mtab2,'MOT ',iva,xva,'FREQUENCE',boolin,iobin, 185 : $ 'FLOTTANT',ivalre,xvalre,charre,boolin,ioboi) 186 : prog(i) = xvalre 187 : 350 continue 188 : 351 jg = i - 1 189 : segadj mlreel,mlenti 190 : 190 : call ecrobj('LISTENTI',mlenti) 190 : call ecrobj('LISTREEL',mlreel) 190 : call ORDONN 190 : call lirobj('LISTREEL',mlreel,1,IRETOU) 190 : call lirobj('LISTENTI',mlenti,1,IRETOU) 191 : IF (IERR.NE.0) RETURN 192 : segact mlenti 193 : do i = 1,jg 194 : mtab2 = lect(i) 194 : call ecctab (iptab2,'ENTIER ',i,xva,charre,boolin,iobin, 195 : $ 'TABLE ',ivalre,xvalre,charre,boolin,mtab2) 196 : 197 : enddo 198 : 199 : C 200 : C--- CREATION DE LA TABLE BASE_MODALE 201 : C 201 : CALL CRTABL(IPTAB1) 201 : CALL ECCTAB(IPTAB1,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0, 202 : # 'MOT',0,0.D0,'BASE_MODALE',.TRUE.,0) 202 : CALL ECCTAB(IPTAB1,'MOT',0,0.D0,'MODES',.TRUE.,0, 203 : # 'TABLE',0,0.D0,' ',.TRUE.,IPTAB2) 203 : CALL ECROBJ('TABLE',IPTAB1) 204 : C 205 : END 206 : 207 : 208 : 209 : 210 : 211 : 212 : 213 : 214 : 215 : 216 :
© Cast3M 2003 - All rights reserved.
Disclaimer