C EXPIL SOURCE PV090527 24/01/14 21:15:02 10699 SUBROUTINE EXPIL (IFILE,ICOLAC,M1,M2,IIICHA) C---------------------------------------------------------------------- C C BUT: REMPLIT LES PILES A PARTIR DE L EXAMEN DE LA PILE C SI IIICHA =1 ON CHANGE LES POINTEURS---- C C ENTREE IFILE NUMERO DE LA PILE EXAMINEE C ICOLAC POINTEUR SUR LE CHAPEAU DES PILES C M1 PREMIER INDICE D EXAMEN DANS LA PILE C M2 DERNIER INDICE C IIICHA =1 ON CHANGE LES POINTEURS C----------------------------------------------------------------------- C REMARQUE : ICOLAC EST UN SEGMENT ACTIF EN ENTREE ET EN SORTIE C PAS DE CHANGEMENT DE STATUT AU COURS DU SP C----------------------------------------------------------------------- C PROGRAMME PAR FARVACQUE- REPRIS PAR LENA C APPELE PAR FILLPI C APPELLE AJOUN TYPFIL C======================================================================= C TABLEAU KCOLA : VOIR LE SOUS-PROGRAMME TYPFIL C======================================================================= IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCASSIS -INC SMBLOC *INC SMELEME -INC SMBASEM *INC SMCHPOI *INC SMRIGID -INC SMMATRI -INC SMCLSTR -INC SMELSTR -INC SMSOLUT -INC SMDEFOR -INC SMSTRUC -INC SMATTAC -INC SMCHARG -INC SMMODEL -INC SMEVOLL -INC SMTABLE -INC SMSUPER -INC SMTEXTE -INC SMVECTE -INC SMLCHPO -INC SMINTE -INC SMNUAGE -INC CCNOYAU -INC TMCOLAC -INC SMANNOT -INC SMLOBJE LOGICAL LOTEMP SEGMENT ITRAVV(NITLAC) CHARACTER*(8) ITYP1 CHARACTER*(1) CHAVAL CHARACTER*(16) MOTYP C======================================================================= C ICOLAC : KCOLA : POINTEUR SUR LA PILE ITLACC C MCOLA : NOMBRE D'OBJETS INSPECTES DANS LA PILE C ICOLA : POINTEUR SUR ISGTR ( NOM-NOM-RANG DANS ITLACC) C KCOLAC: CONTIENT POUR CHAQUE PILE LE NOMBRE D'OBJETS A SORT C======================================================================= IF (M1.GT.M2) RETURN iun=1 icinq=5 IF (IIMPI.EQ.5) WRITE (IOIMP,8877) IFILE,M1,M2 8877 FORMAT (' EXAMEN DE LA PILE ',I5,' DE',I5,' A',I5) SEGACT ICOLAC ILISSE=ILISSF SEGACT ILISSE*MOD ILISSE=ILISSG SEGACT ILISSE*MOD ITLACC=KCOLA(IFILE) GO TO(501,502,503,599,599,506,507,508,509,510, 1 599,512,599,514,515,516,517,599,599,520, 1 599,522,523,524,525,526,527,528,529,530, 1 531,532,533,534,535,536,537,538,539,540, 1 541,542,543,510,545,546,547,548,549,550),IFILE CALL TYPFIL(MOTERR,IFILE) CALL ERREUR (336) CALL GINT2 GO TO 599 C ******************************* MELEME**************************** 501 CONTINUE CALL EXAMEL (ICOLAC,ITLACC,M1,M2,IIICHA) GO TO 599 C **************************** MCHPOI ****************************** 502 CONTINUE CALL EXACHP (ICOLAC,ITLACC,M1,M2,IIICHA) GO TO 599 C **************************** MRIGID ****************************** 503 CONTINUE CALL EXARIG (ICOLAC,ITLACC,M1,M2,IIICHA) GO TO 599 C *************************** ******************************* 504 CONTINUE GO TO 599 C *************************** ******************************* 505 CONTINUE GO TO 599 C **************************** MCLSTR ****************************** 506 CONTINUE ICO1=KCOLA(12) ICO2=KCOLA(3) DO 614 IEL=M1,M2 MCLSTR=ITLAC(IEL) IF (MCLSTR.EQ.0) GO TO 614 SEGACT MCLSTR*MOD DO 615 I=1,ISOSTR(/1) IVA=ISOSTR(I) IF(IVA.NE.0)CALL AJOUN(ICO1,IVA,ILISSE,iun) IF(IIICHA.EQ.1)ISOSTR(I)=IVA IVA=IRIGCL(I) IF (IVA.NE.0)CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1)IRIGCL(I)=IVA 615 CONTINUE SEGDES MCLSTR 614 CONTINUE GO TO 599 C **************************** MELSTR ****************************** 507 CONTINUE ICO1=KCOLA(12) ICO2=KCOLA(1) DO 616 IEL=M1,M2 MELSTR=ITLAC(IEL) IF (MELSTR.EQ.0) GO TO 616 SEGACT MELSTR*MOD DO 617 I=1,ISOSTU(/1) IVA=ISOSTU(I) IF(IVA.NE.0)CALL AJOUN(ICO1,IVA,ILISSE,iun) IF(IIICHA.EQ.1)ISOSTU(I)=IVA IVA=IMELEM(I) IF (IVA.NE.0)CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1)IMELEM(I)=IVA 617 CONTINUE SEGDES MELSTR 616 CONTINUE GO TO 599 C *************************** MSOLUT ******************************* 508 CONTINUE ICO1=KCOLA(1) DO 618 IEL=M1,M2 MSOLUT=ITLAC(IEL) IF (MSOLUT.EQ.0) GO TO 618 SEGACT MSOLUT*MOD NIPO=MSOLIS(/1) DO 620 II=1,NIPO IF(MSOLIS(II).EQ.0) GOTO 620 IF(II.EQ.3) THEN IVA=MSOLIS(3) CALL AJOUN(ICO1,IVA,ILISSE,iun) CCC IF (IONIVE.LT.3) GO TO 620 IF(IIICHA.EQ.1) MSOLIS(3)=IVA GOTO 620 ENDIF IF(II.LE.4) GOTO 620 ICO2=KCOLA(MSOLIT(II)) MSOLEN=MSOLIS(II) SEGACT MSOLEN*MOD LTAB=ISOLEN(/1) DO 619 I=1,LTAB IVA=ISOLEN(I) IF(IVA.EQ.0)GOTO 619 CALL AJOUN(ICO2,IVA,ILISSE,iun) IF (IONIVE.LT.3) GO TO 619 IF(IIICHA.EQ.1) ISOLEN(I)=IVA 619 CONTINUE SEGDES MSOLEN 620 CONTINUE SEGDES MSOLUT 618 CONTINUE GOTO 599 C ************************** MSTRUC ******************************** 509 CONTINUE ICO1=KCOLA(12) DO 621 IEL=M1,M2 MSTRUC=ITLAC(IEL) IF (MSTRUC.EQ.0) GO TO 621 SEGACT MSTRUC*MOD DO 622 I=1,LISTRU(/1) IVA=LISTRU(I) IF(IVA.EQ.0) GO TO 622 IF(IVA.GT.0) THEN CALL AJOUN(ICO1,IVA,ILISSE,iun) IF(IIICHA.EQ.1) LISTRU(I)=-IVA ENDIF 622 CONTINUE SEGDES MSTRUC 621 CONTINUE GOTO 599 C ******************************* MTABLE ************************** * POUR LES TABLES ON COMMENCE PAR METTRE DANS LA PILE DES REELS * LES VALEURS REELLES ON ON PREND LEUR INDICE * CECI NOUS PERMET D'ETRE COMPATIBLE AVEC LES VERSIONS ANTERIEURES * PV 28 DECEMBRE 1988 * a partir du niveau 21 on n'utilise plus la pile d'entiers. On les sauve directement * 510 CONTINUE DO 710 IEL=M1,M2 MTABLE=ITLAC(IEL) IF (MTABLE.EQ.0) GO TO 710 SEGACT MTABLE*MOD L6=MLOTAB IF (L6.EQ.0) GO TO 713 DO 711 K=1,L6 ITYP1=MTABTI(K) IF (IIICHA.NE.1.AND.ITYP1.EQ.'FLOTTANT') THEN XVA=RMTABI(K) CALL QUERAN(IVA,'FLOTTANT',0,XVA,' ',.TRUE.,0) MTABII(K)=IVA ENDIF IVA=MTABII(K) J=0 CALL TYPFIL (ITYP1,J) IF(J.LE.0) GO TO 711 ICO2=KCOLA(J) NUMLIS=1 ilissd=ilissg IF(J.EQ.24) NUMLIS=6 IF(J.EQ.25) then NUMLIS=3 ilissd=ilissf ENDIF IF(J.EQ.26) then if (ionive.le.20) then NUMLIS=2 else goto 716 endif ENDIF IF(J.EQ.27) NUMLIS=5 IF(J.EQ.32) then NUMLIS=3 ilissd=ilissp endif IF(J.EQ.36) NUMLIS=7 IF(J.EQ.45) NUMLIS=5 CALL AJOUN (ICO2,IVA,ILISSd,NUMLIS) IF(IIICHA.EQ.1) MTABII(K)=IVA 716 CONTINUE ITYP1=MTABTV(K) IF (IIICHA.NE.1.AND.ITYP1.EQ.'FLOTTANT') THEN XVA=RMTABV(K) CALL QUERAN(IVA,'FLOTTANT',0,XVA,' ',.TRUE.,0) MTABIV(K)=IVA ENDIF IVA=MTABIV(K) CALL TYPFIL (ITYP1,J) IF(J.LE.0) GO TO 711 IF (J.EQ.47) GO TO 711 ICO2=KCOLA(J) NUMLIS=1 ilissd=ilissg IF(J.EQ.24) NUMLIS=6 IF(J.EQ.25) then NUMLIS=3 ilissd=ilissf ENDIF IF(J.EQ.26) then if (ionive.le.20) then NUMLIS=2 else goto 711 endif ENDIF IF(J.EQ.27) NUMLIS=5 IF(J.EQ.32) then NUMLIS=3 ilissd=ilissp endif IF(J.EQ.36) NUMLIS=7 IF(J.EQ.45) NUMLIS=5 CALL AJOUN (ICO2,IVA,ILISSD,NUMLIS) IF(IIICHA.EQ.1) MTABIV(K)=IVA 711 CONTINUE 713 SEGDES MTABLE 710 CONTINUE GO TO 599 715 CONTINUE MOTERR(1:8)=ITYP1 CALL ERREUR (336) GO TO 599 C ******************************* ************************* 511 CONTINUE GO TO 599 C ******************************** MSOSTU ************************** 512 CONTINUE ICO5=KCOLA(5) ICO3=KCOLA(3) DO 630 IEL=M1,M2 MSOSTU=ITLAC(IEL) IF (MSOSTU.EQ.0) GO TO 630 SEGACT MSOSTU*MOD IVA=ISRAID IF (IVA.NE.0)CALL AJOUN(ICO3,IVA,ILISSE,iun) IF(IIICHA.EQ.1)ISRAID=IVA IVA=ISMASS IF (IVA.NE.0)CALL AJOUN(ICO3,IVA,ILISSE,iun) IF(IIICHA.EQ.1)ISMASS=IVA NS=ISCHAM(/1) IF (NS.EQ.0) GO TO 122 DO 121 I=1,NS IVA= ISCHAM(I) IF (IVA.NE.0)CALL AJOUN (ICO5,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ISCHAM(I)=IVA 121 CONTINUE 122 SEGDES MSOSTU 630 CONTINUE GO TO 599 C ***************************** IMATRI ***************************** 513 CONTINUE GO TO 599 C ***************************** MJONCT ***************************** 514 CONTINUE ICO1=KCOLA(1) ICO12=KCOLA(12) ICO2=KCOLA(2) DO 631 IEL=M1,M2 MJONCT=ITLAC(IEL) IF (MJONCT.EQ.0) GO TO 631 SEGACT MJONCT*MOD IVA=MJOPOI IF(MJOTYP.EQ.'CHOC')THEN IF(IVA.NE.0) CALL AJOUN(ICO2,IVA,ILISSE,iun) ELSE IF(IVA.NE.0) CALL AJOUN(ICO1,IVA,ILISSE,iun) ENDIF CCC CALL AJOUN(ICO1,IVA) IF(IIICHA.EQ.1)MJOPOI=IVA DO 632 I=1,ISTRJO(/1) IVA=ISTRJO(I) IF (IVA.NE.0)CALL AJOUN(ICO12,IVA,ILISSE,iun) IF(IIICHA.EQ.1)ISTRJO(I)=IVA IVA=IPCHJO(I) IF (IVA.NE.0)CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1)IPCHJO(I)=IVA IVA=IPOSJO(I) IF (IVA.NE.0) CALL AJOUN(ICO1,IVA,ILISSE,iun) IF(IIICHA.EQ.1)IPOSJO(I)=IVA 632 CONTINUE SEGDES MJONCT 631 CONTINUE GO TO 599 C ************************ MATTAC ********************************** 515 CONTINUE ICO1=KCOLA(1) ICO3=KCOLA(3) ICO14=KCOLA(14) DO 150 IEL=M1,M2 MATTAC =ITLAC(IEL) IF (MATTAC.EQ.0) GO TO 150 SEGACT MATTAC*MOD NN=LISATT(/1) DO 151 I=1,NN MSOUMA=LISATT(I) IF (MSOUMA.EQ.0) GO TO 151 SEGACT MSOUMA*MOD M=IPMATK(/1) DO 152 J=1,M IVA=IPMATK(J) IF (IVA.NE.0)CALL AJOUN (ICO3,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IPMATK(J)=IVA 152 CONTINUE N=IATREL(/1) DO 153 J=1,N IVA=IATREL(J) IF (IVA.NE.0)CALL AJOUN (ICO14,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IATREL(J)=IVA 153 CONTINUE IF(IGEOCH.EQ.0) GO TO 156 MGEOCH=IGEOCH SEGACT MGEOCH*MOD NI=INORCH(/1) DO 154 J=1,NI IVA=INORCH(J) IF (IVA.NE.0)CALL AJOUN (ICO1 ,IVA,ILISSE,iun) IF(IIICHA.EQ.1) INORCH(J)=IVA 154 CONTINUE N1=IMAPRO(/1) DO 155 J=1,N1 IVA=IMAPRO(J) IF (IVA.NE.0)CALL AJOUN (ICO1 ,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IMAPRO(J)=IVA 155 CONTINUE SEGDES MGEOCH 156 CONTINUE SEGDES MSOUMA 151 CONTINUE SEGDES MATTAC 150 CONTINUE GO TO 599 C ************************ MMATRI ********************************** 516 CONTINUE ICO1=KCOLA(1) DO 633 IEL=M1,M2 MMATRI=ITLAC(IEL) IF (MMATRI.EQ.0) GO TO 633 SEGACT MMATRI*MOD IVA=IGEOMA if (igeoma.eq.0) goto 633 CALL AJOUN(ICO1,IVA,ILISSE,iun) IF(IIICHA.EQ.1)IGEOMA=IVA SEGDES MMATRI 633 CONTINUE GOTO 599 C *************************MDEFOR*********************************** 517 CONTINUE ICO1=KCOLA(1) ICO2=KCOLA(2) ICO30=KCOLA(30) ICO38=KCOLA(38) ICO39=KCOLA(39) DO 634 IEL=M1,M2 MDEFOR=ITLAC(IEL) IF (MDEFOR.EQ.0) GO TO 634 SEGACT MDEFOR*MOD NDEF=IELDEF(/1) DO 635 I=1,NDEF IVA=IELDEF(I) CALL AJOUN(ICO1,IVA,ILISSE,iun) IF(IIICHA.EQ.1)IELDEF(I)=IVA IVA=ICHDEF(I) CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1)ICHDEF(I)=IVA IVA=MTVECT(I) IF (IVA.NE.0) THEN CALL AJOUN(ICO30,IVA,ILISSE,iun) IF(IIICHA.EQ.1)MTVECT(I)=IVA ENDIF IVA=MDCHP(I) IF (IVA.NE.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1)MDCHP(I)=IVA ENDIF IVA=MDCHEL(I) IF (IVA.NE.0) THEN CALL AJOUN(ICO39,IVA,ILISSE,iun) IF(IIICHA.EQ.1)MDCHEL(I)=IVA ENDIF IVA=MDMODE(I) IF (IVA.NE.0) THEN CALL AJOUN(ICO38,IVA,ILISSE,iun) IF(IIICHA.EQ.1)MDMODE(I)=IVA ENDIF 635 CONTINUE SEGDES MDEFOR 634 CONTINUE GOTO 599 C ****************************MLREEL******************************* 518 CONTINUE GOTO 599 C ****************************MLENTI****************************** 519 CONTINUE GOTO 599 C ****************************MCHARG***************************** 520 CONTINUE ICO1=KCOLA(2) ICO2=KCOLA(18) ICO3=KCOLA(39) ICO4=KCOLA(10) ICO5=KCOLA(1) ICO6=KCOLA(50) DO 650 IEL=M1,M2 MCHARG=ITLAC(IEL) IF (MCHARG.EQ.0) GO TO 650 SEGACT MCHARG DO 651 I=1,KCHARG(/1) ICHARG=KCHARG(I) SEGACT ICHARG*MOD IF(CHATYP.EQ.'CHPOINT ') THEN IVA=ICHPO1 IF(IVA.GT.0) THEN CALL AJOUN(ICO1,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO1=-IVA ENDIF IVA=ICHPO2 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO2=-IVA ENDIF IVA=ICHPO3 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO3=-IVA ENDIF ELSEIF(CHATYP.EQ.'MCHAML ') THEN IVA=ICHPO1 IF(IVA.GT.0) THEN CALL AJOUN(ICO3,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO1=-IVA ENDIF IVA=ICHPO2 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO2=-IVA ENDIF IVA=ICHPO3 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO3=-IVA ENDIF ELSEIF(CHATYP.EQ.'TABLE ') THEN IVA=ICHPO1 IF(IVA.GT.0) THEN CALL AJOUN(ICO4,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO1=-IVA ENDIF IVA=ICHPO2 IF(IVA.GT.0) THEN CALL AJOUN(ICO4,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO2=-IVA ENDIF ELSEIF(CHATYP.EQ.'LISTOBJE') THEN IVA=ICHPO1 IF(IVA.GT.0) THEN CALL AJOUN(ICO6,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO1=-IVA ENDIF IVA=ICHPO2 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO2=-IVA ENDIF ENDIF IF(CHAMOB(I).EQ.'TRAN') THEN IVA=ICHPO4 IF(IVA.GT.0) THEN CALL AJOUN(ICO5,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO4=-IVA ENDIF IVA=ICHPO6 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO6=-IVA ENDIF IVA=ICHPO7 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO7=-IVA ENDIF ELSEIF(CHAMOB(I).EQ.'ROTA') THEN IVA=ICHPO4 IF(IVA.GT.0) THEN CALL AJOUN(ICO5,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO4=-IVA ENDIF IVA=ICHPO5 IF(IVA.GT.0.AND.IDIM.GT.2) THEN CALL AJOUN(ICO5,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO5=-IVA ENDIF IVA=ICHPO6 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO6=-IVA ENDIF IVA=ICHPO7 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO7=-IVA ENDIF ELSEIF(CHAMOB(I).EQ.'TRAJ') THEN IVA=ICHPO4 IF(IVA.GT.0) THEN CALL AJOUN(ICO1,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO4=-IVA ENDIF IVA=ICHPO5 IF(IVA.GT.0) THEN CALL AJOUN(ICO5,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO5=-IVA ENDIF IVA=ICHPO6 IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) ICHPO6=-IVA ENDIF ENDIF SEGDES ICHARG 651 CONTINUE SEGDES MCHARG 650 CONTINUE GOTO 599 C *************************** ***************************** 521 CONTINUE GOTO 599 C ****************************MEVOLL****************************** 522 CONTINUE ICOR=KCOLA(18) ICOM=KCOLA(29) DO 660 IEL=M1,M2 MEVOLL=ITLAC(IEL) IF (MEVOLL.EQ.0) GO TO 660 SEGACT MEVOLL DO 661 I=1,IEVOLL(/1) KEVOLL=IEVOLL(I) SEGACT KEVOLL*MOD IVA=IPROGX ICO2=ICOR IF(IONIVE.GE.3) THEN IF(TYPX.EQ.'LISTMOTS') THEN ICO2=ICOM ELSEIF(TYPX.EQ.'LISTREEL')THEN ICO2=ICOR ENDIF ENDIF IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IPROGX=-IVA ENDIF IVA=IPROGY IF(IONIVE.GE.3) THEN IF(TYPY.EQ.'LISTMOTS') THEN ICO2=ICOM ELSEIF(TYPY.EQ.'LISTREEL')THEN ICO2=ICOR ENDIF ENDIF IF(IVA.GT.0) THEN CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IPROGY=-IVA ENDIF SEGDES KEVOLL 661 CONTINUE SEGDES MEVOLL 660 CONTINUE GOTO 599 C **********************SUPERELE************************************ 523 CONTINUE ICO1=KCOLA(1) ICO3=KCOLA(3) ICO2=KCOLA( 2) ICO16=KCOLA(16) DO 5230 IEL=M1,M2 MSUPER=ITLAC(IEL) IF (MSUPER.EQ.0) GO TO 5230 SEGACT MSUPER*MOD IVA=MRIGTO CALL AJOUN(ICO3,IVA,ILISSE,iun) IF(IIICHA.EQ.1)MRIGTO=IVA IVA=MSUPEL CALL AJOUN(ICO1,IVA,ILISSE,iun) IF(IIICHA.EQ.1)MSUPEL=IVA IVA=MSURAI CALL AJOUN(ICO3,IVA,ILISSE,iun) IF(IIICHA.EQ.1)MSURAI=IVA IVA=MSUMAS IF(IVA.NE.0) CALL AJOUN(ICO3,IVA,ILISSE,iun) IF(IIICHA.EQ.1)MSUMAS=IVA IVA=MCROUT if (mcrout.ne.0) then CALL AJOUN(ICO16,IVA,ILISSE,iun) IF(IIICHA.EQ.1)MCROUT=IVA endif c NBINMA=MSUPCH(/1) c DO 5231 I=1,NBINMA c IVA=MSUPCH(I) c CALL AJOUN(ICO2,IVA) c IF(IIICHA.EQ.1)MSUPCH(I)=IVA c 5231 CONTINUE SEGDES MSUPER 5230 CONTINUE GOTO 599 C **********************LOGIQUE*********************************** 524 CONTINUE GOTO 599 C **********************FLOTTANT********************************** 525 CONTINUE GOTO 599 C ********************** ENTIER ********************************** 526 CONTINUE GOTO 599 C ********************** MOT *********************************** 527 CONTINUE GOTO 599 C ********************** TEXTE *********************************** 528 CONTINUE GOTO 599 C ********************** LISTMOTS********************************* 529 CONTINUE GOTO 599 C ********************** VECTEUR********************************** 530 CONTINUE ICO1=KCOLA(1) ICO2=KCOLA( 2) DO 5300 IEL=M1,M2 MVECTE=ITLAC(IEL) IF (MVECTE.EQ.0) GO TO 5300 SEGACT MVECTE*MOD NVEC=ICHPO(/1) DO 5301 I=1,NVEC * CE POINTEUR N'EST PAS ACTUELLEMENT REMPLI * IVA=IGEOV(I) * CALL AJOUN(ICO1,IVA) * IF(IIICHA.EQ.1)IGEOV(I)=IVA IVA=ICHPO(I) CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1)ICHPO(I)=IVA 5301 CONTINUE SEGDES MVECTE 5300 CONTINUE GOTO 599 C ********************** VECTDOUB********************************* 531 CONTINUE GOTO 599 C ********************** POINT ********************************* 532 CONTINUE GOTO 599 C ********************** CONFIG ********************************* 533 CONTINUE GOTO 599 C *********************** LISTCHPO ****************************** 534 CONTINUE ICO2=KCOLA(2) DO 340 IEL=M1,M2 MLCHPO =ITLAC(IEL) IF (MLCHPO.EQ.0) GO TO 340 SEGACT MLCHPO*MOD N1=ICHPOI(/1) DO 341 I=1,N1 IVA=ICHPOI(I) CALL AJOUN(ICO2,IVA,ILISSE,iun) IF(IIICHA.EQ.1)ICHPOI(I)=IVA 341 CONTINUE SEGDES MLCHPO 340 CONTINUE GO TO 599 C ************************** BASEM ******************************** 535 CONTINUE ICO12=KCOLA(12) ICO8=KCOLA(8 ) ICO15=KCOLA(15) DO 350 IEL=M1,M2 MBASEM=ITLAC(IEL) IF (MBASEM.EQ.0) GO TO 350 SEGACT MBASEM DO 351 I=1,LISBAS(/1) MSOBAS=LISBAS(I) SEGACT MSOBAS*MOD IVA=IBSTRM(1) IF(IVA.GT.0) THEN CALL AJOUN(ICO12,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IBSTRM(1)=-IVA ENDIF IVA=IBSTRM(2) IF(IVA.GT.0) THEN CALL AJOUN(ICO8,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IBSTRM(2)=-IVA ENDIF IVA=IBSTRM(3) IF (IVA.EQ.0) GOTO 352 IF(IVA.GT.0) THEN CALL AJOUN(ICO8,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IBSTRM(3)=-IVA ENDIF 352 CONTINUE IVA=IBSTRM(4) IF (IVA.EQ.0) GOTO 353 IF(IVA.GT.0) THEN CALL AJOUN(ICO15,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IBSTRM(4)=-IVA ENDIF 353 CONTINUE IVA=IBSTRM(5) IF (IVA.EQ.0) GOTO 354 IF(IVA.GT.0) THEN CALL AJOUN(ICO8,IVA,ILISSE,iun) IF(IIICHA.EQ.1) IBSTRM(5)=-IVA ENDIF 354 CONTINUE SEGDES MSOBAS 351 CONTINUE SEGDES MBASEM 350 CONTINUE GOTO 599 C ************************* PROCEDURE **************************** * On ajoute les objets en cours de retour (entre respro et finpro) * on va les chercher dans les segments de resultats du bloc * sous jacent a la procedure * 536 CONTINUE ** write(6,*) ' exploration bloc ',m1,m2 MTTRY=MTXBL ITLACC=KCOLA(36) ITLAC1=KCOLA(37) IF (ITLAC(/1).EQ.0) GOTO 599 DO 5270 IEL=M1,M2 MBLA1=ITLAC(IEL) MBLO1=IPIPR1(MBLA1) IF (MBLO1.LE.0) GO TO 5270 ** write(6,*) ' bloc dans procedur ',mblo1 SEGACT MBLO1 iargum=mblo1.margum segact iargum mtresu=itresu if (mtresu.eq.0) goto 5270 segact mtresu do 5271 ires=1,NRESI ityp1=mtyres(ires) iva =ivares(ires) call typfil(ityp1,j) if (j.le.0) goto 5271 ICO2=KCOLA(J) NUMLIS=1 ilissd=ilissg IF(J.EQ.24) NUMLIS=6 IF(J.EQ.25) then NUMLIS=3 ilissd=ilissf ENDIF IF(J.EQ.26) then if (ionive.le.20) then NUMLIS=2 else goto 5271 endif ENDIF IF(J.EQ.27) NUMLIS=5 IF(J.EQ.32) then NUMLIS=3 ilissd=ilissp endif IF(J.EQ.36) NUMLIS=7 IF(J.EQ.45) NUMLIS=5 CALL AJOUN (ICO2,IVA,ILISSd,NUMLIS) 5271 CONTINUE 5270 CONTINUE GO TO 599 C ************************ BLOC ******************************** 537 CONTINUE ICO50=KCOLA(50) IF (ITLAC(/1).EQ.0) GOTO 599 DO 5370 IEL=M1,M2 MBLO1=ITLAC(IEL) IF(MBLO1.LE.0) goto 5370 segact mblo1*mod if (mblo1.mbenum.ne.0) then iva=mblo1.mbenum ** write(6,*) 'ajout de iva ',iva if (iva.gt.0) then CALL AJOUN(ICO50,IVA,ILISSE,iun) IF (IIICHA.EQ.1) mblo1.mbenum =-IVA endif endif 5370 continue goto 599 C ************************ MMODEL ******************************** 538 CONTINUE ICO1 = KCOLA( 1) ICO10 = KCOLA(10) ICO29 = KCOLA(29) ICO40 = kcola(40) DO 5380 IEL=M1,M2 MMODEL = ITLAC(IEL) IF (MMODEL.EQ.0) GOTO 5380 SEGACT,MMODEL DO 5385 I=1,KMODEL(/1) IMODEL = KMODEL(I) SEGACT,IMODEL*MOD IVA = IMAMOD IF(IVA.GT.0) THEN CALL AJOUN(ICO1,IVA,ILISSE,iun) IF (IIICHA.EQ.1) IMAMOD =-IVA ENDIF IVA = IPDPGE IF(IVA.GT.0) THEN CALL AJOUN(ICO1,IVA,ILISSE,iun) IF (IIICHA.EQ.1) IPDPGE =-IVA ENDIF C cas 'NAVIER_STOKES' : INFMOD(2) contient une table NFOR=FORMOD(/2) IF (NFOR.GT.0) THEN IF ((FORMOD(1).EQ.'NAVIER_STOKES').OR. * (FORMOD(1).EQ.'DARCY').OR. * (FORMOD(1).EQ.'EULER')) THEN MN3=INFMOD(/1) IF (MN3.GT.1) THEN IVA=INFMOD(2) IF(IVA.GT.0) THEN CALL AJOUN(ICO10,IVA,ILISSE,iun) IF (IIICHA.EQ.1) INFMOD(2) =-IVA ENDIF ENDIF ENDIF ENDIF NM3=INFMOD(/1) DO IOU=3,NM3 IVA=INFMOD(IOU) IF(IVA.gt.0) then IF(IOU.EQ.14) THEN CALL AJOUN(ICO29,IVA,ilisse,iun) ELSE CALL AJOUN(ICO40,IVA,ilisse,iun) ENDIF IF(IIICHA.EQ.1) INFMOD(IOU)=-IVA ENDIF ENDDO IF(tymode(/2). ne . 0) then do 5387 ihy=1,tymode(/2) ITYP1=tymode(ihy) IVA=IVAMOD(ihy) J=0 if( iva.lt.0) go to 5387 CALL TYPFIL (ITYP1,J) IF(J.LE.0) then MOTERR(1:8)=ITYP1 call erreur(336) ENDIF IF(j.le.0.or.j.eq.32) GO TO 5387 ICO2=KCOLA(J) NUMLIS=1 ilissd=ilissg IF(J.EQ.24) NUMLIS=6 IF(J.EQ.25) then NUMLIS=3 ilissd=ilissf ENDIF IF(J.EQ.26) NUMLIS=2 IF(J.EQ.27) NUMLIS=5 IF(J.EQ.32) then NUMLIS=3 ilissd=ilissp endif IF(J.EQ.36) NUMLIS=7 IF(J.EQ.45) NUMLIS=5 CALL AJOUN (ICO2,IVA,ILISSd,NUMLIS) IF(IIICHA.EQ.1)IVAMOD(ihy) =-IVA 5387 continue endif SEGDES,IMODEL 5385 CONTINUE SEGDES,MMODEL 5380 CONTINUE GOTO 599 C ************************ MCHAML ******************************** 539 CONTINUE CALL EXCHAM(ICOLAC,ITLACC,M1,M2,IIICHA) GOTO 599 C ************************ MINTE ******************************** 540 CONTINUE GOTO 599 C ************************ NUAGE ******************************** 541 CONTINUE DO 810 IEL=M1,M2 MNUAGE=ITLAC(IEL) IF (MNUAGE.EQ.0) GO TO 810 SEGACT MNUAGE L6=NUAPOI(/1) IF (L6.EQ.0) GO TO 813 DO 811 K=1,L6 ITYP1=NUATYP(K) ISIN=NUAPOI(K) J=0 IF(ITYP1.EQ.'FLOTTANT'.OR.ITYP1.EQ.'ENTIER '.OR. $ ITYP1.EQ.'MOT '.OR.ITYP1.EQ.'LOGIQUE ') GO TO 811 CALL TYPFIL (ITYP1,J) IF(J.LE.0) GO TO 811 ICO2=KCOLA(J) NUMLIS=1 ilissd=ilissg IF(J.EQ.32) then NUMLIS=3 ilissd=ilissp endif IF(J.EQ.36) NUMLIS=7 IF(J.EQ.45) NUMLIS=5 NUAVIN=ISIN SEGACT NUAVIN*MOD DO 816 LL =1,NUAINT(/1) IVA=NUAINT(LL) CALL AJOUN (ICO2,IVA,ILISSd,NUMLIS) IF(IIICHA.EQ.1) NUAINT(LL)=IVA 816 CONTINUE SEGDES NUAVIN 811 CONTINUE 813 SEGDES MNUAGE 810 CONTINUE GO TO 599 C **************************** MATRAK ****************************** 542 CONTINUE C ICO1=KCOLA(1) CALL EXAMTK (ICOLAC,ITLACC,M1,M2,IIICHA) GO TO 599 C **************************** MATRIK ****************************** 543 CONTINUE C ICO1=KCOLA(1) CALL EXANTK (ICOLAC,ITLACC,M1,M2,IIICHA) GO TO 599 C ****************************** METHODE *************************** 545 CONTINUE ICO1=KCOLA(27) DO 5450 IEL=M1,M2 IVA = ITLAC(IEL) CALL AJOUN(ICO1,IVA,ILISSE,icinq) IF(IIICHA.EQ.1) ITLAC (IEL) = IVA 5450 CONTINUE GO TO 599 C ****************************** ESCLAVE *************************** 546 CONTINUE DO 5460 IEL=M1,M2 mesres=itlac(iel) segact mesres if (.not.loremp) goto 5460 ityp1=esrety k=0 call typfil(ityp1,k) if (k.le.0) goto 5460 if (k.eq.24) goto 5460 if (k.eq.25) goto 5460 if (k.eq.26) goto 5460 if (k.eq.27) goto 5460 ico1=kcola(k) iva=esreva NUMLIS=1 ilissd=ilissg IF(J.EQ.32) then NUMLIS=3 ilissd=ilissp endif IF(k.EQ.36) NUMLIS=7 IF(K.EQ.45) NUMLIS=5 * write (6,*) ' expill esclave renvoie sur ',ityp1,iva call ajoun(ico1,iva,ilissd,numlis) segdes mesres 5460 continue C JYY print*, ' passage ESCLAVE dans expil' GO TO 599 C ***************************** FANTOME **************************** 547 CONTINUE GO TO 599 C ***************************** IELVAL ***************************** 548 CONTINUE GO TO 599 C ***************************** ANNOTATI *************************** 549 CONTINUE ico49=kcola(49) ico1 =kcola(1) DO 5490 IEL=M1,M2 iva=itlac(iel) call ajoun(ico49,iva,ilisse,iun) MANNOT=itlac(iel) SEGACT,MANNOT NBANNO = MANNOT.ICLAS(/1) DO IANO=1,NBANNO IF(MANNOT.ICLAS(IANO) .EQ. 2)THEN METIQU = MANNOT.ISEGT(IANO) SEGACT,METIQU*MOD iva2 = METIQU.INUPT IF(iva2.GT.0) THEN CALL AJOUN(ico1,iva2,ILISSE,iun) IF (IIICHA.EQ.1) METIQU.INUPT =-iva2 ENDIF SEGDES,METIQU ENDIF ENDDO 5490 continue GO TO 599 C ***************************** LISTOBJE *************************** 550 CONTINUE DO 5500 IEL=M1,M2 MLOBJE = ITLAC(IEL) IF (MLOBJE.EQ.0) GOTO 5500 SEGACT, MLOBJE*MOD NBOB1 = LISOBJ(/1) IF (NBOB1.LE.0) GOTO 5500 IF (TYPOBJ.EQ.'ESCLAVE') THEN C write(6,*) 'EXPIL : traitement listobje esclave' lotemp=lodesl lodesl=.false. CALL ECROBJ('LISTOBJE',MLOBJE) CALL LIRABJ('LISTOBJE',IPLOBJ,1,IRET) lodesl=lotemp IF (IERR.NE.0) RETURN C write(6,*) 'EXPIL : MLOBJE,IPLOBJ=',MLOBJE,IPLOBJ IF (IPLOBJ.NE.MLOBJE) THEN CALL ERREUR(5) RETURN ENDIF ** IF (TYPOBJ.EQ.'ESCLAVE') THEN ** CALL ERREUR(5) ** RETURN ** ENDIF SEGACT MLOBJE*MOD ENDIF ITYP1 = TYPOBJ CALL TYPFIL(ITYP1,J) IF (J.LE.0) GOTO 5500 ICO1 = KCOLA(J) DO 5501 IL=1,NBOB1 IVA = LISOBJ(IL) NUMLIS = 1 ILISSD = ILISSG IF (J.EQ.24) NUMLIS=6 IF (J.EQ.25) THEN NUMLIS = 3 ILISSD = ILISSF ENDIF IF (J.EQ.26) THEN NUMLIS = 2 ENDIF IF (J.EQ.27) NUMLIS=5 IF (J.EQ.32) THEN NUMLIS = 3 ILISSD = ILISSP ENDIF IF (J.EQ.36) NUMLIS = 7 IF (J.EQ.45) NUMLIS = 5 CALL AJOUN(ICO1,IVA,ILISSD,NUMLIS) IF(IIICHA.EQ.1) LISOBJ(IL) = IVA 5501 CONTINUE SEGDES, MLOBJE 5500 CONTINUE GO TO 599 599 CONTINUE SEGDES ICOLAC RETURN END