1 : C ELLA01 SOURCE CHAT 05/01/12 23:33:44 5004 2 : SUBROUTINE ELLA01(NELEXP,NP2,NFRQ,ITEXP,MATRES) 3 : C 4 : IMPLICIT INTEGER(I-N) 5 : -INC SMLREEL 6 : -INC SMTABLE 7 : -INC SMELEME 8 : C 9 : POINTEUR MLREE4.MLREEL,MLREE5.MLREEL 10 : C 11 : C LECTURE DE LA TABLE DES ELEMENTS EXPERIMENTAUX 12 : C 13 : C MODULE DECODANT DES LISTES REELLES DE COEFFICIENTS 14 : C EXPERIMENTAUX 15 : C 16 : C TEXP = TABLE 'TAB_EXPERIMENTALE' ; 17 : C 18 : C TLT . MAILLAGE = TABLE 'ELEMENT_EXPERIMENTAL' ; 19 : C TEXP . MAILLAGE = TLT(JELEM) ; 20 : C 21 : C LA LONGUEUR DE LA TABLE TEXP EST EGALE A : 22 : C 1 + NOMBRE D'ELEMENTS EXPERIMENTAUX 23 : C 24 : C POINTEUR DE MOT : MTABII(1) 25 : C POINTEUR DE MAILLAGE DU 1 ER MAILLAGE EXPERIMENTAL : MTABII(2) 26 : C POINTEUR DE MAILLAGE DU 2 EME MAILLAGE EXPERIMENTAL : MTABII(3) 27 : C POINTEUR DE MAILLAGE DU JELEM EME MAILLAGE EXPERIMENTAL : MTABII(JTAB) 28 : C 29 : C POINTEUR DE TABLE DU 1 ER MAILLAGE EXPERIMENTAL : MTABIV(2) 30 : C POINTEUR DE TABLE DU 2 EME MAILLAGE EXPERIMENTAL : MTABIV(3) 31 : C POINTEUR DE TABLE DU JELEM EME MAILLAGE EXPERIMENTAL : MTABIV(JTAB) 32 : C 33 : C 1 < JLIGNE < 14 34 : C TE(JELEM)L(JLIGN) = TABLE 'LIGNE' ; 35 : C TLT(JELEM) . JLIGN = TE(JELEM)L(JLIGN) ; 36 : C 37 : C 1 < JCOLO < 28 38 : C 1 -> RUXA : PARTIE REELLE DE UXA 39 : C 2 -> RUYA 40 : C ......... 41 : C JCOLO -> COMP(JCOLO) 42 : C ......... 43 : C 28 -> RQTB 44 : C 29 -> IUXA : PARTIE IMAGINAIRE DE UXA 45 : C ......... 46 : C JCOLO+28 -> COMP(JCOLO+28) 47 : C ......... 48 : C 56 -> IQTB 49 : C 50 : C ENTREES : 51 : C - NELEXP : NOMBRE D'ELEMENTS EXPERIMENTAUX 52 : C - NFRQ : NOMBRE DE POINTS EN FREQUENCE 53 : C - ITEXP : POINTEUR DE LA TABLE : TEXP 54 : C 55 : C SORTIES : 56 : C - MATRES : SEGMENT OU L'ON REMPLIT ALPHAI 57 : C 58 : C VARIABLES LOCALES : 59 : C - PARREE : PARTIE REELLE 60 : C - PARIMA : PARTIE IMAGINAIRE 61 : C POINTEURS : 62 : C - ITAB1 : POINTEUR DE TEXP . MAILLAGE 63 : C - ITAB2 : POINTEUR DE TEXP . MAILLAGE. JLIGN 64 : C - IPOLI1 : POINTEUR DE LISTE REELLE : PARTIE REELLE 65 : C - IPOLI2 : POINTEUR DE LISTE REELLE : PARTIE IMAGINAIRE 66 : C 67 : CHARACTER*4 COMP(56) 68 : CHARACTER*8 CHARI,CHARR,MTYPR 69 : LOGICAL LOGII,LOGIR 70 : REAL*8 PARREE,PARIMA,X0,X1,X2 71 : INTEGER ITEXP,ITAB1,ITAB2,IPOLI1,IPOLI2 72 : C 73 : SEGMENT MATRES 74 : COMPLEX*16 ZA1 (NP28,NP28) 75 : COMPLEX*16 ZSM (NP28) 76 : COMPLEX*16 ZXX (NP28) 77 : COMPLEX*16 ZSOL (NNT14,NFRQ) 78 : REAL*8 COOR (3 ,NP2) 79 : REAL*8 GAMA (3 ,NP) 80 : REAL*8 CARACT(10,NP) 81 : REAL*8 XCL (17 ,NNT) 82 : REAL*8 XCOR (2 , 3 , NBELEM ) 83 : REAL*8 VALDE1(2 , NBELEM , 3 ) 84 : REAL*8 VALDE2(2 , NBELEM , 3 ) 85 : REAL*8 VALDE3(2 , NBELEM , 1 ) 86 : REAL*8 VALDE4(2 , NBELEM , 1 ) 87 : INTEGER FLAG (NNT17) 88 : INTEGER CORRES(NP2) 89 : INTEGER NUMERO(NNT) 90 : INTEGER MASS (4,NNT) 91 : REAL*8 RMAS (4,NNT) 92 : INTEGER IRAILO(4,NNT) 93 : REAL*8 VALRAI(6,NNT) 94 : INTEGER IPIVO(NP28) 95 : INTEGER JPIVO(NP28) 96 : INTEGER IAUX(NP28) 97 : INTEGER IEXPER(NP) 98 : COMPLEX*16 ALPHAI(14,28,NP,NFRQ) 99 : ENDSEGMENT 100 : C 101 : DATA COMP/'RUXA','RUYA','RUZA','RRXA','RRYA','RRZA', 102 : & 'RFXA','RFYA','RFZA','RMXA','RMYA','RMZA','RPRA','RQTA', 103 : & 'RUXB','RUYB','RUZB','RRXB','RRYB','RRZB', 104 : & 'RFXB','RFYB','RFZB','RMXB','RMYB','RMZB','RPRB','RQTB', 105 : & 'IUXA','IUYA','IUZA','IRXA','IRYA','IRZA', 106 : & 'IFXA','IFYA','IFZA','IMXA','IMYA','IMZA','IPRA','IQTA', 107 : & 'IUXB','IUYB','IUZB','IRXB','IRYB','IRZB', 108 : & 'IFXB','IFYB','IFZB','IMXB','IMYB','IMZB','IPRB','IQTB'/ 109 : C 110 : C INITIALISATION 111 : C 112 : CHARI=' ' 113 : CHARR=' ' 114 : C 115 : C 116 : MTAB1=ITEXP 117 : C 118 : SEGACT MTAB1 119 : C 120 : LONTAB=MTAB1.MLOTAB 121 : C 122 : DO 10 JTAB = 2,LONTAB 123 : C 124 : C RECHERCHE DE LA VALEUR DU POINTEUR TEXP . MAILLAGE : ITAB1 125 : C 126 : IPT5=MTAB1.MTABII(JTAB) 127 : SEGACT IPT5 128 : C 129 : C NOMBRE DE TUYAUX DANS LE MELEME 130 : C 131 : NBEL=IPT5.NUM(/2) 132 : C 133 : C NUMERO DES NOEUDS CONSTITUANT L'ELEMENT POINTE 134 : C 135 : INU1=IPT5.NUM(1,NBEL) 136 : INU2=IPT5.NUM(2,NBEL) 137 : C 138 : C RECHERCHE DU NUMERO DE L'ELEMENT EXPERIMENTAL 139 : C 140 : DO 100 III=1,NP2,2 141 : C 142 : IN1=MATRES.CORRES(III) 143 : IN2=MATRES.CORRES(III+1) 144 : C 145 : IF (INU1.EQ.IN1.AND.INU2.EQ.IN2) THEN 146 : NUMEXP=INT(III/2) + 1 147 : END IF 148 : C 149 : IF (INU1.EQ.IN2.AND.INU2.EQ.IN1) THEN 150 : NUMEXP=INT(III/2) + 1 151 : END IF 152 : C 153 : 100 CONTINUE 154 : C 155 : SEGDES IPT5 156 : C 157 : C 1 < INP < NP2 158 : C IEXPER(INP) = 0 : TUYAU FORMULATION INTEGRALE 159 : C IEXPER(INP) = 1 : TUYAU FORMULATION EXPERIMENTALE 160 : C IEXPER(INP) EST MIS A EGAL A 1 SI UNIQUEMENT LE MOT VECT EST 161 : C DECODE DANS LE CHAMP DE CARACTERISTIQUES 162 : C 163 : IF (IEXPER(NUMEXP).NE.0) THEN 164 : ITAB1=MTAB1.MTABIV(JTAB) 165 : END IF 166 : C 167 : IF (ITAB1.NE.0) THEN 168 : C 169 : C LE NOM D'UN COMPOSANT EXPERIMENTAL A ETE DETECTE 170 : C 171 : DO 20 JLIGN=1,14 172 : C 173 : C RECHERCHE DE LA VALEUR DU POINTEUR TEXP . MAILLAGE . JLIGN : ITAB2 174 : C 174 : CALL ACCTAB(ITAB1,'ENTIER',JLIGN,X0,CHARI,LOGII,IP0, 175 : & 'TABLE',I1,X1,CHARR,LOGIR,ITAB2) 176 : C 177 : IF (ITAB2.NE.0) THEN 178 : DO 30 JCOLO=1,28 179 : C 180 : C RECHERCHE DE LA VALEUR DU POINTEUR TEXP . JELEM . JLIGN . 181 : C COMP(JCOLO) : IPOLI1 -> CORRESPOND A LA PARTIE REELLE 182 : C 183 : MTYPR=' ' 183 : CALL ACCTAB(ITAB2,'MOT',I0,X0,COMP(JCOLO),LOGII,IP0, 184 : & MTYPR,I1,X1,CHARR,LOGIR,IPOLI1) 185 : IF (MTYPR.EQ.'LISTREEL') THEN 186 : C 187 : C LA PARTIE REELLE NON NULLE : 188 : C RECHERCHE DE LA VALEUR DU POINTEUR TEXP . JELEM . JLIGN . 189 : C COMP(JCOLO+28) : IPOLI2 -> CORRESPOND A LA PARTIE IMAGINAIRE 190 : C 191 : MTYPR=' ' 191 : CALL ACCTAB(ITAB2,'MOT',I0,X0,COMP(JCOLO+28),LOGII,IP0, 192 : & MTYPR,I1,X1,CHARR,LOGIR,IPOLI2) 193 : IF (MTYPR.EQ.'LISTREEL') THEN 194 : C 195 : C LA PARTIE IMAGINAIRE EST NON NULLE 196 : C 197 : MLREE4=IPOLI1 198 : MLREE5=IPOLI2 199 : SEGACT MLREE4 200 : SEGACT MLREE5 201 : DO 40 JFRQ=1,NFRQ 202 : PARREE=MLREE4.PROG(JFRQ) 203 : PARIMA=MLREE5.PROG(JFRQ) 204 : C 205 : MATRES.ALPHAI(JLIGN,JCOLO,NUMEXP,JFRQ)=CMPLX(PARREE, 206 : & PARIMA) 207 : 40 CONTINUE 208 : SEGDES MLREE4 209 : SEGDES MLREE5 210 : C 211 : ELSE 212 : C 213 : PARIMA=0.D0 214 : MLREEL=IPOLI1 215 : SEGACT MLREEL 216 : DO 50 JFRQ=1,NFRQ 217 : PARREE=PROG(JFRQ) 218 : C 219 : MATRES.ALPHAI(JLIGN,JCOLO,NUMEXP,JFRQ)= 220 : & CMPLX(PARREE,PARIMA) 221 : C 222 : 50 CONTINUE 223 : SEGDES MLREEL 224 : C 225 : END IF 226 : ELSE 227 : C 228 : C LA PARTIE REELLE EST NULLE 229 : C 230 : PARREE=0.D0 231 : MTYPR=' ' 231 : CALL ACCTAB(ITAB2,'MOT',I0,X0,COMP(JCOLO+28),LOGII,IP0, 232 : & MTYPR,I1,X1,CHARR,LOGIR,IPOLI2) 233 : IF (MTYPR.EQ.'LISTREEL') THEN 234 : C 235 : C LA PARTIE IMAGINAIRE EST NON NULLE 236 : C 237 : MLREEL=IPOLI2 238 : SEGACT MLREEL 239 : DO 60 JFRQ=1,NFRQ 240 : PARIMA=PROG(JFRQ) 241 : C 242 : MATRES.ALPHAI(JLIGN,JCOLO,NUMEXP,JFRQ)= 243 : & CMPLX(PARREE,PARIMA) 244 : 60 CONTINUE 245 : SEGDES MLREEL 246 : C 247 : ELSE 248 : C 249 : C LA PARTIE IMAGINAIRE EST NULLE 250 : C 251 : PARIMA=0.D0 252 : DO 70 JFRQ=1,NFRQ 253 : MATRES.ALPHAI(JLIGN,JCOLO,NUMEXP,JFRQ)= 254 : & CMPLX(PARREE,PARIMA) 255 : 70 CONTINUE 256 : C 257 : END IF 258 : C 259 : END IF 260 : C 261 : 30 CONTINUE 262 : C 263 : END IF 264 : 20 CONTINUE 265 : C 266 : END IF 267 : 10 CONTINUE 268 : C 269 : SEGDES MTAB1 270 : C 271 : RETURN 272 : C 273 : end 274 : 275 :
© Cast3M 2003 - All rights reserved.
Disclaimer