1 : C FORMCH SOURCE CHAT 12/01/17 21:15:19 7250 2 : SUBROUTINE FORMCH(IPMODL,IPCHEL,IRET,IPT,IPCH1) 3 : C 4 : C-------------------------------------------------------------------- 5 : C 6 : C REACTUALISATION DES CARACTERISTIQUES POUR CERTAINES FORMULATIONS 7 : C ROUTINE APPELE PAR FOMM 8 : C 9 : C-------------------------------------------------------------------- 10 : C 11 : C ENTREES : 12 : C --------- 13 : C 14 : C IPMODL POINTEUR SUR UN MMODEL 15 : C IPCHEL POINTEUR SUR UN MCHAML DE CARACTERISTIQUES 16 : C IPT POINTEUR SUR UN CHPOINT 17 : C 18 : C 19 : C SORTIE : 20 : C -------- 21 : C 22 : C IRET 1 SI L'OPERATION EST POSSIBLE 23 : C 0 SI L'OPERATION EST IMPOSSIBLE 24 : C IPCH1 POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUES 25 : C 26 : C 27 : C PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 20 09 90 28 : C 29 : C------------------------------------------------------------------- 30 : C 31 : IMPLICIT INTEGER(I-N) 32 : IMPLICIT REAL*8(A-H,O-Z) 33 : -INC SMCHAML 34 : -INC SMCOORD 35 : -INC SMELEME 36 : -INC SMMODEL 37 : -INC CCOPTIO 38 : -INC CCHAMP 39 : C 40 : SEGMENT IWRK 41 : REAL*8 XDDL(LRE),XE(3,NBNN),WORK(LW) 42 : ENDSEGMENT 43 : C 44 : SEGMENT INFO 45 : INTEGER INFELL(JG) 46 : ENDSEGMENT 47 : * 48 : SEGMENT NOTYPE 49 : CHARACTER*16 TYPE(NBTYPE) 50 : ENDSEGMENT 51 : C 52 : SEGMENT MPTVAL 53 : INTEGER IPOS(NS) ,NSOF(NS) 54 : INTEGER IVAL(NCOSOU) 55 : CHARACTER*16 TYVAL(NCOSOU) 56 : ENDSEGMENT 57 : C 58 : CHARACTER*8 CMATE 59 : CHARACTER*(NCONCH) CONM 60 : PARAMETER ( NINF=3 ) 61 : INTEGER INFOS(NINF) 62 : LOGICAL lsupdp 63 : C 64 : C 65 : DIMENSION VECT(6) 66 : * 67 : C 68 : C ON VERIFIE QUE LE MCHAML DE CARACTERISTIQUE EST SUR SON SUPPORT 69 : C 69 : CALL QUESUP (IPMODL,IPCHEL,3,1,ISUP,IRETCA) 70 : IF (ISUP.NE.0) THEN 71 : IRET=0 72 : RETURN 73 : ENDIF 74 : C 75 : C 76 : C ON COPIE LE CHAMELEM DE CARACTERISTIQUES 77 : C 77 : CALL COPIE8(IPCHEL,IPCH1) 78 : C 79 : C ON CONVERTIT LE CHAMP POINT EN CHAMP PAR ELEMENT 80 : C 80 : CALL CHAME1(0,IPMODL,IPT,' ',IPCHAM1,1) 81 : IF (IERR.NE.0) THEN 81 : CALL DTCHAM(IPCH1) 82 : IRET=0 83 : RETURN 84 : ENDIF 85 : C 86 : C ACTIVATION DU MODELE 87 : C 88 : IRET=1 89 : MMODEL=IPMODL 90 : SEGACT MMODEL 91 : NSOUS=KMODEL(/1) 92 : NSOU1=NSOUS 93 : C____________________________________________________________________ 94 : C 95 : C BOUCLE SUR LES SOUS-ZONES 96 : C____________________________________________________________________ 97 : C 98 : DO 200 ISOUS=1,NSOU1 99 : KERRE=0 100 : IVACAR=0 101 : IVACA1=0 102 : IVADEP=0 103 : C 104 : C ON RECUPERE L INFORMATION GENERALE 105 : C 106 : IMODEL=KMODEL(ISOUS) 107 : SEGACT IMODEL 108 : IPMAIL=IMAMOD 109 : CONM =CONMOD 110 : C 111 : C TRAITEMENT DU MODELE 112 : C 113 : MELE=NEFMOD 114 : MELEME=IMAMOD 115 : C____________________________________________________________________ 116 : C 117 : C INFORMATION SUR L'ELEMENT FINI 118 : C____________________________________________________________________ 119 : C 119 : CALL ELQUOI(MELE,0,6,IPINF,IMODEL) 120 : IF (IERR.NE.0) THEN 121 : SEGDES IMODEL,MMODEL 121 : CALL DTCHAM(IPCH1) 121 : CALL DTCHAM (IPCHAM1) 122 : IRET=0 123 : RETURN 124 : ENDIF 125 : C 126 : INFO=IPINF 127 : IFORM=INFELL(13) 128 : NBG =INFELL(6) 129 : ICARA=INFELL(5) 130 : LW =INFELL(7) 131 : LRE =INFELL(9) 132 : C 133 : C ACTIVATION DU MELEME 134 : C 135 : SEGACT MELEME 136 : NBNN =NUM(/1) 137 : NBELEM=NUM(/2) 138 : C 139 : C CREATION DU TABLEAU INFOS 140 : C 140 : CALL IDENT(IPMAIL,CONM,IPCH1,IPCHAM1,INFOS,IRTD) 141 : IF (IRTD.EQ.0) THEN 142 : NCARA=0 143 : NCARF=0 144 : NDEP=0 145 : MOCARA=0 146 : MODEPL=0 147 : GOTO 9990 148 : ENDIF 149 : C 150 : C RECHERCHE DES NOMS DE COMPOSANTES 151 : C 152 : if(lnomid(1).ne.0) then 153 : nomid=lnomid(1) 154 : segact nomid 155 : modepl=nomid 156 : ndep=lesobl(/2) 157 : nfac=lesfac(/2) 158 : lsupdp=.false. 159 : else 160 : lsupdp=.true. 160 : CALL IDDEPL(IFORM,IFOUR,MODEPL,NDEP,NFAC) 161 : endif 162 : C 163 : C VERIFICATION DE LEUR PRESENCE 164 : C 165 : NBTYPE=1 166 : SEGINI NOTYPE 167 : MOTYPE=NOTYPE 168 : TYPE(1)='REAL*8' 168 : CALL KOMCHA(IPCHAM1,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP) 169 : SEGSUP NOTYPE 170 : IF (IERR.NE.0) THEN 171 : NCARA=0 172 : NCARF=0 173 : MOCARA=0 174 : GOTO 9990 175 : ENDIF 176 : C____________________________________________________________________ 177 : C 178 : * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES * 179 : C____________________________________________________________________ 180 : C 181 : NBROBL=0 182 : NBRFAC=0 183 : MOCARA=0 184 : NCARA=0 185 : NCARF=0 186 : NCARR=0 187 : IVECT=0 188 : * 189 : * CARACTERISTIQUES POUR LES BARRES 190 : * 191 : IF (IFORM.EQ.27) THEN 192 : NBROBL=1 193 : SEGINI NOMID 194 : MOCARA=NOMID 195 : LESOBL(1)='SECT' 196 : * 197 : NBTYPE=1 198 : SEGINI NOTYPE 199 : MOTYPE=NOTYPE 200 : TYPE(1)='REAL*8' 201 : * 202 : * CARACTERISTIQUES POUR LES POUTRES ET LES TUYAU 203 : * 204 : ELSE IF (IFORM.EQ.7.OR.IFORM.EQ.13) THEN 205 : NBRFAC=1 206 : SEGINI NOMID 207 : MOCARA=NOMID 208 : LESFAC(1)='VECT' 209 : IVECT=1 210 : * 211 : NBTYPE=1 212 : SEGINI NOTYPE 213 : MOTYPE=NOTYPE 214 : TYPE(1)='POINTEURPOINT ' 215 : * 216 : * CARACTERISTIQUES POUR LES LINESPRING 217 : * 218 : ELSE IF (IFORM.EQ.15) THEN 219 : NBROBL=3 220 : SEGINI NOMID 221 : MOCARA=NOMID 222 : LESOBL(1)='VX ' 223 : LESOBL(2)='VY ' 224 : LESOBL(3)='VZ ' 225 : * 226 : NBTYPE=1 227 : SEGINI NOTYPE 228 : MOTYPE=NOTYPE 229 : TYPE(1)='REAL*8' 230 : * 231 : * CARACTERISTIQUES POUR LES TUFI 232 : * 233 : ELSE IF (IFORM.EQ.17) THEN 234 : NBROBL=6 235 : SEGINI NOMID 236 : MOCARA=NOMID 237 : LESOBL(1)='VX ' 238 : LESOBL(2)='VY ' 239 : LESOBL(3)='VZ ' 240 : LESOBL(4)='VXF ' 241 : LESOBL(5)='VYF ' 242 : LESOBL(6)='VZF ' 243 : * 244 : NBTYPE=1 245 : SEGINI NOTYPE 246 : MOTYPE=NOTYPE 247 : TYPE(1)='REAL*8' 248 : ENDIF 249 : * 250 : IF (MOCARA.NE.0) THEN 251 : * 251 : CALL KOMCHA(IPCHEL,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) 252 : * write (6,*) ' formch apres komcha 1 ivacar ',ivacar 253 : IF (IERR.NE.0)THEN 254 : SEGSUP NOTYPE 255 : GOTO 9990 256 : ENDIF 256 : CALL KOMCHA(IPCH1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACA1) 257 : SEGSUP NOTYPE 258 : IF (IERR.NE.0) GOTO 9990 259 : IF (IVECT.EQ.1) THEN 260 : MPTVAL=IVACAR 261 : IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN 262 : * 263 : * MOT CLE VECT EN CAS DE CONVERSION 264 : * 265 : IVECT=2 266 : NOMID=MOCARA 267 : SEGSUP NOMID 268 : NBRFAC=0 269 : NBROBL=3 270 : SEGINI NOMID 271 : MOCARA=NOMID 272 : LESOBL(1)='VX ' 273 : LESOBL(2)='VY ' 274 : LESOBL(3)='VZ ' 275 : * 276 : NBTYPE=1 277 : SEGINI NOTYPE 278 : MOTYPE=NOTYPE 279 : TYPE(1)='REAL*8' 280 : * 280 : CALL KOMCHA(IPCHEL,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) 281 : * write (6,*) ' formch apres komcha 2 ivacar ',ivacar 282 : IF (IERR.NE.0)THEN 283 : SEGSUP NOTYPE 284 : GOTO 9990 285 : ENDIF 285 : CALL KOMCHA(IPCH1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACA1) 286 : SEGSUP NOTYPE 287 : IF (IERR.NE.0) GOTO 9990 288 : ENDIF 289 : ENDIF 290 : ENDIF 291 : NCARA=NBROBL 292 : NCARF=NBRFAC 293 : NCARR=NCARA+NCARF 294 : IF (MOCARA.NE.0) SEGDES NOMID 295 : * 296 : * AJUSTEMENT DE LA DIMENSION DES MELVAL 297 : * 298 : if ((iform.eq.7).OR.(iform.eq.13).OR.(iform.eq.15) 299 : & .OR.(iform.eq.17)) then 300 : IF (NCARR.NE.0) THEN 301 : MPTVAL=IVACAR 302 : MELVAL=IVAL(1) 303 : IF(IVECT.EQ.1) THEN 304 : N2EL =IELCHE(/2) 305 : IF(N2EL.LT.NBELEM) THEN 306 : N2EL = NBELEM 307 : N2PTEL= 1 308 : N1EL = 0 309 : N1PTEL= 0 310 : MPTVAL=IVACA1 311 : MELVAL=IVAL(1) 312 : SEGADJ MELVAL 313 : ENDIF 314 : ELSE 315 : N1PTEL=VELCHE(/1) 316 : N1EL =VELCHE(/2) 317 : IF((N1EL.LT.NBELEM).OR.(N1PTEL.LT.NBG)) THEN 318 : N1EL = MAX(N1EL,NBELEM) 319 : N1PTEL= MAX(N1PTEL,NBG) 320 : N2EL = 0 321 : N2PTEL= 0 322 : IF (IFORM.EQ.7.OR.IFORM.EQ.13) N1PTEL=1 323 : MPTVAL=IVACA1 324 : DO 128 ID=1,NBROBL 325 : MELVAL=IVAL(ID) 326 : SEGADJ MELVAL 327 : 128 CONTINUE 328 : ENDIF 329 : ENDIF 330 : ENDIF 331 : endif 332 : * 333 : * 334 : * MASSI COQUE COQEP POUT CIST THER TUYA LISP 335 : * 336 : if(iform.gt.38) go to 30 337 : GOTO (30,22,30,22,30,22,120,22,30,22,22,22,120,22,90,22, 338 : * 339 : * TUFI RCMA RCCO SULI MEMB UNIA THER INCO PORE 340 : * 341 : . 70,22,22,22,22,22,22,22,22,22,30,22,22,22,22,22,30,22, 342 : * 343 : * RACO HOMO 344 : * 345 : . 30,22,22,22),IFORM 346 : C 347 : 22 CONTINUE 348 : IRET=0 349 : MOTERR(1:8)=NOMFR(IFORM) 349 : CALL ERREUR(193) 350 : GOTO 9990 351 : C______________________________________________________________________ 352 : C 353 : C FORMULATION MASSIVE - RIEN DE SPECIAL A FAIRE 354 : C FORMULATION POREUSE - RIEN DE SPECIAL A FAIRE 355 : C FORMULATIONS COQUE - ON NE FAIT RIEN 356 : C FORMULATIONS UNIAXIALE - ON NE FAIT RIEN 357 : C______________________________________________________________________ 358 : C 359 : 30 CONTINUE 360 : GOTO 150 361 : C______________________________________________________________________ 362 : C 363 : C FORMULATION LINESPRING 364 : C______________________________________________________________________ 365 : C 366 : 90 CONTINUE 367 : IAD=2 368 : SEGINI IWRK 369 : DO 921 IB=1,NBELEM 370 : C 371 : C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS 372 : C 372 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 373 : IE=1 374 : DO 9207 IGAU=1,NBNN 375 : MPTVAL=IVADEP 376 : DO 9207 ICOMP=1,NDEP 377 : MELVAL=IVAL(ICOMP) 378 : IGMN=MIN(IGAU,VELCHE(/1)) 379 : IBMN=MIN(IB ,VELCHE(/2)) 380 : XDDL(IE)=VELCHE(IGMN,IBMN) 381 : IE=IE+1 382 : 9207 CONTINUE 383 : C 384 : DO 921 IC=1,NBG 385 : MPTVAL=IVACAR 386 : IF(IC.EQ.2) GO TO 948 387 : DO 923 ID=1,3 388 : MELVAL=IVAL(ID) 389 : IGMN=MIN(IC,VELCHE(/1)) 390 : IBMN=MIN(IB,VELCHE(/2)) 391 : VECT(ID)=VELCHE(IGMN,IBMN) 392 : 923 CONTINUE 393 : ICC=1 394 : IF(IC.GT.1) ICC=2 394 : CALL LSPFRM(IWRK,KERRE,VECT,ICC) 395 : C 396 : IF(KERRE.NE.0) THEN 397 : INTERR(1)=ISOUS 398 : INTERR(2)=IB 399 : GO TO 927 400 : ENDIF 401 : C 402 : C REMPLISSAGE 403 : C 404 : 948 CONTINUE 405 : MPTVAL=IVACA1 406 : DO 921 ID=1,3 407 : MELVAL=IVAL(ID) 408 : VELCHE(IC,IB)=VECT(ID) 409 : * 410 : 921 CONTINUE 411 : C 412 : 927 SEGSUP IWRK 413 : GOTO 151 414 : C_______________________________________________________________________ 415 : C 416 : C FORMULATION TUYAU FISSURE 417 : C_______________________________________________________________________ 418 : C 419 : 70 CONTINUE 420 : SEGINI IWRK 421 : DO 721 IB=1,NBELEM 422 : C 423 : C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS 424 : C 424 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 425 : IE=1 426 : DO 7207 IC=1,NBNN 427 : MPTVAL=IVADEP 428 : DO 7207 ID=1,NDEP 429 : MELVAL=IVAL(ID) 430 : IGMN=MIN(IC,VELCHE(/1)) 431 : IBMN=MIN(IB,VELCHE(/2)) 432 : XDDL(IE)=VELCHE(IGMN,IBMN) 433 : IE=IE+1 434 : 7207 CONTINUE 435 : C 436 : MPTVAL=IVACAR 437 : DO 723 ID=1,6 438 : MELVAL=IVAL(ID) 439 : IBMN=MIN(IB,VELCHE(/2)) 440 : VECT(ID)=VELCHE(1,IBMN) 441 : 723 CONTINUE 442 : C 442 : CALL TUYFRM(IWRK,KERRE,VECT,VECT(4)) 443 : C 444 : IF(KERRE.NE.0) THEN 445 : INTERR(1)=ISOUS 446 : INTERR(2)=IB 447 : GO TO 727 448 : ENDIF 449 : C 450 : C REMPLISSAGE 451 : C 452 : DO 721 IC=1,NBG 453 : MPTVAL=IVACA1 454 : DO 726 ID=1,6 455 : MELVAL=IVAL(ID) 456 : VELCHE(IC,IB)=VECT(ID) 457 : 726 CONTINUE 458 : C 459 : 721 CONTINUE 460 : C 461 : 727 SEGSUP IWRK 462 : GOTO 151 463 : C_______________________________________________________________________ 464 : C 465 : C FORMULATION POUTRE ET TUYAU 466 : C_______________________________________________________________________ 467 : C 468 : 120 CONTINUE 469 : SEGINI IWRK 470 : C 471 : DO 121 IB=1,NBELEM 472 : C 473 : C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS 474 : C 474 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 475 : IE=1 476 : DO 1207 IC=1,NBNN 477 : MPTVAL=IVADEP 478 : DO 1207 ID=1,NDEP 479 : MELVAL=IVAL(ID) 480 : IGMN=MIN(IC,VELCHE(/1)) 481 : IBMN=MIN(IB,VELCHE(/2)) 482 : XDDL(IE)=VELCHE(IGMN,IBMN) 483 : IE=IE+1 484 : 1207 CONTINUE 485 : C 486 : C CAS OU ON A LU LE MOT VECTEUR 487 : C 488 : MPTVAL=IVACAR 489 : IF (IVECT.EQ.1) THEN 490 : MELVAL=IVAL(NCARR) 491 : IBMN=MIN(IB,IELCHE(/2)) 492 : IP=IELCHE(1,IBMN) 493 : IREF=(IP-1)*(IDIM+1) 494 : DO 6129 IC=1,IDIM 495 : VECT(IC)=XCOOR(IREF+IC) 496 : 6129 CONTINUE 497 : DENSIT=XCOOR(IREF+(IDIM+1)) 498 : C 499 : C CAS DU CHAMELEM COMVERTI 500 : C 501 : ELSE IF (IVECT.EQ.2) THEN 502 : DO 6429 IC=1,3 503 : MELVAL=IVAL(IC) 504 : IBMN=MIN(IB,VELCHE(/2)) 505 : VECT(IC)=VELCHE(1,IBMN) 506 : 6429 CONTINUE 507 : ENDIF 508 : C 508 : CALL POUFRM(IWRK,KERRE,VECT) 509 : C 510 : IF(KERRE.NE.0) THEN 511 : INTERR(1)=ISOUS 512 : INTERR(2)=IB 513 : GO TO 127 514 : ENDIF 515 : C 516 : C REMPLISSAGE 517 : C 518 : IF (IVECT.EQ.1) THEN 519 : C 520 : C ON RECREE UN VECTEUR --> MISE A JOUR DU POINTEUR IELCHE 521 : C 522 : SEGACT MCOORD 523 : C NOMBRE DE NOEUDS 524 : NBNO=XCOOR(/1)/(IDIM+1) 525 : NBNOI=NBNO 526 : NBPTS=NBNO+1 527 : SEGADJ MCOORD 528 : C 529 : C ON CREE LE NOEUD NBNO+1 530 : C 531 : XCOOR(NBNOI*(IDIM+1)+1)= VECT(1) 532 : XCOOR(NBNOI*(IDIM+1)+2)= VECT(2) 533 : IF (IDIM.EQ.3) XCOOR(NBNOI*(IDIM+1)+3)= VECT(3) 534 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))= DENSIT 535 : IPOINT = NBPTS 536 : * 537 : MPTVAL=IVACA1 538 : MELVAL=IVAL(1) 539 : SEGACT MELVAL*MOD 540 : IELCHE(1,IB)=IPOINT 541 : ELSE 542 : MPTVAL=IVACA1 543 : DO 126 ID=1,3 544 : MELVAL=IVAL(ID) 545 : VELCHE(1,IB)=VECT(ID) 546 : 126 CONTINUE 547 : ENDIF 548 : 121 CONTINUE 549 : C 550 : C 551 : 127 SEGSUP IWRK 552 : GOTO 151 553 : C 554 : C AUTRE FORMULATION 555 : C 556 : 151 CONTINUE 556 : IF(KERRE.EQ.1) CALL ERREUR(128) 556 : IF(KERRE.EQ.2) CALL ERREUR(138) 556 : IF(KERRE.EQ.3) CALL ERREUR(277) 557 : 150 CONTINUE 558 : SEGDES MELEME 559 : SEGSUP INFO 560 : SEGDES IMODEL 561 : MPTVAL=IVACAR 562 : IF (MPTVAL.NE.0) THEN 563 : SEGACT MPTVAL 564 : DO 152 I=1,ival(/1) 565 : IF (IVAL(I).NE.0) THEN 566 : MELVAL=IVAL(I) 567 : SEGDES MELVAL 568 : ENDIF 569 : 152 CONTINUE 570 : IF (MOCARA.NE.0) SEGSUP MPTVAL 571 : ENDIF 572 : C 573 : MPTVAL=IVACA1 574 : IF (MPTVAL.NE.0) THEN 575 : SEGACT MPTVAL 576 : DO I=1,IVAL(/1) 577 : IF (IVAL(I).NE.0) THEN 578 : MELVAL=IVAL(I) 579 : SEGDES MELVAL 580 : ENDIF 581 : ENDDO 582 : IF (MOCARA.NE.0) SEGSUP MPTVAL 583 : ENDIF 584 : C 585 : MPTVAL=IVADEP 586 : IF (MPTVAL.NE.0) THEN 587 : SEGACT MPTVAL 588 : DO 153 I=1,ival(/1) 589 : IF (IVAL(I).NE.0) THEN 590 : MELVAL=IVAL(I) 591 : SEGDES MELVAL 592 : ENDIF 593 : 153 CONTINUE 594 : SEGSUP MPTVAL 595 : ENDIF 596 : C 597 : NOMID=MOCARA 598 : IF (MOCARA.NE.0) SEGSUP NOMID 599 : NOMID=MODEPL 600 : if(lsupdp)SEGSUP NOMID 601 : C 602 : IF(KERRE.NE.0) THEN 603 : IRET=0 604 : SEGDES MMODEL 604 : CALL DTCHAM(IPCHAM1) 604 : CALL DTCHAM(IPCH1) 605 : RETURN 606 : ENDIF 607 : C 608 : 200 CONTINUE 609 : C 609 : CALL DTCHAM(IPCHAM1) 610 : SEGDES MMODEL 611 : RETURN 612 : C 613 : 9990 CONTINUE 614 : C 615 : C ERREUR DANS UNE SOUS ZONE DESACTIVATION ET RETOUR 616 : C 617 : SEGDES MELEME 618 : * SEGSUP INFO 619 : SEGDES IMODEL 620 : MPTVAL=IVACAR 621 : DO 9152 I=1,IVAL(/1) 622 : IF (IVAL(I).NE.0) THEN 623 : MELVAL=IVAL(I) 624 : SEGDES MELVAL 625 : ENDIF 626 : 9152 CONTINUE 627 : IF (MOCARA.NE.0) SEGSUP MPTVAL 628 : C 629 : MPTVAL=IVACA1 630 : DO I=1,IVAL(/1) 631 : IF (IVAL(I).NE.0) THEN 632 : MELVAL=IVAL(I) 633 : SEGDES MELVAL 634 : ENDIF 635 : ENDDO 636 : IF (MOCARA.NE.0) SEGSUP MPTVAL 637 : C 638 : MPTVAL=IVADEP 639 : DO 9153 I=1,IVAL(/1) 640 : IF (IVAL(I).NE.0) THEN 641 : MELVAL=IVAL(I) 642 : SEGDES MELVAL 643 : ENDIF 644 : 9153 CONTINUE 645 : IF (MODEPL.NE.0) SEGSUP MPTVAL 646 : C 647 : NOMID=MOCARA 648 : IF (MOCARA.NE.0) SEGSUP NOMID 649 : NOMID=MODEPL 650 : IF (MODEPL.NE.0.and.lsupdp) SEGSUP NOMID 651 : C 652 : RETURN 653 : END 654 : 655 : 656 : 657 : 658 : 659 : 660 : 661 : 662 : 663 : 664 : 665 : 666 : 667 : 668 : 669 : 670 : 671 :
© Cast3M 2003 - All rights reserved.
Disclaimer