1 : C EXPIL SOURCE PV 13/03/26 21:15:06 7747 2 : SUBROUTINE EXPIL (IFILE,ICOLAC,M1,M2,IIICHA) 3 : C---------------------------------------------------------------------- 4 : C 5 : C BUT: REMPLIT LES PILES A PARTIR DE L EXAMEN DE LA PILE 6 : C SI IIICHA =1 ON CHANGE LES POINTEURS---- 7 : C 8 : C ENTREE IFILE NUMERO DE LA PILE EXAMINEE 9 : C ICOLAC POINTEUR SUR LE CHAPEAU DES PILES 10 : C M1 @REMIER INDICE D EXAMEN DANS LA PILE 11 : C M2 DERNIER INDICE 12 : C IIICHA =1 ON CHANGE LES POINTEURS 13 : C---------------------------------------------------------------- 14 : C PROGRAMME PAR FARVACQUE- REPRIS PAR LENA 15 : C APPELE PAR FILLPI 16 : C APPELLE AJOUN TYPFIL 17 : C======================================================================= 18 : C TABLEAU KCOLA : VOIR LE SOUS-PROGRAMME TYPFIL 19 : C======================================================================= 20 : IMPLICIT INTEGER(I-N) 21 : IMPLICIT REAL*8(A-H,O-Z) 22 : -INC CCOPTIO 23 : -INC CCASSIS 24 : 25 : *INC SMELEME 26 : -INC SMBASEM 27 : *INC SMCHPOI 28 : *INC SMRIGID 29 : -INC SMMATRI 30 : -INC SMCLSTR 31 : -INC SMELSTR 32 : -INC SMSOLUT 33 : -INC SMDEFOR 34 : -INC SMSTRUC 35 : -INC SMATTAC 36 : -INC SMCHARG 37 : -INC SMMODEL 38 : -INC SMEVOLL 39 : -INC SMTABLE 40 : -INC SMSUPER 41 : -INC SMTEXTE 42 : -INC SMVECTE 43 : -INC SMLCHPO 44 : -INC SMINTE 45 : -INC SMNUAGE 46 : -INC TMCOLAC 47 : 48 : SEGMENT ITRAVV(NITLAC) 49 : CHARACTER*(8) ITYP1 50 : CHARACTER*(1) CHAVAL 51 : CHARACTER*(16) MOTYP 52 : C======================================================================= 53 : C ICOLAC : KCOLA : POINTEUR SUR LA PILE ITLACC 54 : C MCOLA : NOMBRE D'OBJETS INSPECTES DANS LA PILE 55 : C ICOLA : POINTEUR SUR ISGTR ( NOM-NOM-RANG DANS ITLACC) 56 : C KCOLAC: CONTIENT POUR CHAQUE PILE LE NOMBRE D'OBJETS A SORT 57 : C======================================================================= 58 : IF (M1.GT.M2) RETURN 59 : IF (IIMPI.EQ.5) WRITE (IOIMP,8877) IFILE,M1,M2 60 : 8877 FORMAT (' EXAMEN DE LA PILE ',I5,' DE',I5,' A',I5) 61 : SEGACT ICOLAC 62 : ILISSE=ILISSG 63 : SEGACT ILISSE*MOD 64 : ITLACC=KCOLA(IFILE) 65 : GO TO(501,502,503,599,599,506,507,508,509,510, 66 : 1 599,512,599,514,515,516,517,599,599,520, 67 : 1 599,522,523,524,525,526,527,528,529,530, 68 : 1 531,532,533,534,535,599,599,538,539,540, 69 : 1 541,542,543,510,545,546),IFILE 69 : CALL TYPFIL(MOTERR,IFILE) 69 : CALL ERREUR (336) 69 : CALL GINT2 70 : GO TO 599 71 : C ******************************* MELEME**************************** 72 : 501 CONTINUE 73 : C ICO1=KCOLA(1) 73 : CALL EXAMEL (ICOLAC,ITLACC,M1,M2,IIICHA) 74 : GO TO 599 75 : C **************************** MCHPOI ****************************** 76 : 502 CONTINUE 77 : C ICO1=KCOLA(1) 77 : CALL EXACHP (ICOLAC,ITLACC,M1,M2,IIICHA) 78 : GO TO 599 79 : C **************************** MRIGID ****************************** 80 : 503 CONTINUE 80 : CALL EXARIG (ICOLAC,ITLACC,M1,M2,IIICHA) 81 : GO TO 599 82 : C *************************** ******************************* 83 : 504 CONTINUE 84 : GO TO 599 85 : C *************************** ******************************* 86 : 505 CONTINUE 87 : GO TO 599 88 : C **************************** MCLSTR ****************************** 89 : 506 CONTINUE 90 : ICO1=KCOLA(12) 91 : ICO2=KCOLA(3) 92 : DO 614 IEL=M1,M2 93 : MCLSTR=ITLAC(IEL) 94 : IF (MCLSTR.EQ.0) GO TO 614 95 : SEGACT MCLSTR*MOD 96 : DO 615 I=1,ISOSTR(/1) 97 : IVA=ISOSTR(I) 97 : IF(IVA.NE.0)CALL AJOUN(ICO1,IVA,ILISSE,1) 98 : IF(IIICHA.EQ.1)ISOSTR(I)=IVA 99 : IVA=IRIGCL(I) 99 : IF (IVA.NE.0)CALL AJOUN(ICO2,IVA,ILISSE,1) 100 : IF(IIICHA.EQ.1)IRIGCL(I)=IVA 101 : 615 CONTINUE 102 : SEGDES MCLSTR 103 : 614 CONTINUE 104 : GO TO 599 105 : C **************************** MELSTR ****************************** 106 : 507 CONTINUE 107 : ICO1=KCOLA(12) 108 : ICO2=KCOLA(1) 109 : DO 616 IEL=M1,M2 110 : MELSTR=ITLAC(IEL) 111 : IF (MELSTR.EQ.0) GO TO 616 112 : SEGACT MELSTR*MOD 113 : DO 617 I=1,ISOSTU(/1) 114 : IVA=ISOSTU(I) 114 : IF(IVA.NE.0)CALL AJOUN(ICO1,IVA,ILISSE,1) 115 : IF(IIICHA.EQ.1)ISOSTU(I)=IVA 116 : IVA=IMELEM(I) 116 : IF (IVA.NE.0)CALL AJOUN(ICO2,IVA,ILISSE,1) 117 : IF(IIICHA.EQ.1)IMELEM(I)=IVA 118 : 617 CONTINUE 119 : SEGDES MELSTR 120 : 616 CONTINUE 121 : GO TO 599 122 : C *************************** MSOLUT ******************************* 123 : 508 CONTINUE 124 : ICO1=KCOLA(1) 125 : DO 618 IEL=M1,M2 126 : MSOLUT=ITLAC(IEL) 127 : IF (MSOLUT.EQ.0) GO TO 618 128 : SEGACT MSOLUT*MOD 129 : NIPO=MSOLIS(/1) 130 : DO 620 II=1,NIPO 131 : IF(MSOLIS(II).EQ.0) GOTO 620 132 : IF(II.EQ.3) THEN 133 : IVA=MSOLIS(3) 133 : CALL AJOUN(ICO1,IVA,ILISSE,1) 134 : CCC IF (IONIVE.LT.3) GO TO 620 135 : IF(IIICHA.EQ.1) MSOLIS(3)=IVA 136 : GOTO 620 137 : ENDIF 138 : IF(II.LE.4) GOTO 620 139 : ICO2=KCOLA(MSOLIT(II)) 140 : MSOLEN=MSOLIS(II) 141 : SEGACT MSOLEN*MOD 142 : LTAB=ISOLEN(/1) 143 : DO 619 I=1,LTAB 144 : IVA=ISOLEN(I) 145 : IF(IVA.EQ.0)GOTO 619 145 : CALL AJOUN(ICO2,IVA,ILISSE,1) 146 : IF (IONIVE.LT.3) GO TO 619 147 : IF(IIICHA.EQ.1) ISOLEN(I)=IVA 148 : 619 CONTINUE 149 : SEGDES MSOLEN 150 : 620 CONTINUE 151 : SEGDES MSOLUT 152 : 618 CONTINUE 153 : GOTO 599 154 : C ************************** MSTRUC ******************************** 155 : 509 CONTINUE 156 : ICO1=KCOLA(12) 157 : DO 621 IEL=M1,M2 158 : MSTRUC=ITLAC(IEL) 159 : IF (MSTRUC.EQ.0) GO TO 621 160 : SEGACT MSTRUC*MOD 161 : DO 622 I=1,LISTRU(/1) 162 : IVA=LISTRU(I) 163 : IF(IVA.EQ.0) GO TO 622 164 : IF(IVA.GT.0) THEN 164 : CALL AJOUN(ICO1,IVA,ILISSE,1) 165 : IF(IIICHA.EQ.1) LISTRU(I)=-IVA 166 : ENDIF 167 : 622 CONTINUE 168 : SEGDES MSTRUC 169 : 621 CONTINUE 170 : GOTO 599 171 : C ******************************* MTABLE ************************** 172 : * POUR LES TABLES ON COMMENCE PAR METTRE DANS LA PILE DES REELS 173 : * LES VALEURS REELLES ON ON PREND LEUR INDICE 174 : * CECI NOUS PERMET D'ETRE COMPATIBLE AVEC LES VERSIONS ANTERIEURES 175 : * PV 28 DECEMBRE 1988 176 : 510 CONTINUE 177 : DO 710 IEL=M1,M2 178 : 179 : MTABLE=ITLAC(IEL) 180 : IF (MTABLE.EQ.0) GO TO 710 181 : SEGACT MTABLE*MOD 182 : L6=MLOTAB 183 : IF (L6.EQ.0) GO TO 713 184 : DO 711 K=1,L6 185 : 186 : ITYP1=MTABTI(K) 187 : IF (IIICHA.NE.1.AND.ITYP1.EQ.'FLOTTANT') THEN 188 : XVA=RMTABI(K) 188 : CALL QUERAN(IVA,'FLOTTANT',0,XVA,' ',.TRUE.,0) 189 : MTABII(K)=IVA 190 : ENDIF 191 : IVA=MTABII(K) 192 : J=0 192 : CALL TYPFIL (ITYP1,J) 193 : IF(J.LE.0) GO TO 711 194 : ICO2=KCOLA(J) 195 : NUMLIS=1 196 : IF(J.EQ.24) NUMLIS=6 197 : IF(J.EQ.25) NUMLIS=4 198 : IF(J.EQ.26) NUMLIS=2 199 : IF(J.EQ.27) NUMLIS=5 200 : IF(J.EQ.32) NUMLIS=3 201 : IF(J.EQ.36) NUMLIS=7 201 : CALL AJOUN (ICO2,IVA,ILISSE,NUMLIS) 202 : IF(IIICHA.EQ.1) MTABII(K)=IVA 203 : ITYP1=MTABTV(K) 204 : IF (IIICHA.NE.1.AND.ITYP1.EQ.'FLOTTANT') THEN 205 : XVA=RMTABV(K) 205 : CALL QUERAN(IVA,'FLOTTANT',0,XVA,' ',.TRUE.,0) 206 : MTABIV(K)=IVA 207 : ENDIF 208 : IVA=MTABIV(K) 208 : CALL TYPFIL (ITYP1,J) 209 : IF(J.LE.0) GO TO 711 210 : IF (J.EQ.47) GO TO 711 211 : ICO2=KCOLA(J) 212 : NUMLIS=1 213 : IF(J.EQ.24) NUMLIS=6 214 : IF(J.EQ.25) NUMLIS=4 215 : IF(J.EQ.26) NUMLIS=2 216 : IF(J.EQ.27) NUMLIS=5 217 : IF(J.EQ.32) NUMLIS=3 218 : IF(J.EQ.36) NUMLIS=7 218 : CALL AJOUN (ICO2,IVA,ILISSE,NUMLIS) 219 : IF(IIICHA.EQ.1) MTABIV(K)=IVA 220 : 711 CONTINUE 221 : 713 SEGDES MTABLE 222 : 710 CONTINUE 223 : GO TO 599 224 : 715 CONTINUE 225 : MOTERR(1:8)=ITYP1 225 : CALL ERREUR (336) 226 : GO TO 599 227 : C ******************************* ************************* 228 : 511 CONTINUE 229 : GO TO 599 230 : C ******************************** MSOSTU ************************** 231 : 512 CONTINUE 232 : ICO5=KCOLA(5) 233 : ICO3=KCOLA(3) 234 : DO 630 IEL=M1,M2 235 : MSOSTU=ITLAC(IEL) 236 : IF (MSOSTU.EQ.0) GO TO 630 237 : SEGACT MSOSTU*MOD 238 : IVA=ISRAID 238 : IF (IVA.NE.0)CALL AJOUN(ICO3,IVA,ILISSE,1) 239 : IF(IIICHA.EQ.1)ISRAID=IVA 240 : IVA=ISMASS 240 : IF (IVA.NE.0)CALL AJOUN(ICO3,IVA,ILISSE,1) 241 : IF(IIICHA.EQ.1)ISMASS=IVA 242 : NS=ISCHAM(/1) 243 : IF (NS.EQ.0) GO TO 122 244 : DO 121 I=1,NS 245 : IVA= ISCHAM(I) 245 : IF (IVA.NE.0)CALL AJOUN (ICO5,IVA,ILISSE,1) 246 : IF(IIICHA.EQ.1) ISCHAM(I)=IVA 247 : 121 CONTINUE 248 : 122 SEGDES MSOSTU 249 : 630 CONTINUE 250 : GO TO 599 251 : C ***************************** IMATRI ***************************** 252 : 513 CONTINUE 253 : GO TO 599 254 : C ***************************** MJONCT ***************************** 255 : 514 CONTINUE 256 : ICO1=KCOLA(1) 257 : ICO12=KCOLA(12) 258 : ICO2=KCOLA(2) 259 : DO 631 IEL=M1,M2 260 : MJONCT=ITLAC(IEL) 261 : IF (MJONCT.EQ.0) GO TO 631 262 : SEGACT MJONCT*MOD 263 : IVA=MJOPOI 264 : IF(MJOTYP.EQ.'CHOC')THEN 264 : IF(IVA.NE.0) CALL AJOUN(ICO2,IVA,ILISSE,1) 265 : ELSE 265 : IF(IVA.NE.0) CALL AJOUN(ICO1,IVA,ILISSE,1) 266 : ENDIF 266 : CCC CALL AJOUN(ICO1,IVA) 267 : IF(IIICHA.EQ.1)MJOPOI=IVA 268 : DO 632 I=1,ISTRJO(/1) 269 : IVA=ISTRJO(I) 269 : IF (IVA.NE.0)CALL AJOUN(ICO12,IVA,ILISSE,1) 270 : IF(IIICHA.EQ.1)ISTRJO(I)=IVA 271 : IVA=IPCHJO(I) 271 : IF (IVA.NE.0)CALL AJOUN(ICO2,IVA,ILISSE,1) 272 : IF(IIICHA.EQ.1)IPCHJO(I)=IVA 273 : IVA=IPOSJO(I) 273 : IF (IVA.NE.0) CALL AJOUN(ICO1,IVA,ILISSE,1) 274 : IF(IIICHA.EQ.1)IPOSJO(I)=IVA 275 : 632 CONTINUE 276 : SEGDES MJONCT 277 : 631 CONTINUE 278 : GO TO 599 279 : C ************************ MATTAC ********************************** 280 : 515 CONTINUE 281 : ICO1=KCOLA(1) 282 : ICO3=KCOLA(3) 283 : ICO14=KCOLA(14) 284 : DO 150 IEL=M1,M2 285 : MATTAC =ITLAC(IEL) 286 : IF (MATTAC.EQ.0) GO TO 150 287 : SEGACT MATTAC*MOD 288 : NN=LISATT(/1) 289 : DO 151 I=1,NN 290 : MSOUMA=LISATT(I) 291 : IF (MSOUMA.EQ.0) GO TO 151 292 : SEGACT MSOUMA*MOD 293 : M=IPMATK(/1) 294 : DO 152 J=1,M 295 : IVA=IPMATK(J) 295 : IF (IVA.NE.0)CALL AJOUN (ICO3,IVA,ILISSE,1) 296 : IF(IIICHA.EQ.1) IPMATK(J)=IVA 297 : 152 CONTINUE 298 : N=IATREL(/1) 299 : DO 153 J=1,N 300 : IVA=IATREL(J) 300 : IF (IVA.NE.0)CALL AJOUN (ICO14,IVA,ILISSE,1) 301 : IF(IIICHA.EQ.1) IATREL(J)=IVA 302 : 153 CONTINUE 303 : IF(IGEOCH.EQ.0) GO TO 156 304 : MGEOCH=IGEOCH 305 : SEGACT MGEOCH*MOD 306 : NI=INORCH(/1) 307 : DO 154 J=1,NI 308 : IVA=INORCH(J) 308 : IF (IVA.NE.0)CALL AJOUN (ICO1 ,IVA,ILISSE,1) 309 : IF(IIICHA.EQ.1) INORCH(J)=IVA 310 : 154 CONTINUE 311 : N1=IMAPRO(/1) 312 : DO 155 J=1,N1 313 : IVA=IMAPRO(J) 313 : IF (IVA.NE.0)CALL AJOUN (ICO1 ,IVA,ILISSE,1) 314 : IF(IIICHA.EQ.1) IMAPRO(J)=IVA 315 : 155 CONTINUE 316 : SEGDES MGEOCH 317 : 156 CONTINUE 318 : SEGDES MSOUMA 319 : 151 CONTINUE 320 : SEGDES MATTAC 321 : 150 CONTINUE 322 : GO TO 599 323 : C ************************ MMATRI ********************************** 324 : 516 CONTINUE 325 : ICO1=KCOLA(1) 326 : DO 633 IEL=M1,M2 327 : MMATRI=ITLAC(IEL) 328 : IF (MMATRI.EQ.0) GO TO 633 329 : SEGACT MMATRI*MOD 330 : IVA=IGEOMA 330 : CALL AJOUN(ICO1,IVA,ILISSE,1) 331 : IF(IIICHA.EQ.1)IGEOMA=IVA 332 : SEGDES MMATRI 333 : 633 CONTINUE 334 : GOTO 599 335 : C *************************MDEFOR*********************************** 336 : 517 CONTINUE 337 : ICO1=KCOLA(1) 338 : ICO2=KCOLA(2) 339 : ICO30=KCOLA(30) 340 : ICO38=KCOLA(38) 341 : ICO39=KCOLA(39) 342 : DO 634 IEL=M1,M2 343 : MDEFOR=ITLAC(IEL) 344 : IF (MDEFOR.EQ.0) GO TO 634 345 : SEGACT MDEFOR*MOD 346 : NDEF=IELDEF(/1) 347 : DO 635 I=1,NDEF 348 : IVA=IELDEF(I) 348 : CALL AJOUN(ICO1,IVA,ILISSE,1) 349 : IF(IIICHA.EQ.1)IELDEF(I)=IVA 350 : IVA=ICHDEF(I) 350 : CALL AJOUN(ICO2,IVA,ILISSE,1) 351 : IF(IIICHA.EQ.1)ICHDEF(I)=IVA 352 : IVA=MTVECT(I) 353 : IF (IVA.NE.0) THEN 353 : CALL AJOUN(ICO30,IVA,ILISSE,1) 354 : IF(IIICHA.EQ.1)MTVECT(I)=IVA 355 : ENDIF 356 : IVA=MDCHP(I) 357 : IF (IVA.NE.0) THEN 357 : CALL AJOUN(ICO2,IVA,ILISSE,1) 358 : IF(IIICHA.EQ.1)MDCHP(I)=IVA 359 : ENDIF 360 : IVA=MDCHEL(I) 361 : IF (IVA.NE.0) THEN 361 : CALL AJOUN(ICO39,IVA,ILISSE,1) 362 : IF(IIICHA.EQ.1)MDCHEL(I)=IVA 363 : ENDIF 364 : IVA=MDMODE(I) 365 : IF (IVA.NE.0) THEN 365 : CALL AJOUN(ICO38,IVA,ILISSE,1) 366 : IF(IIICHA.EQ.1)MDMODE(I)=IVA 367 : ENDIF 368 : 635 CONTINUE 369 : SEGDES MDEFOR 370 : 634 CONTINUE 371 : GOTO 599 372 : C ****************************MLREEL******************************* 373 : 518 CONTINUE 374 : GOTO 599 375 : C ****************************MLENTI****************************** 376 : 519 CONTINUE 377 : GOTO 599 378 : C ****************************MCHARG***************************** 379 : 520 CONTINUE 380 : ICO1=KCOLA(2) 381 : ICO2=KCOLA(18) 382 : ICO3=KCOLA(39) 383 : ICO4=KCOLA(10) 384 : ICO5=KCOLA(32) 385 : ICO6=KCOLA(1) 386 : DO 650 IEL=M1,M2 387 : MCHARG=ITLAC(IEL) 388 : IF (MCHARG.EQ.0) GO TO 650 389 : SEGACT MCHARG 390 : DO 651 I=1,KCHARG(/1) 391 : ICHARG=KCHARG(I) 392 : SEGACT ICHARG*MOD 393 : IF(CHATYP.EQ.'CHPOINT ') THEN 394 : IVA=ICHPO1 395 : IF(IVA.GT.0) THEN 395 : CALL AJOUN(ICO1,IVA,ILISSE,1) 396 : IF(IIICHA.EQ.1) ICHPO1=-IVA 397 : ENDIF 398 : IVA=ICHPO2 399 : IF(IVA.GT.0) THEN 399 : CALL AJOUN(ICO2,IVA,ILISSE,1) 400 : IF(IIICHA.EQ.1) ICHPO2=-IVA 401 : ENDIF 402 : IVA=ICHPO3 403 : IF(IVA.GT.0) THEN 403 : CALL AJOUN(ICO2,IVA,ILISSE,1) 404 : IF(IIICHA.EQ.1) ICHPO3=-IVA 405 : ENDIF 406 : ELSEIF(CHATYP.EQ.'MCHAML ') THEN 407 : IVA=ICHPO1 408 : IF(IVA.GT.0) THEN 408 : CALL AJOUN(ICO3,IVA,ILISSE,1) 409 : IF(IIICHA.EQ.1) ICHPO1=-IVA 410 : ENDIF 411 : IVA=ICHPO2 412 : IF(IVA.GT.0) THEN 412 : CALL AJOUN(ICO2,IVA,ILISSE,1) 413 : IF(IIICHA.EQ.1) ICHPO2=-IVA 414 : ENDIF 415 : IVA=ICHPO3 416 : IF(IVA.GT.0) THEN 416 : CALL AJOUN(ICO2,IVA,ILISSE,1) 417 : IF(IIICHA.EQ.1) ICHPO3=-IVA 418 : ENDIF 419 : ELSEIF(CHATYP.EQ.'TABLE ') THEN 420 : IVA=ICHPO1 421 : IF(IVA.GT.0) THEN 421 : CALL AJOUN(ICO4,IVA,ILISSE,1) 422 : IF(IIICHA.EQ.1) ICHPO1=-IVA 423 : ENDIF 424 : IVA=ICHPO2 425 : IF(IVA.GT.0) THEN 425 : CALL AJOUN(ICO4,IVA,ILISSE,1) 426 : IF(IIICHA.EQ.1) ICHPO2=-IVA 427 : ENDIF 428 : ENDIF 429 : IF(CHAMOB(I).EQ.'TRAN') THEN 430 : IVA=ICHPO4 431 : IF(IVA.GT.0) THEN 431 : CALL AJOUN(ICO5,IVA,ILISSE,3) 432 : IF(IIICHA.EQ.1) ICHPO4=-IVA 433 : ENDIF 434 : IVA=ICHPO6 435 : IF(IVA.GT.0) THEN 435 : CALL AJOUN(ICO2,IVA,ILISSE,1) 436 : IF(IIICHA.EQ.1) ICHPO6=-IVA 437 : ENDIF 438 : IVA=ICHPO7 439 : IF(IVA.GT.0) THEN 439 : CALL AJOUN(ICO2,IVA,ILISSE,1) 440 : IF(IIICHA.EQ.1) ICHPO7=-IVA 441 : ENDIF 442 : ELSEIF(CHAMOB(I).EQ.'ROTA') THEN 443 : IVA=ICHPO4 444 : IF(IVA.GT.0) THEN 444 : CALL AJOUN(ICO5,IVA,ILISSE,3) 445 : IF(IIICHA.EQ.1) ICHPO4=-IVA 446 : ENDIF 447 : IVA=ICHPO5 448 : IF(IVA.GT.0.AND.IDIM.GT.2) THEN 448 : CALL AJOUN(ICO5,IVA,ILISSE,3) 449 : IF(IIICHA.EQ.1) ICHPO5=-IVA 450 : ENDIF 451 : IVA=ICHPO6 452 : IF(IVA.GT.0) THEN 452 : CALL AJOUN(ICO2,IVA,ILISSE,1) 453 : IF(IIICHA.EQ.1) ICHPO6=-IVA 454 : ENDIF 455 : IVA=ICHPO7 456 : IF(IVA.GT.0) THEN 456 : CALL AJOUN(ICO2,IVA,ILISSE,1) 457 : IF(IIICHA.EQ.1) ICHPO7=-IVA 458 : ENDIF 459 : ELSEIF(CHAMOB(I).EQ.'TRAJ') THEN 460 : IVA=ICHPO4 461 : IF(IVA.GT.0) THEN 461 : CALL AJOUN(ICO1,IVA,ILISSE,1) 462 : IF(IIICHA.EQ.1) ICHPO4=-IVA 463 : ENDIF 464 : IVA=ICHPO5 465 : IF(IVA.GT.0) THEN 465 : CALL AJOUN(ICO6,IVA,ILISSE,1) 466 : IF(IIICHA.EQ.1) ICHPO5=-IVA 467 : ENDIF 468 : IVA=ICHPO6 469 : IF(IVA.GT.0) THEN 469 : CALL AJOUN(ICO2,IVA,ILISSE,1) 470 : IF(IIICHA.EQ.1) ICHPO6=-IVA 471 : ENDIF 472 : ENDIF 473 : SEGDES ICHARG 474 : 651 CONTINUE 475 : SEGDES MCHARG 476 : 650 CONTINUE 477 : GOTO 599 478 : C *************************** ***************************** 479 : 521 CONTINUE 480 : GOTO 599 481 : C ****************************MEVOLL****************************** 482 : 522 CONTINUE 483 : ICOR=KCOLA(18) 484 : ICOM=KCOLA(29) 485 : DO 660 IEL=M1,M2 486 : MEVOLL=ITLAC(IEL) 487 : IF (MEVOLL.EQ.0) GO TO 660 488 : SEGACT MEVOLL 489 : DO 661 I=1,IEVOLL(/1) 490 : KEVOLL=IEVOLL(I) 491 : SEGACT KEVOLL*MOD 492 : IVA=IPROGX 493 : ICO2=ICOR 494 : IF(IONIVE.GE.3) THEN 495 : IF(TYPX.EQ.'LISTMOTS') THEN 496 : ICO2=ICOM 497 : ELSEIF(TYPX.EQ.'LISTREEL')THEN 498 : ICO2=ICOR 499 : ENDIF 500 : ENDIF 501 : IF(IVA.GT.0) THEN 501 : CALL AJOUN(ICO2,IVA,ILISSE,1) 502 : IF(IIICHA.EQ.1) IPROGX=-IVA 503 : ENDIF 504 : IVA=IPROGY 505 : IF(IONIVE.GE.3) THEN 506 : IF(TYPY.EQ.'LISTMOTS') THEN 507 : ICO2=ICOM 508 : ELSEIF(TYPY.EQ.'LISTREEL')THEN 509 : ICO2=ICOR 510 : ENDIF 511 : ENDIF 512 : IF(IVA.GT.0) THEN 512 : CALL AJOUN(ICO2,IVA,ILISSE,1) 513 : IF(IIICHA.EQ.1) IPROGY=-IVA 514 : ENDIF 515 : SEGDES KEVOLL 516 : 661 CONTINUE 517 : SEGDES MEVOLL 518 : 660 CONTINUE 519 : GOTO 599 520 : C **********************SUPERELE************************************ 521 : 523 CONTINUE 522 : ICO1=KCOLA(1) 523 : ICO3=KCOLA(3) 524 : ICO2=KCOLA( 2) 525 : ICO16=KCOLA(16) 526 : DO 5230 IEL=M1,M2 527 : MSUPER=ITLAC(IEL) 528 : IF (MSUPER.EQ.0) GO TO 5230 529 : SEGACT MSUPER*MOD 530 : IVA=MRIGTO 530 : CALL AJOUN(ICO3,IVA,ILISSE,1) 531 : IF(IIICHA.EQ.1)MRIGTO=IVA 532 : IVA=MSUPEL 532 : CALL AJOUN(ICO1,IVA,ILISSE,1) 533 : IF(IIICHA.EQ.1)MSUPEL=IVA 534 : IVA=MSURAI 534 : CALL AJOUN(ICO3,IVA,ILISSE,1) 535 : IF(IIICHA.EQ.1)MSURAI=IVA 536 : IVA=MSUMAS 536 : IF(IVA.NE.0) CALL AJOUN(ICO3,IVA,ILISSE,1) 537 : IF(IIICHA.EQ.1)MSUMAS=IVA 538 : IVA=MCROUT 538 : CALL AJOUN(ICO16,IVA,ILISSE,1) 539 : IF(IIICHA.EQ.1)MCROUT=IVA 540 : c NBINMA=MSUPCH(/1) 541 : c DO 5231 I=1,NBINMA 542 : c IVA=MSUPCH(I) 542 : c CALL AJOUN(ICO2,IVA) 543 : c IF(IIICHA.EQ.1)MSUPCH(I)=IVA 544 : c 5231 CONTINUE 545 : SEGDES MSUPER 546 : 5230 CONTINUE 547 : GOTO 599 548 : C **********************LOGIQUE*********************************** 549 : 524 CONTINUE 550 : GOTO 599 551 : C **********************FLOTTANT********************************** 552 : 525 CONTINUE 553 : GOTO 599 554 : C ********************** ENTIER ********************************** 555 : 526 CONTINUE 556 : GOTO 599 557 : C ********************** MOT *********************************** 558 : 527 CONTINUE 559 : GOTO 599 560 : C ********************** TEXTE *********************************** 561 : 528 CONTINUE 562 : GOTO 599 563 : C ********************** LISTMOTS********************************* 564 : 529 CONTINUE 565 : GOTO 599 566 : C ********************** VECTEUR********************************** 567 : 530 CONTINUE 568 : ICO1=KCOLA(1) 569 : ICO2=KCOLA( 2) 570 : DO 5300 IEL=M1,M2 571 : MVECTE=ITLAC(IEL) 572 : IF (MVECTE.EQ.0) GO TO 5300 573 : SEGACT MVECTE*MOD 574 : NVEC=ICHPO(/1) 575 : DO 5301 I=1,NVEC 576 : * CE POINTEUR N'EST PAS ACTUELLEMENT REMPLI 577 : * IVA=IGEOV(I) 577 : * CALL AJOUN(ICO1,IVA) 578 : * IF(IIICHA.EQ.1)IGEOV(I)=IVA 579 : IVA=ICHPO(I) 579 : CALL AJOUN(ICO2,IVA,ILISSE,1) 580 : IF(IIICHA.EQ.1)ICHPO(I)=IVA 581 : 5301 CONTINUE 582 : SEGDES MVECTE 583 : 5300 CONTINUE 584 : GOTO 599 585 : C ********************** VECTDOUB********************************* 586 : 531 CONTINUE 587 : GOTO 599 588 : C ********************** POINT ********************************* 589 : 532 CONTINUE 590 : GOTO 599 591 : C ********************** CONFIG ********************************* 592 : 533 CONTINUE 593 : GOTO 599 594 : C *********************** LISTCHPO ****************************** 595 : 534 CONTINUE 596 : ICO2=KCOLA(2) 597 : DO 340 IEL=M1,M2 598 : MLCHPO =ITLAC(IEL) 599 : IF (MLCHPO.EQ.0) GO TO 340 600 : SEGACT MLCHPO*MOD 601 : N1=ICHPOI(/1) 602 : DO 341 I=1,N1 603 : IVA=ICHPOI(I) 603 : CALL AJOUN(ICO2,IVA,ILISSE,1) 604 : IF(IIICHA.EQ.1)ICHPOI(I)=IVA 605 : 341 CONTINUE 606 : SEGDES MLCHPO 607 : 340 CONTINUE 608 : GO TO 599 609 : C ************************** BASEM ******************************** 610 : 535 CONTINUE 611 : ICO12=KCOLA(12) 612 : ICO8=KCOLA(8 ) 613 : ICO15=KCOLA(15) 614 : DO 350 IEL=M1,M2 615 : MBASEM=ITLAC(IEL) 616 : IF (MBASEM.EQ.0) GO TO 350 617 : SEGACT MBASEM 618 : DO 351 I=1,LISBAS(/1) 619 : MSOBAS=LISBAS(I) 620 : SEGACT MSOBAS*MOD 621 : IVA=IBSTRM(1) 622 : IF(IVA.GT.0) THEN 622 : CALL AJOUN(ICO12,IVA,ILISSE,1) 623 : IF(IIICHA.EQ.1) IBSTRM(1)=-IVA 624 : ENDIF 625 : IVA=IBSTRM(2) 626 : IF(IVA.GT.0) THEN 626 : CALL AJOUN(ICO8,IVA,ILISSE,1) 627 : IF(IIICHA.EQ.1) IBSTRM(2)=-IVA 628 : ENDIF 629 : IVA=IBSTRM(3) 630 : IF (IVA.EQ.0) GOTO 352 631 : IF(IVA.GT.0) THEN 631 : CALL AJOUN(ICO8,IVA,ILISSE,1) 632 : IF(IIICHA.EQ.1) IBSTRM(3)=-IVA 633 : ENDIF 634 : 352 CONTINUE 635 : IVA=IBSTRM(4) 636 : IF (IVA.EQ.0) GOTO 353 637 : IF(IVA.GT.0) THEN 637 : CALL AJOUN(ICO15,IVA,ILISSE,1) 638 : IF(IIICHA.EQ.1) IBSTRM(4)=-IVA 639 : ENDIF 640 : 353 CONTINUE 641 : IVA=IBSTRM(5) 642 : IF (IVA.EQ.0) GOTO 354 643 : IF(IVA.GT.0) THEN 643 : CALL AJOUN(ICO8,IVA,ILISSE,1) 644 : IF(IIICHA.EQ.1) IBSTRM(5)=-IVA 645 : ENDIF 646 : 354 CONTINUE 647 : SEGDES MSOBAS 648 : 351 CONTINUE 649 : SEGDES MBASEM 650 : 350 CONTINUE 651 : GOTO 599 652 : C ************************* PROCEDURE **************************** 653 : 536 CONTINUE 654 : * ICO1=KCOLA(27) 655 : * DO 5360 IEL=M1,M2 656 : * IVA = ITLAC(IEL) 656 : * CALL AJOUN(ICO1,IVA) 657 : * IF(IIICHA.EQ.1) ITLAC (IEL) = IVA 658 : * 5360 CONTINUE 659 : C ************************ MMODEL ******************************** 660 : 538 CONTINUE 661 : ICO1 = KCOLA( 1) 662 : ICO10 = KCOLA(10) 663 : ICO40=kcola(40) 664 : DO 5380 IEL=M1,M2 665 : MMODEL = ITLAC(IEL) 666 : IF (MMODEL.EQ.0) GOTO 5380 667 : SEGACT,MMODEL 668 : DO 5385 I=1,KMODEL(/1) 669 : IMODEL = KMODEL(I) 670 : SEGACT,IMODEL*MOD 671 : IVA = IMAMOD 672 : IF(IVA.GT.0) THEN 672 : CALL AJOUN(ICO1,IVA,ILISSE,1) 673 : IF (IIICHA.EQ.1) IMAMOD =-IVA 674 : ENDIF 675 : C cas 'NAVIER_STOKES' : INFMOD(2) contient une table 676 : NFOR=FORMOD(/2) 677 : IF (NFOR.GT.0) THEN 678 : IF ((FORMOD(1).EQ.'NAVIER_STOKES').OR. 679 : * (FORMOD(1).EQ.'DARCY').OR. 680 : * (FORMOD(1).EQ.'EULER')) THEN 681 : MN3=INFMOD(/1) 682 : IF (MN3.GT.1) THEN 683 : IVA=INFMOD(2) 684 : IF(IVA.GT.0) THEN 684 : CALL AJOUN(ICO10,IVA,ILISSE,1) 685 : IF (IIICHA.EQ.1) INFMOD(2) =-IVA 686 : ENDIF 687 : ENDIF 688 : ENDIF 689 : ENDIF 690 : NM3=INFMOD(/1) 691 : DO IOU=3,NM3 692 : IVA=INFMOD(IOU) 693 : IF(IVA.gt.0) then 693 : CALL AJOUN(ICO40,IVA,ilisse,1) 694 : IF(IIICHA.EQ.1) INFMOD(IOU)=-IVA 695 : ENDIF 696 : ENDDO 697 : IF(tymode(/2). ne . 0) then 698 : do 5387 ihy=1,tymode(/2) 699 : ITYP1=tymode(ihy) 700 : IVA=IVAMOD(ihy) 701 : J=0 702 : if( iva.lt.0) go to 5387 702 : CALL TYPFIL (ITYP1,J) 703 : IF(J.LE.0.or.j.eq.32) GO TO 5387 704 : ICO2=KCOLA(J) 705 : NUMLIS=1 706 : IF(J.EQ.24) NUMLIS=6 707 : IF(J.EQ.25) NUMLIS=4 708 : IF(J.EQ.26) NUMLIS=2 709 : IF(J.EQ.27) NUMLIS=5 710 : IF(J.EQ.36) NUMLIS=7 710 : CALL AJOUN (ICO2,IVA,ILISSE,NUMLIS) 711 : IF(IIICHA.EQ.1)IVAMOD(ihy) =-IVA 712 : 5387 continue 713 : endif 714 : SEGDES,IMODEL 715 : 5385 CONTINUE 716 : SEGDES,MMODEL 717 : 5380 CONTINUE 718 : GOTO 599 719 : C ************************ MCHAML ******************************** 720 : 539 CONTINUE 720 : CALL EXCHAM(ICOLAC,ITLACC,M1,M2,IIICHA) 721 : GOTO 599 722 : C ************************ MINTE ******************************** 723 : 540 CONTINUE 724 : GOTO 599 725 : C ************************ NUAGE ******************************** 726 : 541 CONTINUE 727 : DO 810 IEL=M1,M2 728 : MNUAGE=ITLAC(IEL) 729 : IF (MNUAGE.EQ.0) GO TO 810 730 : SEGACT MNUAGE 731 : L6=NUAPOI(/1) 732 : IF (L6.EQ.0) GO TO 813 733 : DO 811 K=1,L6 734 : ITYP1=NUATYP(K) 735 : ISIN=NUAPOI(K) 736 : J=0 737 : IF(ITYP1.EQ.'FLOTTANT'.OR.ITYP1.EQ.'ENTIER '.OR. 738 : $ ITYP1.EQ.'MOT '.OR.ITYP1.EQ.'LOGIQUE ') GO TO 811 738 : CALL TYPFIL (ITYP1,J) 739 : IF(J.LE.0) GO TO 811 740 : ICO2=KCOLA(J) 741 : NUMLIS=1 742 : IF(J.EQ.32) NUMLIS=3 743 : IF(J.EQ.36) NUMLIS=7 744 : NUAVIN=ISIN 745 : SEGACT NUAVIN*MOD 746 : DO 816 LL =1,NUAINT(/1) 747 : IVA=NUAINT(LL) 747 : CALL AJOUN (ICO2,IVA,ILISSE,NUMLIS) 748 : IF(IIICHA.EQ.1) NUAINT(LL)=IVA 749 : 816 CONTINUE 750 : SEGDES NUAVIN 751 : 811 CONTINUE 752 : 813 SEGDES MNUAGE 753 : 810 CONTINUE 754 : GO TO 599 755 : C **************************** MATRAK ****************************** 756 : 542 CONTINUE 757 : C ICO1=KCOLA(1) 757 : CALL EXAMTK (ICOLAC,ITLACC,M1,M2,IIICHA) 758 : GO TO 599 759 : C **************************** MATRIK ****************************** 760 : 543 CONTINUE 761 : C ICO1=KCOLA(1) 761 : CALL EXANTK (ICOLAC,ITLACC,M1,M2,IIICHA) 762 : GO TO 599 763 : C ****************************** METHODE *************************** 764 : 545 CONTINUE 765 : ICO1=KCOLA(27) 766 : DO 5450 IEL=M1,M2 767 : IVA = ITLAC(IEL) 767 : CALL AJOUN(ICO1,IVA,ILISSE,5) 768 : IF(IIICHA.EQ.1) ITLAC (IEL) = IVA 769 : 5450 CONTINUE 770 : GO TO 599 771 : C ****************************** ESCLAVE *************************** 772 : 546 CONTINUE 773 : DO 5460 IEL=M1,M2 774 : mesres=itlac(iel) 775 : segact mesres 776 : nesres=iesres 777 : segact nesres 778 : if (.not.loremp) goto 5460 779 : ityp1=esrety 780 : k=0 780 : call typfil(ityp1,k) 781 : if (k.le.0) goto 5460 782 : if (k.eq.24) goto 5460 783 : if (k.eq.25) goto 5460 784 : if (k.eq.26) goto 5460 785 : if (k.eq.27) goto 5460 786 : ico1=kcola(k) 787 : iva=esreva 788 : NUMLIS=1 789 : IF(k.EQ.32) NUMLIS=3 790 : IF(k.EQ.36) NUMLIS=7 791 : * write (6,*) ' expill esclave renvoie sur ',ityp1,iva 791 : call ajoun(ico1,iva,ilisse,numlis) 792 : segdes nesres 793 : segdes mesres 794 : 5460 continue 795 : C JYY print*, ' passage ESCLAVE dans expil' 796 : GO TO 599 797 : 798 : 599 CONTINUE 799 : SEGDES ICOLAC 800 : RETURN 801 : END 802 : 803 : 804 : 805 : 806 :
© Cast3M 2003 - All rights reserved.
Disclaimer