1 : C NLOVEP SOURCE CHAT 11/03/16 21:28:36 6902 2 : SUBROUTINE NLOVEP(IPCHCO,IPCHI,IPLMOT, IPCHO,NLOC1, IRET) 3 : C_______________________________________________________________________ 4 : C 5 : C VERIFICATION ET PREPARATION DU TRAVAIL SUR LA MOYENNE 6 : C NON LOCALE 7 : C 8 : C 9 : C Entrees: 10 : C -------- 11 : C IPCHCO Pointeur sur un MCHAML de Connectivite 12 : C (ss-type CONNECTIVITE NON LOCAL) 13 : C IPCHI Pointeur sur un MCHAML de ss-type indifferentt 14 : C IPLMOT Pointeur sur un LISTMOTS de noms de composante 15 : C 16 : C Sorties: 17 : C -------- 18 : C IRET=1 ou 0 si OK ou non 19 : C IPCHO pointeur sur le champ moyenne 20 : C NLOC1 pointeur sur l'arbre de calcul 21 : C 22 : C Appele par: NLOCA1 23 : C ----------- 24 : C 25 : C Appel a: 26 : C -------- 27 : C 28 : C DOUBLO : detection de doublon 29 : C LOADPO : lecture d'un point (pointeur --> x(3)) 30 : C ELQUOI, IDENT, KOMCHA, COPIE8, DTCHEL 31 : C 32 : C P.PEGON 9/11/92 33 : C_______________________________________________________________________ 34 : C 35 : IMPLICIT INTEGER(I-N) 36 : IMPLICIT REAL*8(A-H,O-Z) 37 : LOGICAL LMASS,LCARA 38 : * 39 : -INC CCOPTIO 40 : -INC SMCHAML 41 : -INC SMELEME 42 : -INC SMMODEL 43 : -INC SMLMOTS 44 : -INC SMINTE 45 : CHARACTER*(LCONMO) CONM 46 : * 47 : SEGMENT INFO 48 : INTEGER INFELL(JG) 49 : ENDSEGMENT 50 : * 51 : SEGMENT NOTYPE 52 : CHARACTER*16 TYPE (NBTYPE) 53 : ENDSEGMENT 54 : * 55 : SEGMENT MPTVAL 56 : INTEGER IPOS(NS) ,NSOF(NS) 57 : INTEGER IVAL(NCOSOU) 58 : CHARACTER*16 TYVAL(NCOSOU) 59 : ENDSEGMENT 60 : * 61 : SEGMENT WRK0 62 : INTEGER IRAGNT(NSOUCO),IDUMMM(2,NSOUCO),IDUPLI(NSOUCO) 63 : END SEGMENT 64 : * 65 : SEGMENT NLOC1 66 : INTEGER ILOC2 (NZONEF) 67 : END SEGMENT 68 : * 69 : SEGMENT NLOC2 70 : INTEGER MPCHAM (NDOUBL) 71 : INTEGER ILOC4 (NDOUBL) 72 : INTEGER MODLAC,MAILEF,MINTEF 73 : INTEGER MAILAC (NSZACC) 74 : INTEGER MINTAC (NSZACC) 75 : INTEGER ILOC3 (NSZACC) 76 : INTEGER ILOC3I,ILOC3O 77 : INTEGER MELCAR 78 : END SEGMENT 79 : * 80 : SEGMENT NLOC3 81 : INTEGER MELVAC (NCOMP) 82 : END SEGMENT 83 : * 84 : SEGMENT NLOC4 85 : INTEGER JCLE 86 : REAL*8 PT1(3),PT2(3),DISP 87 : INTEGER MELPNI,MELPLI 88 : END SEGMENT 89 : * 90 : PARAMETER ( NINF=3 ) 91 : INTEGER INFOS(NINF) 92 : C 93 : PARAMETER(NCLE=5) 94 : CHARACTER*4 MCLE(NCLE) 95 : DATA MCLE/'NORM','TRAN','POIN','DROI','PLAN'/ 96 : C 97 : C 98 : C ACTIVATION DU CHAMP DE CONNECTIVITE 99 : C 100 : MCHELM=IPCHCO 101 : SEGACT,MCHELM 102 : NSOUCO=ICHAML(/1) 103 : SEGINI,WRK0 104 : C 105 : C ACTIVATION DES SOUS-ZONES (MCHAML) 106 : C 107 : DO ISOUCO=1,NSOUCO 108 : MCHAML=ICHAML(ISOUCO) 109 : SEGACT,MCHAML 110 : END DO 111 : C 112 : C ON ETABLIT LA LISTE DES MAILLAGES 113 : C ACTIVATION DU SECOND MELVAL DU CHAMP DE CONNECTIVITE 114 : C QUI EST LE MODELE ASSOCIE AU SS-ZONES ACCESSIBLE 115 : C ON ETABLIT LA LISTE DE CES MODELES 116 : C ON DESACTIVE LE MELVAL 117 : C 118 : DO ISOUCO=1,NSOUCO 119 : IDUMMM(1,ISOUCO)=IMACHE(ISOUCO) 120 : MCHAML=ICHAML(ISOUCO) 121 : IRAGNT(ISOUCO)=ISOUCO 122 : NCOMP=IELVAL(/1) 123 : IF(NCOMP.LT.4.OR.NCOMP.GT.6)THEN 123 : CALL ERREUR(734) 124 : SEGSUP,WRK0 125 : GOTO 9999 126 : ENDIF 127 : IF(NOMCHE(2).NE.'PMOD')THEN 128 : MOTERR(1:4)='PMOD' 128 : CALL ERREUR(734) 129 : SEGSUP,WRK0 130 : GOTO 9999 131 : ENDIF 132 : IF(TYPCHE(2).NE.'POINTEURMMODEL')THEN 133 : MOTERR(1:4)='PMOD' 134 : MOTERR(5:12)='MODEL ' 134 : CALL ERREUR(736) 135 : SEGSUP,WRK0 136 : GOTO 9999 137 : ENDIF 138 : MELVAL=IELVAL(2) 139 : SEGACT,MELVAL 140 : IDUMMM(2,ISOUCO)=IELCHE(1,1) 141 : SEGDES,MELVAL 142 : END DO 143 : C 144 : C ON ORDONNE LE TABLEAU IDUMMM EN GARDANT LA TRACE DES PERMUTATIONS 145 : C DANS IRAGNT 146 : C ON DETECTE LES DOUBLONS: 147 : C IDUPLI INDIQUE LE NOMBRE DE DOUBLON PAR ZONE EFFECTIVE 148 : C IDUMMM POINTE SUR LE MAILLAGE/MODELE DE LA ZONE EFFECTIVE 149 : C 149 : CALL DOUBLO(IDUMMM,IRAGNT,2,NSOUCO, NZONEF,IDUPLI) 150 : C 151 : C ON REMPLIT NLOC1 ET PARTIELLEMENT NLOC2 152 : C ON ACTIVE LES MMODEL 153 : C ON ACTIVE LES MAILLAGES EFFECTIFS 154 : C ON SUPRIME WRK0 155 : C 156 : J=0 157 : NSZACC=0 158 : SEGINI,NLOC1 159 : DO ISOUCF=1,NZONEF 160 : NDOUBL=IDUPLI(ISOUCF) 161 : SEGINI,NLOC2 162 : ILOC2(ISOUCF)=NLOC2 163 : MMODEL=IDUMMM(2,ISOUCF) 164 : MODLAC=MMODEL 165 : SEGACT,MMODEL 166 : DO IDOUBL=1,NDOUBL 167 : J=J+1 168 : MPCHAM(IDOUBL)=IRAGNT(J) 169 : ILOC4 (IDOUBL)=0 170 : END DO 171 : MELEME=IDUMMM(1,ISOUCF) 172 : MAILEF=MELEME 173 : SEGACT,MELEME 174 : END DO 175 : SEGSUP,WRK0 176 : C 177 : C ON ACTIVES LES IMODEL ET ON CONTINUE DE REMPLIR NLOC2 178 : C (MAILLAGE ET MINTE) 179 : C IL FAUT ACTIVER LE MINTE !!!! 180 : C ON VERIFIE AU PASSAGE QUE LA FORMULATION DU MODELE EST 181 : C BIEN MASSIVE ... 182 : C ... ET QUE SOIT LES LONGUEURS CARACTERISTIQUES SUR UNE MEME 183 : C SOUS-ZONE EFFECTIVE SONT IDENTIQUE OU QUE LE MELVAL DE LONGUEUR 184 : C CARACTERISTIQUE EST LE MEME. POUR CELA ON ACTIVE 185 : C ET ON DESACTIVE LE PREMIER MELVAL DU CHAMP DE CONNECTIVITE 186 : C 187 : C 188 : LMASS=.TRUE. 189 : LCARA=.TRUE. 190 : DO ISOUCF=1,NZONEF 191 : C 192 : NLOC2=ILOC2(ISOUCF) 193 : ILOC3I=0 194 : ILOC3O=0 195 : MMODEL=MODLAC 196 : NSZACC=KMODEL(/1) 197 : * PP 15/6/93 198 : NDOUBL=MPCHAM(/1) 199 : SEGADJ,NLOC2 200 : DO ISZACC=1,NSZACC 201 : IMODEL=KMODEL(ISZACC) 202 : SEGACT,IMODEL 203 : MELE=NEFMOD 204 : MFR=NUMMFR (MELE) 205 : IF (MFR .NE. 1) THEN 205 : CALL ERREUR(737) 206 : LMASS=.FALSE. 207 : ENDIF 208 : MAILAC(ISZACC)=IMAMOD 209 : if(infmod(/1).lt.7) then 209 : CALL ELQUOI (MELE,0,5,INFO,IMODEL) 210 : MINTAC(ISZACC)=INFELL(11) 211 : MINTE=INFELL(11) 212 : SEGSUP,INFO 213 : else 214 : minte=infmod(7) 215 : MINTAC(ISZACC)=minte 216 : endif 217 : SEGACT,MINTE 218 : 219 : ILOC3 (ISZACC)=0 220 : * 221 : END DO 222 : C 223 : ICHAMC=MPCHAM(1) 224 : MCHAML=ICHAML(ICHAMC) 225 : IF(NOMCHE(1).NE.'NLAR')THEN 226 : MOTERR(1:4)='NLAR' 226 : CALL ERREUR(734) 227 : LCARA=.FALSE. 228 : ELSEIF(TYPCHE(1).NE.'REAL*8')THEN 229 : MOTERR(1:4)='NLAR' 230 : MOTERR(5:12)='FLOTTANT' 230 : CALL ERREUR(736) 231 : LCARA=.FALSE. 232 : ENDIF 233 : IF(LCARA)THEN 234 : MELVAL=IELVAL(1) 235 : SEGACT,MELVAL 236 : MELCAR=MELVAL 237 : IF(VELCHE(/1).EQ.1.AND.VELCHE(/2).EQ.1)THEN 238 : XLCAR=VELCHE(1,1) 239 : ELSE 240 : XLCAR=0.D0 241 : ENDIF 242 : SEGDES,MELVAL 243 : NDOUBL=MPCHAM(/1) 244 : C 245 : DO IDOUBL=1,NDOUBL 246 : ICHAMC=MPCHAM(IDOUBL) 247 : MCHAML=ICHAML(ICHAMC) 248 : IF(NOMCHE(1).NE.'NLAR')THEN 249 : MOTERR(1:4)='NLAR' 249 : CALL ERREUR(734) 250 : LCARA=.FALSE. 251 : ELSEIF(TYPCHE(1).NE.'REAL*8')THEN 252 : MOTERR(1:4)='NLAR' 253 : MOTERR(5:12)='FLOTTANT' 253 : CALL ERREUR(736) 254 : LCARA=.FALSE. 255 : ENDIF 256 : IF(LCARA)THEN 257 : MELVAL=IELVAL(1) 258 : IF(XLCAR.EQ.0.D0)THEN 259 : MELVA1=MELCAR 260 : SEGACT,MELVAL,MELVA1 261 : IF(MELVA1.VELCHE(/1).EQ.VELCHE(/1).AND. 262 : > MELVA1.VELCHE(/2).EQ.VELCHE(/2))THEN 263 : XDIFNL=0.D0 264 : XMAXNL=0.D0 265 : DO IB=1,VELCHE(/2) 266 : DO IG=1,VELCHE(/1) 267 : XDIFNL=XDIFNL+ 268 : > ABS(MELVA1.VELCHE(IG,IB)-VELCHE(IG,IB)) 269 : XMAXNL=MAX(XMAXNL,MELVA1.VELCHE(IG,IB), 270 : > VELCHE(IG,IB)) 271 : ENDDO 272 : ENDDO 273 : ELSE 274 : XDIFNL=1 275 : XMAXNL=1 276 : ENDIF 277 : IF(XMAXNL.EQ.0.D0.OR.XDIFNL.GT.XMAXNL*1.D-10)THEN 277 : CALL ERREUR(739) 278 : LCARA=.FALSE. 279 : ENDIF 280 : SEGDES,MELVAL,MELVA1 281 : C 282 : ELSE 283 : SEGACT,MELVAL 284 : IF(XLCAR.NE.VELCHE(1,1))THEN 284 : CALL ERREUR(738) 285 : LCARA=.FALSE. 286 : ENDIF 287 : SEGDES,MELVAL 288 : ENDIF 289 : ENDIF 290 : END DO 291 : ENDIF 292 : END DO 293 : IF(.NOT.LMASS) GOTO 9998 294 : IF(.NOT.LCARA) GOTO 9998 295 : C 296 : C ON CREE UN HEADER DE MCHAML DE CONNECTIVITE SUR LES ZONES 297 : C EFFECTIVES 298 : C ON CREE UN HEADER DE MODELE SUR LES ZONES EFFECTIVES QUI 299 : C REPREND LE IMODEL ASSOCIE A LA ZONE COURANTE 300 : C 301 : L1=TITCHE(/1) 302 : N1=NZONEF 303 : N3=INFCHE(/2) 304 : SEGINI,MCHEL1 305 : MCHEL1.TITCHE=TITCHE 306 : MCHEL1.IFOCHE=IFOCHE 307 : SEGINI,MMODE1 308 : DO ISOUCF=1,NZONEF 309 : NLOC2=ILOC2(ISOUCF) 310 : ICHAMC=MPCHAM(1) 311 : MCHAML=ICHAML(ICHAMC) 312 : IMACHA=IMACHE(ICHAMC) 313 : MCHEL1.IMACHE(ISOUCF)=IMACHA 314 : MCHEL1.ICHAML(ISOUCF)=0 315 : MMODEL=MODLAC 316 : NSZACC=KMODEL(/1) 317 : DO ISZACC=1,NSZACC 318 : IMODEL=KMODEL(ISZACC) 319 : IF (IMAMOD.EQ.IMACHA)GOTO 1 320 : END DO 320 : CALL ERREUR(740) 321 : GOTO 9997 322 : 1 MINTEF=MINTAC(ISZACC) 323 : MMODE1.KMODEL(ISOUCF)=IMODEL 324 : MCHEL1.CONCHE(ISOUCF)=CONMOD 325 : DO J=1,N3 326 : MCHEL1.INFCHE(ISOUCF,J)=INFCHE(ICHAMC,J) 327 : END DO 328 : END DO 329 : C 330 : C PREPARATION NOMID'S POUR LE CHAMP A MOYENNER 331 : C 332 : MLMOTS=IPLMOT 333 : SEGACT,MLMOTS 334 : NBROBL=MOTS(/2) 335 : NBRFAC=0 336 : SEGINI,NOMID 337 : MOMOTS=NOMID 338 : DO IE1=1,NBROBL 339 : LESOBL(IE1)=MOTS(IE1) 340 : END DO 341 : SEGDES,MLMOTS 342 : NMOTS=NBROBL+NBRFAC 343 : C 344 : C PREPARATION NOTYPE'S POUR LE CHAMP A MOYENNER 345 : C 346 : NBTYPE=1 347 : SEGINI,NOTYPE 348 : TYPE(1)='REAL*8' 349 : C 350 : C ON VERIFIE LA COMPATIBILITE DES SUPPORTS GEOMETRIQUES ET 351 : C QUE CES COMPOSANTES EXISTENT SUR TOUTES LES 352 : C ZONE EFFECTIVES 353 : C 354 : MMODEL=MMODE1 355 : DO ISOUCF=1,NZONEF 356 : NLOC2=ILOC2(ISOUCF) 357 : IMODEL=KMODEL(ISOUCF) 358 : CONM=CONMOD 359 : IPMAIL=IMAMOD 359 : CALL IDENT(IPMAIL,CONM,IPCHI,MCHEL1,INFOS,IRTD) 360 : IF(IRTD .NE. 1)THEN 360 : CALL ERREUR(741) 361 : GOTO 9996 362 : ENDIF 362 : CALL KOMCHA(IPCHI,IPMAIL,CONM,MOMOTS,NOTYPE,1, 363 : > INFOS,3,IVAMOT) 364 : IF (IERR .NE. 0) THEN 364 : CALL ERREUR(742) 365 : GOTO 9996 366 : ENDIF 367 : MPTVAL=IVAMOT 368 : NCOMP=IVAL(/1) 369 : SEGINI,NLOC3 370 : ILOC3I=NLOC3 371 : DO ICOMP=1,NCOMP 372 : MELVAC(ICOMP)=IVAL(ICOMP) 373 : END DO 374 : SEGSUP,MPTVAL 375 : END DO 376 : C 377 : C ON VERIFIE QUE LES MINTE EXISTENT ET QU'ILS SONT AUX PT DE GAUSS 378 : C POUR LE CHAMP A MOYENNER 379 : C 380 : MCHEL2=IPCHI 381 : SEGACT,MCHEL2 382 : DO ISOUCF=1,NZONEF 383 : IMODEL=KMODEL(ISOUCF) 384 : CONM=CONMOD 385 : IPMAIL=IMAMOD 386 : DO J=1,MCHEL2.CONCHE(/2) 387 : IF((MCHEL2.CONCHE(J).EQ.CONM) 388 : > .AND.(MCHEL2.IMACHE(J).EQ.IPMAIL))THEN 389 : IF((MCHEL2.INFCHE(J,4).EQ.0) 390 : > .OR.(MCHEL2.INFCHE(J,6).NE.5))THEN 390 : CALL ERREUR(745) 391 : GOTO 9996 392 : ENDIF 393 : ENDIF 394 : END DO 395 : END DO 396 : SEGDES,MCHEL2 397 : C 398 : C ON CONTINUE LA VERIFICATION DU MCHELM DES 399 : C CONNECTIVITES 400 : C ON CONTINUE DE REMPLIR NLOC2 ET ON CREE ET REMPLIT LES NLOC4 401 : C PAR OUVERTURE/FERMETURE DE MELVAL 402 : C 403 : DO ISOUCF=1,NZONEF 404 : NLOC2=ILOC2(ISOUCF) 405 : NDOUBL=MPCHAM(/1) 406 : DO IDOUBL=1,NDOUBL 407 : ICHAMC=MPCHAM(IDOUBL) 408 : CONM=CONCHE(ICHAMC) 409 : SEGINI,NLOC4 410 : ILOC4(IDOUBL)=NLOC4 411 : DO ICLE=1,NCLE 412 : IF(CONM(13:16) .EQ. MCLE(ICLE))GOTO 2 413 : END DO 413 : CALL ERREUR(746) 414 : GOTO 9996 415 : 2 JCLE=ICLE 416 : MCHAML=ICHAML(ICHAMC) 417 : NCOMP=IELVAL(/1) 418 : GOTO (11,12,13,14,15),ICLE 419 : C NORM 420 : 11 CONTINUE 421 : IF(NCOMP.NE.4)GOTO 16 422 : GOTO 17 423 : C TRAN 424 : 12 CONTINUE 425 : IF(NCOMP.NE.5)GOTO 16 426 : IF (NOMCHE(5).NE.'POT1')THEN 427 : MOTERR(1:4)='POT1' 428 : MOTERR(13:16)='TRAN' 428 : CALL ERREUR(743) 429 : GOTO 9996 430 : ENDIF 431 : IF (TYPCHE(5).NE.'POINTEURPOINT ')THEN 432 : MOTERR(1:4)='POT1' 433 : MOTERR(5:12)='POINT ' 434 : MOTERR(13:16)='TRAN' 434 : CALL ERREUR(744) 435 : GOTO 9996 436 : ENDIF 437 : MELVAL=IELVAL(5) 438 : SEGACT,MELVAL 439 : JPT1=IELCHE(1,1) 440 : SEGDES,MELVAL 440 : CALL LOADPO(JPT1,PT1) 441 : GOTO 17 442 : C POIN 443 : 13 CONTINUE 444 : IF(NCOMP.NE.5)GOTO 16 445 : IF (NOMCHE(5).NE.'POT1')THEN 446 : MOTERR(1:4)='POT1' 447 : MOTERR(13:16)='POIN' 447 : CALL ERREUR(743) 448 : GOTO 9996 449 : ENDIF 450 : IF (TYPCHE(5).NE.'POINTEURPOINT ')THEN 451 : MOTERR(1:4)='POT1' 452 : MOTERR(5:12)='POINT ' 453 : MOTERR(13:16)='POIN' 453 : CALL ERREUR(744) 454 : GOTO 9996 455 : ENDIF 456 : MELVAL=IELVAL(5) 457 : SEGACT,MELVAL 458 : JPT1=IELCHE(1,1) 459 : SEGDES,MELVAL 459 : CALL LOADPO(JPT1,PT1) 460 : GOTO 17 461 : C DROI 462 : 14 CONTINUE 463 : IF(NCOMP.NE.6)GOTO 16 464 : IF (NOMCHE(5).NE.'POT1')THEN 465 : MOTERR(1:4)='POT1' 466 : MOTERR(13:16)='DROI' 466 : CALL ERREUR(743) 467 : GOTO 9996 468 : ENDIF 469 : IF (TYPCHE(5).NE.'POINTEURPOINT ')THEN 470 : MOTERR(1:4)='POT1' 471 : MOTERR(5:12)='POINT ' 472 : MOTERR(13:16)='DROI' 472 : CALL ERREUR(744) 473 : GOTO 9996 474 : ENDIF 475 : MELVAL=IELVAL(5) 476 : SEGACT,MELVAL 477 : JPT1=IELCHE(1,1) 478 : SEGDES,MELVAL 478 : CALL LOADPO(JPT1,PT1) 479 : IF (NOMCHE(6).NE.'POT2')THEN 480 : MOTERR(1:4)='POT2' 481 : MOTERR(13:16)='DROI' 481 : CALL ERREUR(743) 482 : GOTO 9996 483 : ENDIF 484 : IF (TYPCHE(6).NE.'POINTEURPOINT ')THEN 485 : MOTERR(1:4)='POT2' 486 : MOTERR(5:12)='POINT ' 487 : MOTERR(13:16)='DROI' 487 : CALL ERREUR(744) 488 : GOTO 9996 489 : ENDIF 490 : MELVAL=IELVAL(6) 491 : SEGACT,MELVAL 492 : JPT2=IELCHE(1,1) 493 : SEGDES,MELVAL 493 : CALL LOADPO(JPT2,PT2) 494 : GOTO 17 495 : C PLAN 496 : 15 CONTINUE 497 : IF(NCOMP.NE.6)GOTO 16 498 : IF (NOMCHE(5).NE.'POT1')THEN 499 : MOTERR(1:4)='POT1' 500 : MOTERR(13:16)='PLAN' 500 : CALL ERREUR(743) 501 : GOTO 9996 502 : ENDIF 503 : IF (TYPCHE(5).NE.'POINTEURPOINT ')THEN 504 : MOTERR(1:4)='POT1' 505 : MOTERR(5:12)='POINT ' 506 : MOTERR(13:16)='PLAN' 506 : CALL ERREUR(744) 507 : GOTO 9996 508 : ENDIF 509 : MELVAL=IELVAL(5) 510 : SEGACT,MELVAL 511 : JPT1=IELCHE(1,1) 512 : SEGDES,MELVAL 512 : CALL LOADPO(JPT1,PT1) 513 : IF (NOMCHE(6).NE.'DISP')THEN 514 : MOTERR(1:4)='DISP' 515 : MOTERR(13:16)='PLAN' 515 : CALL ERREUR(743) 516 : GOTO 9996 517 : ENDIF 518 : IF (TYPCHE(6).NE.'REAL*8')THEN 519 : MOTERR(1:4)='DISP' 520 : MOTERR(5:12)='FLOTTANT' 521 : MOTERR(13:16)='PLAN' 521 : CALL ERREUR(744) 522 : GOTO 9996 523 : ENDIF 524 : MELVAL=IELVAL(6) 525 : SEGACT,MELVAL 526 : DISP=VELCHE(1,1) 527 : SEGDES,MELVAL 528 : GOTO 17 529 : C 530 : 16 CONTINUE 530 : CALL ERREUR(734) 531 : GOTO 9996 532 : C 533 : 17 CONTINUE 534 : IF (NOMCHE(3).NE.'NPNI')THEN 535 : MOTERR(1:4)='NPNI' 535 : CALL ERREUR(734) 536 : GOTO 9996 537 : ENDIF 538 : IF (TYPCHE(3).NE.'POINTEURLISTENTI')THEN 539 : MOTERR(1:4)='NPNI' 540 : MOTERR(5:12)='LISTENTI' 540 : CALL ERREUR(736) 541 : GOTO 9996 542 : ENDIF 543 : MELPNI=IELVAL(3) 544 : IF (NOMCHE(4).NE.'NPLI')THEN 545 : MOTERR(1:4)='NPLI' 545 : CALL ERREUR(734) 546 : GOTO 9996 547 : ENDIF 548 : IF (TYPCHE(4).NE.'POINTEURLISTENTI')THEN 549 : MOTERR(1:4)='NPLI' 550 : MOTERR(5:12)='LISTENTI' 550 : CALL ERREUR(736) 551 : GOTO 9996 552 : ENDIF 553 : MELPLI=IELVAL(4) 554 : END DO 555 : END DO 556 : C 557 : C ON VERIFIE QUE SUR CHAQUE SS-ZONE EFFECTIVE ON A UN ICLE=1 ET 558 : C UN SEUL 559 : C 560 : DO ISOUCF=1,NZONEF 561 : NLOC2=ILOC2(ISOUCF) 562 : NDOUBL=ILOC4(/1) 563 : KCLE=0 564 : DO IDOUBL=1,NDOUBL 565 : NLOC4=ILOC4(IDOUBL) 566 : IF(JCLE.EQ.1)KCLE=KCLE+1 567 : END DO 568 : IF(KCLE.EQ.0)THEN 568 : CALL ERREUR(747) 569 : GOTO 9996 570 : ENDIF 571 : IF(KCLE.GT.1)THEN 571 : CALL ERREUR(748) 572 : GOTO 9996 573 : ENDIF 574 : END DO 575 : C 576 : C ON COPIE LE CHAMELEM A MOYENNER 577 : C 577 : CALL COPIE8 (IPCHI,IPCHO) 578 : C 579 : C ON FINIT DE REMPLIR NLOC2 ET ON CREE ET REMPLIT LES NLOC3 580 : C LES MELVAL RESULTATS DE MOYENNE CONSTANT SONT SEGADJUSTES 581 : C 582 : DO ISOUCF=1,NZONEF 583 : NLOC2=ILOC2(ISOUCF) 584 : C 585 : MMODEL=MODLAC 586 : NSZACC=KMODEL(/1) 587 : DO ISZACC=1,NSZACC 588 : IMODEL=KMODEL(ISZACC) 589 : CONM=CONMOD 590 : IPMAIL=IMAMOD 590 : CALL IDENT(IPMAIL,CONM,IPCHI,MCHEL1,INFOS,IRTD) 590 : CALL KOMCHA(IPCHI,IPMAIL,CONM,MOMOTS,NOTYPE,1, 591 : > INFOS,3,IVAMOT) 592 : MPTVAL=IVAMOT 593 : NCOMP=IVAL(/1) 594 : SEGINI,NLOC3 595 : ILOC3(ISZACC)=NLOC3 596 : DO ICOMP=1,NCOMP 597 : MELVAC(ICOMP)=IVAL(ICOMP) 598 : END DO 599 : SEGSUP,MPTVAL 600 : END DO 601 : C 602 : IMODEL=MMODE1.KMODEL(ISOUCF) 603 : CONM=CONMOD 604 : IPMAIL=IMAMOD 604 : CALL IDENT(IPMAIL,CONM,IPCHO,MCHEL1,INFOS,IRTD) 604 : CALL KOMCHA(IPCHO,IPMAIL,CONM,MOMOTS,NOTYPE,1, 605 : > INFOS,3,IVAMOT) 606 : MPTVAL=IVAMOT 607 : NCOMP=IVAL(/1) 608 : SEGINI,NLOC3 609 : ILOC3O=NLOC3 610 : DO ICOMP=1,NCOMP 611 : MELVAC(ICOMP)=IVAL(ICOMP) 612 : END DO 613 : SEGSUP,MPTVAL 614 : C 615 : IPT1=IPMAIL 616 : N1EL=IPT1.NUM(/2) 617 : MINTE=MINTEF 618 : N1PTEL=POIGAU(/1) 619 : DO ICOMP=1,NCOMP 620 : MELVAL=MELVAC(ICOMP) 621 : C SI LE CHAMP N"EST PAS DANS SES BORNES ... 622 : IF((VELCHE(/1).NE.N1PTEL).OR.(VELCHE(/2).NE.N1EL))THEN 623 : C ... IL EST CONSTANT 624 : IF((VELCHE(/1).EQ.1).AND.(VELCHE(/2).EQ.1))THEN 625 : * PP 15/6/93 626 : N2PTEL=IELCHE(/1) 627 : N2EL=IELCHE(/2) 628 : SEGADJ,MELVAL 629 : XELCHE=VELCHE(1,1) 630 : DO I1EL=1,N1EL 631 : DO I1PTEL=1,N1PTEL 632 : VELCHE(I1PTEL,I1EL)=XELCHE 633 : END DO 634 : END DO 635 : C ... OU IL EST CONSTANT PAR ELEMENT 636 : ELSE IF (VELCHE(/1).EQ.1)THEN 637 : IF(VELCHE(/2).NE.N1EL)THEN 637 : CALL ERREUR(749) 638 : GOTO 9995 639 : ENDIF 640 : * PP 15/6/93 641 : N2PTEL=IELCHE(/1) 642 : N2EL=IELCHE(/2) 643 : SEGADJ MELVAL 644 : DO I1EL=1,N1EL 645 : XELCHE=VELCHE(1,I1EL) 646 : DO I1PTEL=1,N1PTEL 647 : VELCHE(I1PTEL,I1EL)=XELCHE 648 : END DO 649 : END DO 650 : C ... OU IL EST ERRONE 651 : ELSE 651 : CALL ERREUR(750) 652 : GOTO 9995 653 : ENDIF 654 : ENDIF 655 : END DO 656 : END DO 657 : C 658 : C ON ACTIVE LES MELVAL DE CONNECTIVITE 659 : C 660 : DO ISOUCF=1,NZONEF 661 : NLOC2=ILOC2 (ISOUCF) 662 : MELVAL=MELCAR 663 : SEGACT,MELVAL 664 : NDOUBL=ILOC4(/1) 665 : DO IDOUBL=1,NDOUBL 666 : NLOC4=ILOC4(IDOUBL) 667 : MELVAL=MELPNI 668 : SEGACT,MELVAL 669 : MELVAL=MELPLI 670 : SEGACT,MELVAL 671 : END DO 672 : END DO 673 : C 674 : C ON DESACTIVE LE MCHELM,MCHAML DE CONNECTIVITE 675 : C 676 : DO ISOUCO=1,NSOUCO 677 : MCHAML=ICHAML(ISOUCO) 678 : SEGDES,MCHAML 679 : END DO 680 : SEGDES,MCHELM 681 : C 682 : C ON SORT (SANS ERREUR ???) 683 : C 684 : NOMID=MOMOTS 685 : SEGSUP,NOMID,NOTYPE 686 : SEGSUP,MCHEL1 687 : SEGSUP,MMODE1 688 : IRET=1 689 : RETURN 690 : C 691 : C TRAITEMENT DES ERREURS 692 : C 693 : 9995 CONTINUE 693 : CALL DTCHEL(IPCHO) 694 : 9996 CONTINUE 695 : DO ISOUCF=1,NZONEF 696 : NLOC2=ILOC2 (ISOUCF) 697 : NDOUBL=ILOC4(/1) 698 : DO IDOUBL=1,NDOUBL 699 : IF(ILOC4(IDOUBL).NE.0)THEN 700 : NLOC4=ILOC4(IDOUBL) 701 : SEGSUP,NLOC4 702 : ENDIF 703 : END DO 704 : NSZACC=ILOC3(/1) 705 : DO ISZACC=1,NSZACC 706 : IF(ILOC3(ISZACC).NE.0)THEN 707 : NLOC3=ILOC3(ISZACC) 708 : SEGSUP,NLOC3 709 : END IF 710 : END DO 711 : IF (ILOC3O.NE.0)THEN 712 : NLOC3=ILOC3O 713 : SEGSUP,NLOC3 714 : END IF 715 : IF (ILOC3I.NE.0)THEN 716 : NLOC3=ILOC3I 717 : NCOMP=MELVAC(/1) 718 : DO ICOMP=1,NCOMP 719 : MELVAL=MELVAC (ICOMP) 720 : SEGDES,MELVAL 721 : END DO 722 : SEGSUP,NLOC3 723 : ENDIF 724 : END DO 725 : 9997 CONTINUE 726 : NOMID=MOMOTS 727 : SEGSUP,NOMID,NOTYPE 728 : SEGSUP,MCHEL1 729 : SEGSUP,MMODE1 730 : 9998 CONTINUE 731 : DO ISOUCF=1,NZONEF 732 : NLOC2=ILOC2 (ISOUCF) 733 : MELEME=MAILEF 734 : MMODEL=MODLAC 735 : NSZACC=KMODEL(/1) 736 : DO ISZACC=1,NSZACC 737 : MINTE=MINTAC(ISZACC) 738 : SEGDES,MINTE 739 : IMODEL=KMODEL(ISZACC) 740 : SEGDES,IMODEL 741 : END DO 742 : SEGDES,MELEME 743 : END DO 744 : DO ISOUCF=1,NZONEF 745 : NLOC2=ILOC2 (ISOUCF) 746 : MMODEL=MODLAC 747 : SEGDES,MMODEL 748 : SEGSUP,NLOC2 749 : END DO 750 : SEGSUP,NLOC1 751 : 9999 CONTINUE 752 : DO ISOUCO=1,NSOUCO 753 : MCHAML=ICHAML(ISOUCO) 754 : SEGDES,MCHAML 755 : END DO 756 : SEGDES,MCHELM 757 : C 758 : IRET=0 759 : RETURN 760 : END 761 : 762 : 763 : 764 : 765 : 766 : 767 : 768 : 769 : 770 : 771 : 772 : 773 : 774 : 775 :
© Cast3M 2003 - All rights reserved.
Disclaimer