C REMPIL SOURCE CHAT 09/01/19 21:15:01 6261 C SI DANS LA PILE UNE TTABLE EST SUIVI PAR UN DE SES INDICE ALORS ON C REMPLACE L'INDICE PAR LA VALEUR ET ON DIT AVOIR DEJA LU LA TABLE C I EST LE RANG DE LA TABLE DANS LA PILE INTERMEDIAIRE C IL FAUT QUE LA TABLE SOIT SUIVI D'UN SEPARATEUR PUIS DE L'INDICE C ISUCC INDIQUE PAR 1 QUE L'ON A TROUVE UN INDICE C en entree ISUCC=2 si on a rencontre la syntaxe : % titi c'est C a dire qu' il faut mettre devant l'objet qui est dans mobjco C (segment mbloc) SUBROUTINE REMPIL(I,ISUCC) IMPLICIT INTEGER(I-N) EXTERNAL LONG -INC CCNOYAU -INC CCOPTIO -INC SMTABLE -INC SMBLOC -INC SMCOORD -INC CCASSIS REAL*8 XXVA,XER,CRIT,CRAT CHARACTER*(8) INDIC1 ,TYPOBJ ,MOTYP,CHARRE CHARACTER*26 ICHA CHARACTER*72 MOTASS LOGICAL IBOOL LOGICAL LOMISA,ILOREMP nth=0 if (nbesc.ne.0) call ooonth(nth) * write(6,*) ' nth nbesc ', nth,nbesc if(nbesc.ne.0) segact ipiloc IMETH=ISUCC ISUCC=0 CRIT = 1.D0 / 3.D0 CRAT =ABS( CRIT * 3.D0 - 1.d0 )* 1000. MTABLE=JPOOB4(I) I1=I+1 I2=I+2 IF(IMETH.EQ.2) THEN I1=I I2=I+1 MTABLE=MOBJCO * write(6,*) ' rempil imeth mobjco', imeth,mobjco IF(MOBJCO.EQ.0) THEN CALL ERREUR(863) RETURN ENDIF ENDIF INDIC1=JTYOBJ(I1) * TEST DE LA PRESENCE D'UN SEPARATEUR SINON RETOUR IF(INDIC1.NE.'SEPARATE'.AND.INDIC1.NE.'METHODOL') RETURN ICAS=1 IF(INDIC1.EQ.'METHODOL') ICAS=2 IF(I1.EQ.IHPILE) RETURN * write(6,*) ' rempil icas ',icas INDIC1=JTYOBJ(I2) INDIC2=JPOOB4(I2) IF(ICAS.EQ.2.AND.IMETH.EQ.1) THEN * le type est methode et l'a valeur pointe sur la chaine du nom INDIC1='METHODE ' INDIC2=INOOB1(JPOOB2(I2)) * write(6,*) ' rempil 1 indic2', indic2 IF(JTYOBJ(I2).EQ.'MOT ') THEN INDIC2 = JPOOB4(I2) * write(6,*) ' rempil 2 indic2', indic2 ENDIF ENDIF * if(icas.eq.2) then * write(6,*) ' type indice , valeur',indic1,indic2 * endif SEGACT MTABLE NB=MLOTAB IF(NB.EQ.0) GO TO 15 TYPOBJ=' ' MOTYP='MOT' CALL ACCTAB(MTABLE,MOTYP,IVAL,XER,'SOUSTYPE',IBOOL $ ,IOBJ,TYPOBJ,IVALRE,XER,CHARRE,IBOOL,IOBRE) IBOOL=.FALSE. IF(TYPOBJ.EQ.'MOT '.AND.CHARRE.EQ.'RESULTAT') $ IBOOL=.TRUE. C creation de indic3 pour aider l'optimiseur if(nbesc.ne.0) segact ipiloc INDIC3=MIN(INDIC2,XIFLOT(/1)) SEGACT MTABLE DO 10 IJ=1,NB * if( icas.eq.2) then * write(6,*) ' rempilindicetypevaleur',MTABTI(IJ),MTABII(IJ) * endif IF(MTABTI(IJ).NE.'METHODE') THEN IF (INDIC1.NE.MTABTI(IJ)) GOTO 10 ELSE IF(INDIC1.NE.'MOT '.AND.INDIC1.NE.'METHODE') GO TO 10 ENDIF IF (INDIC1.NE.'FLOTTANT') THEN IF (INDIC2.NE.MTABII(IJ)) GOTO 10 ELSE IF (IBOOL) THEN XER=ABS((XIFLOT(INDIC3)-RMTABI(IJ))/ $ (ABS(XIFLOT(INDIC3))+MAX(1.D-20 ,ABS(XIFLOT(INDIC3)) $ )/ 1.D15)) * $ XIFLOT(INDIC2),RMTABI(IJ), XER IF(XER. GT . CRAT ) GO TO 10 ELSE IF (XIFLOT(INDIC3).NE.RMTABI(IJ)) GOTO 10 ENDIF ENDIF * if(icas.eq.2) write(6,*) 'rempil on a trouve' GOTO 20 10 CONTINUE 15 CONTINUE * PAS D'INDICE CORRECT ON FAIT UNE ERREUR IF(IMETH.EQ.2.AND.ICAS.EQ.2) THEN I3=I1 ISUCC=1 JTYOBJ(I3)='TABLE ' JPOOB4(I3)=MOBJCO if(nbesc.ne.0) segdes ipiloc return ELSE MOTERR=' ' IF ( INDIC1.EQ.'FLOTTANT') THEN REAERR(1)= XIFLOT(INDIC2) CALL ERREUR ( 534) ELSEIF (INDIC1.EQ.'MOT ') THEN CCC ** SI ON NE TROUVE PAS UN MOT ON CHERCHE S'IL N'Y A PAS LE MEME CCC MOT SANS LES BLANCS A LA FIN DU MOT * write(6,*) ' indic2' ,indic2 * write(6,*) ' longueur de ipchar' , ipchar(/1) * write(6,*) ( ipchar (iou),iou=1,ipchar(/1)) IOD = IPCHAR(INDIC2 ) * write(6,*) ' iod ' , iod IOF= IPCHAR(INDIC2+1) IL2= LONG(ICHARA(IOD:IOF-1))+IOD-1 DO 30 IJ=1,NB IP=MTABII(IJ) ID=IPCHAR(IP) IFI=IPCHAR(IP+1) IL1= LONG(ICHARA(ID:IFI-1))+ID-1 IF(ICHARA(ID:IL1).EQ.ICHARA(IOD:IL2)) GO TO 20 30 CONTINUE IOM = MAX ( 8, IOF -IOD ) MOTERR(1:IOM)=ICHARA(IOD:IOF-1) IF(IOF-IOD.GT.8) MOTERR(9:11) = '...' CALL ERREUR (535) ELSE IF(ICAS.EQ.1) THEN MOTERR(1:8) = INDIC1 INTERR(1)= INDIC2 CALL ERREUR (171) ELSEIF(ICAS.EQ.2) THEN IF(IMETH.EQ.1) THEN CALL ERREUR(864) ELSE CALL ERREUR(865) ENDIF ENDIF ENDIF ENDIF IF(nbesc.ne.0) segdes ipiloc RETURN 20 CONTINUE * ON A TROUVE UN INDICE * si icas=2 et imeth=1 il faut tester que a vale * est bien un mot ou une procedur segact mtable*mod if( nbesc.ne.0) segdes ipiloc I3=I2 ISUCC=1 INDIC1=MTABTV(IJ) JTYOBJ(I3)=INDIC1 JPOOB2(I3)=0 if (indic1.eq.'ESCLAVE ') then LOMISA = .FALSE. if (.not.lodesl.or.nth.ne.0) lomisa =.true. mesres=MTABIV(IJ) if (iimpi .eq. 1234) write(ioimp,*) & 'un objet (ESCLAVE) de la table est utilisé',mesres C * mise a jour eventuelle et menage eventuel IF ( LOMISA ) THEN SEGACT MESRES NESRES = IESRES segdes mcoord segact nesres if (.not.loremp) then 5 continue segdes nesres*record segdes mesres SEGACT NESRES*(ECR=1,MOD) segact mesres if (.not.loremp) then * write(6,*) ' loremp pas vrai dans rempil ' goto 5 endif endif segdes mesres segact mcoord if (iimpi .eq. 1234) & write(ioimp,*) 'le segment a ete mis a jour ',MESRES indic1=esrety JTYOBJ(I3)=INDIC1 call tabesc(mtable,ij,nesres) C * menage eventuel SEGDES MESRES SEGDES NESRES*RECORD END IF endif IF(IMETH.EQ.1.AND.ICAS.EQ.2) THEN IF(INDIC1.NE.'MOT '.AND. INDIC1.NE.'PROCEDUR') THEN ISUCC=0 if(nbesc.ne.0) segdes ipiloc RETURN ENDIF ENDIF IF (INDIC1.NE.'FLOTTANT') THEN JPOOB4(I3)=MTABIV(IJ) ELSE * SYNTONISER LA VALEUR AVEC LA PILE DES FLOTTANTS XXVA=RMTABV(IJ) call posree(xxva,iplac) JPOOB4(I3)=IPLAC ENDIF SEGDES MTABLE IF(ICAS.EQ.1) JPOOB1(I)=.FALSE. JPOOB1(I1)=.FALSE. IF(IMETH.EQ.2.AND.INDIC1.EQ.'PROCEDUR') THEN * on place l'objet mobjco dans la pile a la place du % * write(6,*) 'rempil on vient de trouver %procedur' JPOOB1(I1)=.TRUE. JPOOB4(I1)=MOBJCO JTYOBJ(I1) = 'OBJET ' ENDIF if(nbesc.ne.0) segdes ipiloc RETURN END