1 : C VIBRAT SOURCE CHAT 09/10/09 21:25:51 6519 2 : SUBROUTINE VIBRAT 3 : ************************************************************************ 4 : * 5 : * V I B R A T 6 : * ----------- 7 : * 8 : * SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "VIBRATION" 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * CALCUL DE MODES PROPRES. 14 : * 15 : * PHRASE D'APPEL (EN GIBIANE): 16 : * ---------------------------- 17 : * 18 : * ..... = VIBRATION | PROCHE ..... | ; 19 : * | INTERVALLE ..... | 20 : * | SIMULTANE ..... | 21 : * 22 : * VOIR LES DETAILS DANS LES SOUS-PROGRAMMES ASSOCIES AUX OPTIONS 23 : * "PROCHE", "INTERVALLE", ETC... 24 : * 25 : * SOUS-PROGRAMMES APPELES: 26 : * ------------------------ 27 : * 28 : * INTVAL, LIRMOT, PROCHE, SIMULT. 29 : * 30 : * AUTEUR, DATE DE CREATION: 31 : * ------------------------- 32 : * 33 : * PASCAL MANIGOT 13 NOVEMBRE 1984 34 : * 35 : * LANGAGE: 36 : * -------- 37 : * 38 : * FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS 39 : * 40 : ************************************************************************ 41 : * 42 : IMPLICIT INTEGER(I-N) 43 : IMPLICIT REAL*8 (A-H,O-Z) 44 : -INC CCOPTIO 45 : -INC SMSOLUT 46 : -INC SMCHPOI 47 : -INC SMRIGID 48 : -INC SMTABLE 49 : * 50 : COMMON/CITINV/ NBITER,IACCEL,NUMAC,IPX2,IPX0,IPX1,IPBX1, 51 : C IBBX1,IBBX2,ITPRO,DIFREL 52 : * 53 : PARAMETER (NBRMOT = 8) 54 : * 55 : CHARACTER*4 LISMOT(NBRMOT) 56 : CHARACTER*8 letyp,charre 57 : 58 : * 59 : LOGICAL LOG1, LIMAGE, LMULT,boolin 60 : * 61 : DATA LISMOT/'PROC','INTE','SIMU','IMPR','BASS','HAUT', 62 : 1 'TBAS','MULT'/ 63 : * 64 : IBASS=0 65 : IHAUT=0 66 : NOPT=0 67 : LOG1 = .FALSE. 68 : LMULT = .FALSE. 69 : LIMAGE= .FALSE. 70 : NIMP=IIMPI 71 : ICODE = 0 72 : NBMOT = NBRMOT 73 : DO 10 I=1,5 73 : CALL LIRMOT (LISMOT,NBMOT,NUMLIS,ICODE) 74 : IF (IERR .NE. 0) RETURN 75 : IF (NUMLIS.EQ.0) GOTO 10 76 : IF(NUMLIS.LE.3) THEN 77 : IF (NUMLIS.EQ.1) THEN 77 : CALL LIROBJ ('LISTREEL',IPFREQ,1,IRETOU) 78 : IF(IERR.NE.0) RETURN 79 : IPNMOD = 0 79 : CALL LIROBJ ( 'LISTENTI', IPNMOD, 0, IRETOU ) 80 : IF (IERR .NE. 0) RETURN 81 : ENDIF 82 : IF(NUMLIS.EQ.2) THEN 82 : CALL LIRREE(XINT1,1,IRETOU) 83 : IF(IERR.NE.0) RETURN 83 : CALL LIRREE(XINT2,1,IRETOU) 84 : IF(IERR.NE.0) RETURN 85 : ENDIF 86 : IF(NUMLIS.EQ.3) THEN 86 : CALL LIRREE(XINT1,1,IRETOU) 87 : IF(IERR.NE.0) RETURN 87 : CALL LIRENT (IBASS,1,IRETOU) 88 : IF(IERR.NE.0) RETURN 89 : ENDIF 90 : NOPT=NUMLIS 91 : GOTO 10 92 : ENDIF 93 : IF (NUMLIS.EQ.4) THEN 94 : *** IIMPI=2 94 : CALL GINT2 95 : ENDIF 95 : IF (NUMLIS.EQ.5) CALL LIRENT (IBASS,1,IRETOU) 96 : IF(IERR.NE.0) RETURN 96 : IF (NUMLIS.EQ.6) CALL LIRENT(IHAUT,1,IRETOU) 97 : IF(IERR.NE.0) RETURN 98 : IF (NUMLIS.EQ.7) LOG1 = .TRUE. 99 : IF (NUMLIS.EQ.8) LMULT = .TRUE. 100 : 10 CONTINUE 100 : CALL LIROBJ('RIGIDITE',IPRIG1,1,IRETOU) 101 : IF(IERR.NE.0) RETURN 101 : CALL LIROBJ ('RIGIDITE',IPRIG2,1,IRETOU) 102 : IF(IERR.NE.0) RETURN 102 : CALL WHICH1 (IPRIG1,IPRIG2,IPRIGI,IPMASS) 103 : iprig1=iprigi 104 : iprig2=ipmass 104 : CALL LIRLOG(LIMAGE,0,IRETOU) 105 : * dualisation des mult de Lagrange 106 : mrigid=iprig1 107 : segini,ri1=mrigid 108 : segdes mrigid 109 : mrigid=ri1 110 : imgeo2=0 110 : call dbblx(mrigid,lagdua) 111 : imlag=lagdua 112 : iprig1=mrigid 113 : * 114 : IF (NOPT .EQ. 1) THEN 115 : ITPRO=1 115 : CALL PROCHE (IPMASS,IPSOLU,IPFREQ,IPRIG1,IPRIG2,LIMAGE, 116 : & IPNMOD,MBASC,INSYM) 117 : IF(IERR.NE.0) RETURN 118 : ELSE IF (NOPT .EQ. 2) THEN 119 : ITPRO=0 119 : CALL INTVAL (IPMASS,IPSOLU,XINT1,XINT2,IBASS,IHAUT, 120 : $ LIMAGE,IPRIG1,IPRIG2,LMULT) 121 : INSYM = 0 122 : IF(IERR.NE.0) RETURN 123 : ELSE IF (NOPT .EQ. 3) THEN 124 : ITPRO=0 124 : CALL SIMULT (IPMASS,IPSOLU,IPRIG1,IPRIG2,LIMAGE,XINT1,IBASS) 125 : IF(IERR.NE.0) RETURN 126 : INSYM = 0 127 : ELSE 127 : CALL ERREUR (533) 128 : RETURN 129 : ENDIF 130 : * dedualisation de la solution 131 : IF(insym.eq.0) then 132 : msolut=ipsolu 133 : segact msolut*mod 134 : do 210 ilx=1,msolit(/1) 135 : if (msolit(ilx).eq.2) then 136 : msolen=msolis(ilx) 137 : segact msolen*mod 138 : do 200 iso=1,isolen(/1) 139 : mchpoi=isolen(iso) 140 : segact mchpoi*mod 140 : if (lagdua.ne.0) call dbbcf(mchpoi,lagdua) 141 : isolen(iso)=mchpoi 142 : 200 continue 143 : endif 144 : 210 continue 145 : ELSE 146 : if (lagdua.ne.0) then 147 : mtable=mbasc 148 : segact mtable 148 : call acctab(mbasc,'MOT ',iva,xvalin,'MODES',boolin,iobin, 149 : $ 'TABLE ',ivalre,xvalre,charre,boolin,mtab1) 150 : do 250 i=1,10000 151 : letyp=' ' 151 : call acctab (mtab1,'ENTIER ',i,xva,charre,boolin,iobin, 152 : $ letyp,ivalre,xvalre,charre,boolin,mtab2) 153 : if(letyp.ne.'TABLE ') go to 251 154 : letyp=' ' 154 : call acctab(mtab2,'MOT',iva,xva,'DEFORMEE_MODALE_REELLE', 155 : $ boolin,iobin,letyp,ivalre,xvalre,charre,boolin,iobre) 156 : if(letyp.eq.'CHPOINT') then 157 : mchpoi=iobre 158 : segact mchpoi*mod 158 : call dbbcf(mchpoi,lagdua) 158 : call ecctab(mtab2,'MOT',iva,xva,'DEFORMEE_MODALE_REELLE', 159 : $ boolin,iobin,letyp,ivalre,xvalre,charre,boolin,mchpoi) 160 : else 160 : call erreur(5) 161 : return 162 : endif 163 : letyp=' ' 163 : call acctab(mtab2,'MOT',iva,xva,'DEFORMEE_MODALE_IMAGINAIRE', 164 : $ boolin,iobin,letyp,ivalre,xvalre,charre,boolin,iobre) 165 : if(letyp.eq.' ')go to 250 166 : mchpoi=iobre 167 : segact mchpoi*mod 167 : call dbbcf(mchpoi,lagdua) 167 : call ecctab(mtab2,'MOT',ivalin,xva,'DEFORMEE_MODALE_IMAG', 168 : $ boolin,iobin,letyp,ivalre,xvalre,charre,boolin,mchpoi) 169 : 250 continue 170 : endif 171 : 251 continue 172 : ENDIF 173 : 174 : 175 : IF (INSYM .EQ. 0) THEN 176 : 177 : IF (LOG1) THEN 177 : CALL CRTBAS (IPSOLU,IPMASS) 177 : CALL DESOLU (IPSOLU) 178 : ELSE 178 : CALL ECROBJ ('SOLUTION',IPSOLU) 179 : ENDIF 180 : ELSE 180 : CALL LIROBJ('CHPOINT', IPOINT, 0, IRETOU) 180 : CALL ECROBJ('TABLE', MBASC) 181 : END IF 182 : IIMPI=NIMP 182 : CALL GINT2 183 : 184 : END 185 : 186 : 187 : 188 : 189 : 190 : 191 : 192 :
© Cast3M 2003 - All rights reserved.
Disclaimer