1 : C INTVA2 SOURCE CHAT 05/01/13 00:41:46 5004 2 : SUBROUTINE INTVA2 (IPRIGI,IPMASS,NBFREQ,INF0,IPSOLU,LIMAGE,LMULT) 3 : ************************************************************************ 4 : * 5 : * I N T V A 2 6 : * ----------- 7 : * 8 : * FONCTION: 9 : * --------- 10 : * 11 : * ISOLATION DES PULSATIONS PROPRES CONTENUES DANS UN INTERVALLE 12 : * DONNE ET CALCUL DES MODES PROPRES CORRESPONDANTS. 13 : * 14 : * MODE D'APPEL: 15 : * ------------- 16 : * 16 : * CALL INTVA2 (IPRIGI,IPMASS,NBFREQ,INF0,IPSOLU) 17 : * 18 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 19 : * ----------- 20 : * 21 : * IPRIGI ENTIER (E) POINTEUR SUR UNE 'RIGIDITE'. 22 : * IPMASS ENTIER (E) POINTEUR SUR UNE 'RIGIDITE'. 23 : * NBFREQ ENTIER (E) NOMBRE MAXIMAL DE MODES PROPRES DEMANDES. 24 : * IPSOLU ENTIER (S) POINTEUR SUR LA 'SOLUTION' CONTENANT LES 25 : * MODES PROPRES. 26 : * 27 : * VOIR AUSSI LE PARAGRAPHE "COMMUN CINTVA". 28 : * 29 : * COMMUN "CINTVA": 30 : * ---------------- 31 : * 32 : * IMULTP ENTIER MIS A 1 SI INTERVALLE A DETECTE UN MODE 33 : * MULTIPLE (=0 SINON) (8 AVRIL 86) 34 : * IPW2 ENTIER POINTEUR SUR LE 'LISTREEL' REPRESENTANT LA 35 : * PARTITION DE L'INTERVALLE DE PULSATIONS AU 36 : * CARRE. 37 : * W2A REEL DP AVANT DERNIERE VALEUR DANS LE 'LISTREEL' DE 38 : * POINTEUR "IPW2". 39 : * W2B REEL DP DERNIERE VALEUR DANS LE 'LISTREEL' DE POINTEUR 40 : * "IPW2". 41 : * W2I REEL DP MILIEU DU SOUS-INTERVALLE (W2A,W2B). 42 : * NBW2 ENTIER NOMBRE DE SOUS-INTERVALLES PLUS 1 DE LA 43 : * PARTITION. 44 : * IPNUM ENTIER POINTEUR SUR LE 'LISTENTI' CONTENANT LA 45 : * COLLECTION DES NOMBRES DE PULSATIONS PROPRES AU 46 : * CARRE INFERIEURES AUX PULSATIONS AU CARRE 47 : * COLLECTEES DANS LE 'LISTREEL' DE POINTEUR 48 : * "IPW2". 49 : * NUM... ENTIER NOMBRE DE PULSATIONS PROPRES AU CARRE 50 : * INFERIEURES A ... ("..." REPRESENTANT "W2A", 51 : * "W2B" OU "W2I") A UNE CONSTANTE PRES ,DEPENDANT 52 : * DE LA 'RIGIDITE' DE POINTEUR "IPRIGI". 53 : * IUN ENTIER = +1 SI LA SUITE DE PULSATIONS DEFINISSANT LA 54 : * PARTITION DE L'INTERVALLE EST EN ORDRE 55 : * DECROISSANT, 56 : * = -1 SINON. 57 : * 58 : * A L'ENTREE DANS "INTVA2", LES VALEURS SUIVANTES DU COMMUN "CINTVA" 59 : * ONT ETE INITIALISEES OU FIXEES PAR LE PROGRAMME APPELANT: 60 : * INITIALISEES: W2A, W2B, NBW2, NUMW2A, NUMW2B. 61 : * FIXEES: IPW2, IPNUM, IUN. 62 : * 63 : * SOUS-PROGRAMMES APPELES: 64 : * ------------------------ 65 : * 66 : * DESOLU, FUSOLU, INTVA3, INTVA4, INTVA5, INTVA6, VRFINT. 67 : * 68 : * AUTEUR, DATE DE CREATION: 69 : * ------------------------- 70 : * 71 : * PASCAL MANIGOT 2 JANVIER 1985 72 : * 73 : * LANGAGE: 74 : * -------- 75 : * 76 : * FORTRAN77 77 : * LES ' GOTO 105 ' ONT ETE AJOUTES EN RAISON D'UNE ERREUR DE 78 : * COMPILATEUR LE 8 AVRIL 86 79 : * 80 : ************************************************************************ 81 : * 82 : IMPLICIT INTEGER(I-N) 83 : IMPLICIT REAL*8 (A-H,O-Z) 84 : -INC CCREEL 85 : -INC CCOPTIO 86 : -INC SMSOLUT 87 : * 88 : * REGROUPEMENT DES INFORMATIONS SUR LA SUITE DE PULSATIONS AU CARRE: 89 : COMMON/CINTVA/IMULTP,IPW2,W2A,W2I,W2B,NBW2,IPNUM,NUMW2A,NUMW2I, 90 : & NUMW2B ,IUN 91 : * 92 : LOGICAL NONVID,LIMAGE,LMULT 93 : * 94 : PARAMETER (SMALL = 1.D-2 , SMALS2 = SMALL/2.D0) 95 : PARAMETER (DEUXPI = (2.D0*XPI)) 96 : * 97 : NONVID = .TRUE. 98 : IFREQ = 0 99 : IMULTP=0 100 : IALEAT=0 101 : INSYM=0 102 : IBID1=0 103 : IBID2=0 104 : * 105 : * /FAIRE TANT QUE .../ 106 : 105 CONTINUE 107 : IF (NONVID .AND. (IFREQ .LT. NBFREQ) ) THEN 108 : * 108 : IF (IIMPI.EQ.2) CALL VRFINT(LIMAGE) 109 : * 110 : IF (NUMW2A .EQ. NUMW2B) THEN 111 : * 112 : * ON RACCOURCIT L'INTERVALLE EN SUPPRIMANT LA PARTIE (W2A,W2B) 112 : CALL INTVA6 (NONVID) 113 : IF (IERR .NE. 0) RETURN 114 : GOTO 105 115 : * 116 : ELSE IF (NUMW2A .EQ. (NUMW2B + IUN) 117 : & .OR. ABS( (W2A-W2B) / (W2A+W2B) ) .LT. SMALS2) THEN 118 : * 119 : IF (NUMW2A .NE. (NUMW2B + IUN) ) THEN 120 : IF (.NOT.LMULT) THEN 121 : IF (IIMPI.EQ.2) WRITE (IOIMP,2000) SMALL,W2A,W2B 122 : 2000 FORMAT (//,' ***** ATTENTION: MODES PROPRES DE MEME ' 123 : & ,'PULSATION OU DE PULSATIONS AU CARRE VOISINES '/ 124 : & ,' ***** A MOINS DE ',1PE8.1,' (ECART RELATIF)' 125 : & ,' DANS L''INTERVALLE (',1PE12.5,',',1PE12.5,').'/ 126 : & ,' ***** ON NE RECHERCHE QU''UN SEUL MODE DANS CET' 127 : & ,' INTERVALLE.'///) 128 : IMULTP=1 129 : ENDIF 130 : END IF 131 : * 132 : * RECHERCHE DE MODE PROPRE: 133 : ********************************************************************** 134 : * 135 : * -- RECHERCHE DES MODES PROPRES MULTIPLES MISE EN PLACE 136 : * LE 29/08/94 . -- 137 : * 138 : ********************************************************************** 139 : 140 : NBMOD = NUMW2A - NUMW2B 141 : 142 : IF ( (NBMOD .EQ. 1) .OR. ( .NOT. LMULT ) ) THEN 143 : ****** 144 : * -- AVANT L'AJOUT DES MODES MULTIPLES -- 145 : *** 145 : CALL INTVA3 (IPRIGI,IPMASS,INF0,IPMODE,IALEAT,LIMAGE) 146 : ELSE 147 : ****** 148 : * -- APRES L'AJOUT DES MODES MULTIPLES -- 149 : *** 150 : W2 = ( W2A + W2B ) / 2.D0 151 : FREQ = SQRT( ABS(W2) ) / DEUXPI 152 : FREQ = SIGN( FREQ, W2 ) 152 : CALL PROCH3(FREQ,NBMOD,IPRIGI,IPMASS,INF0,IPMODE,LIMAGE 153 : $ , INSYM,IBID1,IBID2) 154 : ENDIF 155 : 156 : ****** 157 : * -- FIN DE LA MODIFICATION -- 158 : *** 159 : IMULTP=0 160 : IF (IERR .NE. 0) RETURN 161 : IFREQ = IFREQ + 1 162 : * 163 : * AJOUT DU MODE A L'ENSEMBLE DES MODES: 164 : IF (IFREQ .EQ. 1) THEN 165 : IPSOLU = IPMODE 166 : ELSE 166 : CALL FUSOLU (IPSOLU,IPMODE, IPSOL1) 167 : IF (IERR .NE. 0) RETURN 167 : CALL DESOLU (IPMODE) 167 : CALL DESOLU (IPSOLU) 168 : IPSOLU = IPSOL1 169 : END IF 170 : * 171 : * ON RACCOURCIT L'INTERVALLE EN SUPPRIMANT LA PARTIE (W2A,W2B) 171 : CALL INTVA6 (NONVID) 172 : IF (IERR .NE. 0) RETURN 173 : GOTO 105 174 : * 175 : ELSE IF ( (IUN*(NUMW2A -NUMW2B) ) .GT. 0) THEN 176 : * 177 : W2I = (W2A + W2B) / 2.D0 177 : CALL NBVALP (IPRIGI,IPMASS,W2I, NUMW2I) 178 : IF (IERR .NE. 0) RETURN 179 : * 180 : IF (NUMW2I .EQ. NUMW2B) THEN 181 : * ON RACCOURCIT L'INTERVALLE EN REMPLACANT "W2B" PAR "W2I": 181 : CALL INTVA5 182 : IF (IERR .NE. 0) RETURN 183 : ELSE 184 : * ON INSERE "W2I" AVANT "W2B" DANS LA PARTITION: 184 : CALL INTVA4 185 : IF (IERR .NE. 0) RETURN 186 : END IF 187 : * 188 : ELSE 189 : * 190 : NUMERR = 185 190 : CALL ERREUR (NUMERR) 191 : RETURN 192 : * 193 : END IF 194 : * 195 : GOTO 105 196 : END IF 197 : * /FIN FAIRE/ 198 : * 198 : IF(IALEAT.NE.0) CALL DTCHPO(IALEAT) 199 : IF(IFREQ.EQ.0) THEN 200 : NIPO=0 201 : SEGINI MSOLUT 202 : ITYSOL='MODE ' 203 : SEGDES MSOLUT 204 : IPSOLU=MSOLUT 205 : ENDIF 206 : END 207 : 208 : 209 : 210 : 211 : 212 :
© Cast3M 2003 - All rights reserved.
Disclaimer