1 : C PROCH1 SOURCE CHAT 09/10/09 21:21:56 6519 2 : C SUBROUTINE PROCH1 (IPFREQ,IPNMOD,IPRIGI,IPMASS,IPSOLU,LIMAGE,IBASC, 3 : C INSYM) 4 : ************************************************************************ 5 : * 6 : * P R O C H 1 7 : * ----------- 8 : * 9 : * FONCTION: 10 : * --------- 11 : * 12 : * EXECUTER LA FONCTION ATTRIBUEE A L'OPERATEUR "PROCHE". 13 : * VOIR LE SOUS-PROGRAMME "PROCHE". 14 : * 15 : * MODE D'APPEL: 16 : * ------------- 17 : * 17 : * CALL PROCH1 (IPFREQ,IPNMOD,IPRIGI,IPMASS,IPSOLU,LIMAGE) 18 : * 19 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 20 : * ----------- 21 : * 22 : * IPFREQ ENTIER (E) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT LA 23 : * SUITE DE FREQUENCES A APPROCHER PAR DES 24 : * FREQUENCES PROPRES. 25 : * IPNMOD ENTIER (E) POINTEUR DE L'OBJET 'LISTENTI' CONTENANT LA 26 : * SUITE DES ORDRES DE MULTIPLICITE DES FREQUENCES 27 : * PROPRES 28 : * IPRIGI ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT 29 : * LA MATRICE DE RIGIDITE. 30 : * IPMASS ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT 31 : * LA MATRICE MASSE. 32 : * IPSOLU ENTIER (S) POINTEUR DE L'OBJET 'SOLUTION' CONTENANT 33 : * LA SUITE DE MODES PROPRES SOLUTIONS. 34 : * INSYM ENTIER INDIQUE LA NON SYMETRIE DE LA MATRICE 35 : * DE RIGIDITE 36 : * LIMAGE BOOLEEN (E) VRAI SI ON SOUHAITE DES FREQ. NEGATIVES. 37 : * IBASC TABLE (S) TABLE D'OBJETS SOLUTION CAS NON SYMETRIQUE 38 : * 39 : * 40 : * 41 : * AUTEUR, DATE DE CREATION: 42 : * ------------------------- 43 : * 44 : * PASCAL MANIGOT 16 OCTOBRE 1984 ( ESOPE ) 45 : * 46 : * MODIFICATION : 47 : *--------------- 48 : * C. LE BIDEAU JUILLET 2001 49 : * Benoit PRABEL MARS 2009 50 : * 51 : ************************************************************************ 52 : 53 : SUBROUTINE PROCH1 (IPFREQ,IPNMOD,IPRIGI,IPMASS,IPSOLU, 54 : & LIMAGE,IBASC, INSYM) 55 : 56 : IMPLICIT INTEGER(I-N) 57 : IMPLICIT REAL*8 (A-H,O-Z) 58 : 59 : -INC CCOPTIO 60 : -INC SMLREEL 61 : -INC SMLENTI 62 : -INC SMRIGID 63 : -INC SMTABLE 64 : 65 : 66 : ****** 67 : * -- PARAMETRES -- 68 : *** 69 : POINTEUR IPFREQ.MLREEL, IPNMOD.MLENTI , IBASC.MTABLE 70 : INTEGER IPRIGI, IPMASS, IPSOLU,INF0,INSYM, NRG, NBR 71 : LOGICAL LIMAGE 72 : 73 : ****** 74 : * -- VARIABLES LOCALES -- 75 : *** 76 : REAL*8 FREQ 77 : INTEGER NBFREQ, NBMOD, IB100, IPSOL1, IPMODE, I 78 : 79 : INF0 = 0 80 : INSYM = 0 81 : 82 : SEGACT ,IPFREQ, IPNMOD 83 : NBFREQ = IPFREQ.PROG(/1) 84 : ****** 85 : * --TEST DE LA SYMETRIE-- 86 : ****** 87 : 88 : MRIGID=IPRIGI 89 : SEGACT MRIGID*MOD 90 : NRG = IRIGEL(/1) 91 : NBR = IRIGEL(/2) 92 : IF(NBR.EQ.0) THEN 93 : SEGDES MRIGID 93 : CALL ERREUR(727) 94 : RETURN 95 : ENDIF 96 : * 97 : * 98 : IF (NRG.GE.7) THEN 99 : C ... On teste si la matrice contient des matrices non symétriques ... 100 : * 101 : * 102 : DO 9 IN = 1,NBR 103 : IANTI=IRIGEL(7,IN) 104 : IF(IANTI.GT.0) THEN 105 : IF(NORINC.NE.0.AND.NORIND.EQ.0) THEN 105 : CALL ERREUR(760) 106 : SEGDES,MRIGID 107 : RETURN 108 : ENDIF 109 : * 110 : INSYM = 1 111 : ENDIF 112 : 9 CONTINUE 113 : END IF 114 : * WRITE(6,*)'INSYM = ',INSYM 115 : * 116 : ****** 117 : * -- POUR CHAQUE FREQUENCE -- 118 : *** 119 : * 120 : IF (INSYM .EQ. 1) THEN 121 : I = 1 121 : CALL CRTABL(IBASC) 121 : CALL ECCTAB(IBASC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 122 : & 'MOT',0,0.0D0,'TABLE_DE_MODES',.TRUE.,0) 122 : CALL CRTABL(MTAB3) 122 : CALL ECCTAB(IBASC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, 123 : & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0) 124 : * 125 : ****** 126 : * CREATION DE L'OBJET SOLUTION 127 : *** 128 : * 128 : CALL CRTABL(MTAB3) 128 : CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE. 129 : & ,0,'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0) 130 : 131 : END IF 132 : DO 100 IB100=1,NBFREQ 133 : FREQ = IPFREQ.PROG(IB100) 134 : NBMOD = IPNMOD.LECT(IB100) 135 : ****** 136 : * -- RECHERCHE D'UN MODE ET AJOUT A L'ENSEMBLE DES MODES 137 : * DEJA TROUVES. POUR LES MODES SIMPLES, ON UTILISE LA 138 : * METHODE DE LA PUISSANCE INVERSE. POUR LES MODES MULTIPLES 139 : * L'ITERATION D'UN SOUS-ESPACE. -- 140 : *** 141 : IF ( NBMOD .LE. 1 ) THEN 142 : IALEAT = 0 142 : CALL PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,LIMAGE, 143 : & INSYM, MTAB3,I) 144 : IF ( IERR .NE. 0 ) RETURN 144 : if (IALEAT.ne.0) CALL DTCHPO ( IALEAT ) 145 : ELSE 145 : CALL PROCH3 (FREQ,NBMOD,IPRIGI,IPMASS,INF0,IPMODE, 146 : & LIMAGE,INSYM, MTAB3, I) 147 : ENDIF 148 : IF ( IERR .NE. 0 ) RETURN 149 : * 150 : * 151 : IF (INSYM .EQ. 0 ) THEN 152 : IF (IB100 .EQ. 1) THEN 153 : IPSOLU = IPMODE 154 : ELSE 154 : CALL FUSOLU (IPSOLU, IPMODE, IPSOL1) 155 : IF ( IERR .NE. 0 ) RETURN 155 : CALL DESOLU(IPMODE) 156 : IF ( IERR .NE. 0 ) RETURN 156 : CALL DESOLU(IPSOLU) 157 : IF ( IERR .NE. 0 ) RETURN 158 : IPSOLU = IPSOL1 159 : ENDIF 160 : **** 161 : ** SI MODES COMPLEXES, TABLES D'OBJETS SOLUTIONS 162 : ** UN ELEMENT DE MBASC CORRESPOND A UN COUPLE SOLUTION 163 : **** 164 : ELSE 165 : 165 : CALL ECCTAB(IBASC,'MOT',0,0.0D0,'MODES',.TRUE.,0, 166 : & 'TABLE',0,0.0D0,' ',.TRUE.,MTAB3) 167 : END IF 168 : 100 CONTINUE 169 : SEGDES ,IPFREQ, IPNMOD 170 : RETURN 171 : END 172 : 173 : 174 : 175 : 176 : 177 :
© Cast3M 2003 - All rights reserved.
Disclaimer