1 : C EXCHA1 SOURCE KICH 11/08/11 21:15:28 7079 2 : SUBROUTINE EXCHA1(ICHAM,ILISR,CMOT) 3 : 4 : ************************************************************************ 5 : * 6 : * EXTRACTION DES VARIABLES DONT DEPENDENT LES PARAMETRES DU 7 : * MATERIAU. 8 : * 9 : * ICHAM (E) INTEGER POINTEUR SUR LE MCHAML 10 : * ILISR (S) INTEGER POINTEUR SUR UN OBJET DE TYPE SMLMOTS 11 : * CONTENANT LES NOMS DES VARIABLES 12 : * CMOT (E) 13 : * 14 : ************************************************************************ 15 : 16 : IMPLICIT INTEGER(I-N) 17 : IMPLICIT REAL*8(A-H,O-Z) 18 : 19 : -INC CCOPTIO 20 : -INC CCNOYAU 21 : -INC CCASSIS 22 : 23 : -INC SMCHAML 24 : -INC SMLMOTS 25 : -INC SMNUAGE 26 : -INC SMEVOLL 27 : -INC SMTABLE 28 : 29 : PARAMETER ( NNOMCH=24 ) 30 : CHARACTER*(*) CMOT 31 : CHARACTER*8 NOMCHT,NOMVXT,NOMVYT,LNOMCH(NNOMCH) 32 : CHARACTER*4 MOTSIM 33 : DATA MOTSIM / 'SIMU' / 34 : DATA LNOMCH / 'TRAC ','EVOL ','COMP ','FLXY ', 35 : & 'FLXZ ','CISY ','CISZ ','JDA ', 36 : & 'EM0 ','EM1 ','EM2 ','EM3 ', 37 : & 'EM4 ','EM5 ','EM6 ','EM7 ', 38 : & 'EM8 ','MONP ','MONN ','MONO ', 39 : & 'COEV ','TREV ','TRAS ','TRAT ' / 40 : 41 : ICAS = 1 42 : IF (CMOT.EQ.'COVA') ICAS = 2 43 : 44 : *------------- activation de la liste de MOTS ------------------------ 45 : 46 : JGM = 20 47 : JGN = 8 48 : SEGINI MLMOT1 49 : ITE1 = 0 50 : 51 : MCHELM = ICHAM 52 : SEGACT MCHELM 53 : NSOUS = ICHAML(/1) 54 : 55 : *------------------ boucle sur les sous chamelem --------------------- 56 : 57 : DO 1 I1=1,NSOUS 58 : MCHAML = ICHAML(I1) 59 : SEGACT MCHAML 60 : NCOMP = NOMCHE(/2) 61 : 62 : *-------------------- boucle sur les composantes --------------------- 63 : 64 : DO 2 I2=1,NCOMP 65 : IF (TYPCHE(I2).EQ.'REAL*8 ') THEN 66 : GOTO 2 67 : ELSE IF (TYPCHE(I2).EQ.'POINTEURPOINT ') THEN 68 : GOTO 2 69 : ELSE IF (TYPCHE(I2).EQ.'POINTEURMAILLAGE') THEN 70 : GOTO 2 71 : ELSE IF (TYPCHE(I2).EQ.'POINTEURMCHAML ') THEN 72 : GOTO 2 73 : ELSE IF (TYPCHE(I2).EQ.'POINTEURCHPOINT ') THEN 74 : GOTO 2 75 : ELSE IF (TYPCHE(I2).EQ.'POINTEURMMODEL ') THEN 76 : GOTO 2 77 : ELSE IF (TYPCHE(I2).EQ.'POINTEURLISTREEL') THEN 78 : GOTO 2 79 : 80 : ELSE IF (TYPCHE(I2).EQ.'POINTEURNUAGE ') THEN 81 : NOMCHT = NOMCHE(I2) 82 : IF (ICAS.EQ.1) THEN 82 : CALL PLACE(LNOMCH,NNOMCH,iplac,NOMCHT) 83 : MELVAL = IELVAL(I2) 84 : SEGACT MELVAL 85 : NOE = IELCHE(/1) 86 : NEL = IELCHE(/2) 87 : DO 3 I3=1,NEL 88 : DO 4 I4=1,NOE 89 : MNUAGE = IELCHE(I4,I3) 90 : SEGACT MNUAGE 91 : NVAR = NUANOM(/2) 92 : IPOSI = 0 93 : DO 5 I5 = 1,NVAR 94 : IF (NUANOM(I5).EQ.NOMCHT) IPOSI = I5 95 : 5 CONTINUE 96 : IF (IPOSI.NE.0) THEN 97 : DO 6 I6 = 1,NVAR 98 : IF (I6.EQ.IPOSI) THEN 99 : IF (iplac.EQ.0) THEN 100 : IF (NUATYP(I6).EQ.'EVOLUTIO') THEN 101 : NUAVIN=NUAPOI(I6) 102 : SEGACT NUAVIN 103 : MEVOL1=NUAINT(1) 104 : SEGDES NUAVIN 105 : SEGACT MEVOL1 106 : N1=MEVOL1.IEVOLL(/1) 107 : C 108 : C ON TESTE L'OBJET EVOLUTION 109 : C 110 : IF(N1.NE.1) THEN 111 : MOTERR(1:8)='EVOLUTIO' 112 : INTERR(1)=MEVOL1 112 : CALL ERREUR(110) 113 : SEGDES MEVOL1 114 : SEGDES MNUAGE 115 : SEGDES MELVAL 116 : SEGDES MCHAML 117 : GOTO 9000 118 : ENDIF 119 : IF(MEVOL1.ITYEVO.NE.'REEL') THEN 120 : MOTERR(1:8)='EVOLUTIO' 121 : MOTERR(9:16)='REEL ' 121 : CALL ERREUR(79) 122 : SEGDES MEVOL1 123 : SEGDES MNUAGE 124 : SEGDES MELVAL 125 : SEGDES MCHAML 126 : GOTO 9000 127 : ENDIF 128 : KEVOL1=MEVOL1.IEVOLL(1) 129 : SEGDES MEVOL1 130 : SEGACT KEVOL1 131 : IF(KEVOL1.TYPX.NE.'LISTREEL'.OR. 132 : & KEVOL1.TYPY.NE.'LISTREEL')THEN 133 : MOTERR(1:8)='EVOLUTIO' 134 : MOTERR(9:16)='LISTREEL' 135 : INTERR(1)=MEVOL1 135 : CALL ERREUR(630) 136 : SEGDES KEVOL1 137 : SEGDES MNUAGE 138 : SEGDES MELVAL 139 : SEGDES MCHAML 140 : GOTO 9000 141 : ENDIF 142 : NOMVXT=KEVOL1.NOMEVX(1:8) 143 : SEGDES KEVOL1 144 : DO 7 IU=1,ITE1 145 : IF (MLMOT1.MOTS(IU).EQ.NOMVXT) GOTO 8 146 : 7 CONTINUE 147 : ITE1 = ITE1 + 1 148 : IF (ITE1.GT.JGM) THEN 149 : JGM = JGM + 20 150 : SEGADJ MLMOT1 151 : ENDIF 152 : MLMOT1.MOTS(ITE1) = NOMVXT 153 : 8 CONTINUE 154 : ENDIF 155 : ENDIF 156 : ELSE 157 : NOMVXT = NUANOM(I6) 158 : DO 9 IU=1,ITE1 159 : IF (MLMOT1.MOTS(IU).EQ.NOMVXT) GOTO 10 160 : 9 CONTINUE 161 : ITE1 = ITE1 + 1 162 : IF (ITE1.GT.JGM) THEN 163 : JGM = JGM + 20 164 : SEGADJ MLMOT1 165 : ENDIF 166 : MLMOT1.MOTS(ITE1) = NOMVXT 167 : 10 CONTINUE 168 : ENDIF 169 : 6 CONTINUE 170 : ELSE IF (nvar.gt.2) THEN 171 : goto 1 172 : ELSE 173 : *--------- un parametre du mchaml ne correspond a aucun ----------- 174 : *------------------- nom de composante du NUAGE --------------------- 175 : MOTERR(1:8) = NOMCHT 175 : CALL ERREUR(677) 176 : SEGDES MNUAGE 177 : SEGDES MELVAL 178 : SEGDES MCHAML 179 : GOTO 9000 180 : ENDIF 181 : SEGDES MNUAGE 182 : 4 CONTINUE 183 : 3 CONTINUE 184 : SEGDES MELVAL 185 : ELSE IF (ICAS.EQ.2) THEN 186 : DO 11 IU=1,ITE1 187 : IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GO TO 12 188 : 11 CONTINUE 189 : ITE1 = ITE1+1 190 : IF (ITE1.GT.JGM) THEN 191 : JGM= JGM+20 192 : SEGADJ MLMOT1 193 : ENDIF 194 : MLMOT1.MOTS(ITE1) = NOMCHT 195 : 12 CONTINUE 196 : ENDIF 197 : 198 : ELSE IF (TYPCHE(I2).EQ.'POINTEUREVOLUTIO') THEN 199 : NOMCHT = NOMCHE(I2) 199 : CALL PLACE(LNOMCH,NNOMCH,iplac,NOMCHT) 200 : IF (iplac.NE.0) GOTO 2 201 : IF (ICAS.EQ.1) THEN 202 : MELVAL = IELVAL(I2) 203 : SEGACT MELVAL 204 : NOE = IELCHE(/1) 205 : NEL = IELCHE(/2) 206 : DO 13 I13=1,NEL 207 : DO 14 I14=1,NOE 208 : MEVOLL = IELCHE(I14,I13) 209 : SEGACT MEVOLL 210 : KEVOLL = IEVOLL(1) 211 : SEGDES MEVOLL 212 : SEGACT KEVOLL 213 : NOMVYT=NOMEVY(1:8) 214 : IF (NOMCHT.EQ.NOMVYT) THEN 215 : NOMVXT=NOMEVX(1:8) 216 : DO 15 IU=1,ITE1 217 : IF (MLMOT1.MOTS(IU).EQ.NOMVXT) GOTO 16 218 : 15 CONTINUE 219 : ITE1 = ITE1 + 1 220 : IF (ITE1.GT.JGM) THEN 221 : JGM = JGM + 20 222 : SEGADJ MLMOT1 223 : ENDIF 224 : MLMOT1.MOTS(ITE1) = NOMVXT 225 : 16 CONTINUE 226 : ELSE IF (NOMCHT.EQ.'MOCO'. 227 : & AND.NOMVYT(1:4).EQ.'RAID') THEN 228 : *calcul frequentiel 229 : DO 151 IU=1,ITE1 230 : IF (MLMOT1.MOTS(IU).EQ.'TEMP') GOTO 161 231 : 151 CONTINUE 232 : ITE1 = ITE1 + 1 233 : IF (ITE1.GT.JGM) THEN 234 : JGM = JGM + 20 235 : SEGADJ MLMOT1 236 : ENDIF 237 : MLMOT1.MOTS(ITE1) = 'TEMP' 238 : 161 CONTINUE 239 : 240 : ELSE 241 : * Le nom de la composante ne correspond pas a l'ordonnee de l'EVOLUTION 242 : MOTERR(1:8) = NOMCHT 243 : MOTERR(9:20) = NOMEVY 243 : CALL ERREUR(678) 244 : SEGDES KEVOLL 245 : SEGDES MELVAL 246 : SEGDES MCHAML 247 : GOTO 9000 248 : END IF 249 : SEGDES KEVOLL 250 : 14 CONTINUE 251 : 13 CONTINUE 252 : SEGDES MELVAL 253 : ELSE IF (ICAS.EQ.2) THEN 254 : DO 17 IU=1,ITE1 255 : IF( MLMOT1.MOTS(IU) . EQ.NOMCHT) GO TO 18 256 : 17 CONTINUE 257 : ITE1 = ITE1+1 258 : IF (ITE1.GT.JGM) THEN 259 : JGM = JGM + 20 260 : SEGADJ MLMOT1 261 : ENDIF 262 : MLMOT1.MOTS(ITE1) = NOMCHT 263 : 18 CONTINUE 264 : ENDIF 265 : C 266 : ELSE IF (TYPCHE(I2).EQ.'POINTEURLISTMOTS') THEN 267 : C 268 : IF (ICAS.EQ.1) THEN 269 : C 270 : MELVAL=IELVAL(I2) 271 : SEGACT,MELVAL 272 : N2PTEL=IELCHE(/1) 273 : N2EL=IELCHE(/2) 274 : C 275 : C Le LISTMOTS donne les noms des variables dont depend 276 : C la composante, dans l'optique d'une evaluation de la 277 : C composante par une fonction externe. 278 : C HYPOTHESE de CHAMP UNIFORME : la composante depend 279 : C des memes variables en tout point d'integration de 280 : C tout element de la sous-zone. 281 : C Cette hypothese est necessaire car la composante ne 282 : C peut etre associee qu'a une seule fonction externe. 283 : C EN CONFORMITE AVEC VARINU.eso 284 : C 285 : IF (N2PTEL.NE.1.AND.N2EL.NE.1) THEN 286 : MOTERR(1:8)=NOMCHE(I2) 286 : CALL ERREUR(953) 287 : SEGDES,MELVAL 288 : SEGDES,MCHAML 289 : GOTO 9000 290 : ENDIF 291 : MLMOT2=IELCHE(1,1) 292 : SEGACT,MLMOT2 293 : JESIMU=0 294 : IF(MLMOT2.MOTS(1)(1:4).EQ.MOTSIM) THEN 295 : JESIMU=1 296 : ENDIF 297 : NPARA=MLMOT2.MOTS(/2)-JESIMU 298 : IF (ITE1.EQ.0) THEN 299 : ITE1=NPARA 300 : IF (ITE1.GT.JGM) THEN 301 : JGM=NPARA 302 : SEGADJ,MLMOT1 303 : ENDIF 304 : DO 19 IP=1,NPARA 305 : JP=IP+JESIMU 306 : MLMOT1.MOTS(IP)=MLMOT2.MOTS(JP) 307 : 19 CONTINUE 308 : ELSE 309 : DO 20 IP=1,NPARA 310 : NOMCHT = MLMOT2.MOTS(IP+JESIMU) 311 : DO 21 IU=1,ITE1 312 : IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GO TO 20 313 : 21 CONTINUE 314 : ITE1=ITE1+1 315 : IF (ITE1.GT.JGM) THEN 316 : JGM=JGM+20 317 : SEGADJ,MLMOT1 318 : ENDIF 319 : MLMOT1.MOTS(ITE1)=NOMCHT 320 : 20 CONTINUE 321 : ENDIF 322 : SEGDES,MLMOT2 323 : SEGDES,MELVAL 324 : C 325 : ELSE IF (ICAS.EQ.2) THEN 326 : C 327 : NOMCHT = NOMCHE(I2) 328 : DO 22 IU=1,ITE1 329 : IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GO TO 23 330 : 22 CONTINUE 331 : ITE1=ITE1+1 332 : IF (ITE1.GT.JGM) THEN 333 : JGM=JGM+20 334 : SEGADJ,MLMOT1 335 : ENDIF 336 : MLMOT1.MOTS(ITE1)=NOMCHT 337 : 23 CONTINUE 338 : C 339 : ENDIF 340 : C 341 : *-------- Cas d'une table 342 : ELSE IF (TYPCHE(I2).EQ.'POINTEURTABLE') THEN 343 : C 344 : IF (ICAS.EQ.1) THEN 345 : C 346 : MELVAL=IELVAL(I2) 347 : SEGACT,MELVAL 348 : N2PTEL=IELCHE(/1) 349 : N2EL=IELCHE(/2) 350 : C 351 : C La Table contient un LISTMOTS qui donne les 352 : C noms des variables dont depend 353 : C la composante, dans l'optique d'une evaluation de la 354 : C composante par une fonction externe. 355 : C HYPOTHESE de CHAMP UNIFORME : la composante depend 356 : C des memes variables en tout point d'integration de 357 : C tout element de la sous-zone. 358 : C Cette hypothese est necessaire car la composante ne 359 : C peut etre associee qu'a une seule fonction externe. 360 : C EN CONFORMITE AVEC VARINU.eso 361 : C 362 : IF (N2PTEL.NE.1.AND.N2EL.NE.1) THEN 363 : MOTERR(1:8)=NOMCHE(I2) 363 : CALL ERREUR(953) 364 : SEGDES,MELVAL 365 : SEGDES,MCHAML 366 : GOTO 9000 367 : ENDIF 368 : MTAB1=IELCHE(1,1) 369 : SEGACT,MTAB1 370 : if (NBESC.NE.0) SEGACT IPILOC 371 : C Recherche de la liste de mots à ouvrir 372 : ivar = 0 373 : DO 630 IN=1,MTAB1.MLOTAB 374 : if (mtab1.mtabti(in).ne.'MOT') goto 630 375 : IP=MTAB1.MTABII(IN) 376 : IDEBCH=IPCHAR(IP) 377 : IFINCH=IPCHAR(IP+1)-1 378 : IF (ICHARA(IDEBCH:IFINCH).EQ.'VARIABLES') IVAR=IN 379 : 630 CONTINUE 380 : if (ivar.eq.0) GOTO 631 381 : MLMOT2=MTAB1.MTABIV(IVAR) 382 : SEGACT,MLMOT2 383 : JESIMU=0 384 : IF(MLMOT2.MOTS(1)(1:4).EQ.MOTSIM) THEN 385 : JESIMU=1 386 : ENDIF 387 : NPARA=MLMOT2.MOTS(/2)-JESIMU 388 : IF (ITE1.EQ.0) THEN 389 : ITE1=NPARA 390 : IF (NPARA.GT.JGM) THEN 391 : JGM=NPARA 392 : SEGADJ,MLMOT1 393 : ENDIF 394 : DO 29 IP=1,NPARA 395 : JP=IP+JESIMU 396 : MLMOT1.MOTS(IP)=MLMOT2.MOTS(JP) 397 : 29 CONTINUE 398 : ELSE 399 : DO 30 IP=1,NPARA 400 : NOMCHT = MLMOT2.MOTS(IP+JESIMU) 401 : DO 31 IU=1,ITE1 402 : IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GOTO 30 403 : 31 CONTINUE 404 : ITE1=ITE1+1 405 : IF (ITE1.GT.JGM) THEN 406 : JGM=JGM+20 407 : SEGADJ,MLMOT1 408 : ENDIF 409 : MLMOT1.MOTS(ITE1)=NOMCHT 410 : 30 CONTINUE 411 : ENDIF 412 : SEGDES,MLMOT2 413 : 631 CONTINUE 414 : if (NBESC.NE.0) SEGDES IPILOC 415 : SEGDES,MTAB1 416 : SEGDES,MELVAL 417 : C 418 : ELSE IF (ICAS.EQ.2) THEN 419 : C 420 : NOMCHT =NOMCHE(I2) 421 : DO 32 IU=1,ITE1 422 : IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GO TO 33 423 : 32 CONTINUE 424 : ITE1=ITE1+1 425 : IF (ITE1.GT.JGM) THEN 426 : JGM=JGM+20 427 : SEGADJ,MLMOT1 428 : ENDIF 429 : MLMOT1.MOTS(ITE1)=NOMCHT 430 : 33 CONTINUE 431 : C 432 : ENDIF 433 : C 434 : *-------- le type de la composante du mchaml est incorrect ---------- 435 : ELSE 436 : MOTERR(1:8) = NOMCHE(I2) 436 : CALL ERREUR(679) 437 : SEGDES MCHAML 438 : GOTO 9000 439 : END IF 440 : 441 : 2 CONTINUE 442 : SEGDES MCHAML 443 : 1 CONTINUE 444 : 445 : IF (ITE1.NE.JGM) THEN 446 : JGM = ITE1 447 : SEGADJ MLMOT1 448 : ENDIF 449 : 450 : 9000 CONTINUE 451 : IF (IERR.NE.0) THEN 452 : SEGSUP,MLMOT1 453 : ILISR = 0 454 : ELSE 455 : SEGDES,MLMOT1 456 : ILISR = MLMOT1 457 : ENDIF 458 : SEGDES MCHELM 459 : 460 : RETURN 461 : END 462 : 463 : 464 :
© Cast3M 2003 - All rights reserved.
Disclaimer