1 : C REMPIL SOURCE CHAT 09/01/19 21:15:01 6261 2 : C SI DANS LA PILE UNE TTABLE EST SUIVI PAR UN DE SES INDICE ALORS ON 3 : C REMPLACE L'INDICE PAR LA VALEUR ET ON DIT AVOIR DEJA LU LA TABLE 4 : C I EST LE RANG DE LA TABLE DANS LA PILE INTERMEDIAIRE 5 : C IL FAUT QUE LA TABLE SOIT SUIVI D'UN SEPARATEUR PUIS DE L'INDICE 6 : C ISUCC INDIQUE PAR 1 QUE L'ON A TROUVE UN INDICE 7 : C en entree ISUCC=2 si on a rencontre la syntaxe : % titi c'est 8 : C a dire qu' il faut mettre devant l'objet qui est dans mobjco 9 : C (segment mbloc) 10 : SUBROUTINE REMPIL(I,ISUCC) 11 : IMPLICIT INTEGER(I-N) 12 : EXTERNAL LONG 13 : -INC CCNOYAU 14 : -INC CCOPTIO 15 : -INC SMTABLE 16 : -INC SMBLOC 17 : -INC SMCOORD 18 : -INC CCASSIS 19 : REAL*8 XXVA,XER,CRIT,CRAT 20 : CHARACTER*(8) INDIC1 ,TYPOBJ ,MOTYP,CHARRE 21 : CHARACTER*26 ICHA 22 : CHARACTER*72 MOTASS 23 : LOGICAL IBOOL 24 : LOGICAL LOMISA,ILOREMP 25 : nth=0 25 : if (nbesc.ne.0) call ooonth(nth) 26 : * write(6,*) ' nth nbesc ', nth,nbesc 27 : if(nbesc.ne.0) segact ipiloc 28 : IMETH=ISUCC 29 : ISUCC=0 30 : CRIT = 1.D0 / 3.D0 31 : CRAT =ABS( CRIT * 3.D0 - 1.d0 )* 1000. 32 : MTABLE=JPOOB4(I) 33 : I1=I+1 34 : I2=I+2 35 : IF(IMETH.EQ.2) THEN 36 : I1=I 37 : I2=I+1 38 : MTABLE=MOBJCO 39 : * write(6,*) ' rempil imeth mobjco', imeth,mobjco 40 : IF(MOBJCO.EQ.0) THEN 40 : CALL ERREUR(863) 41 : RETURN 42 : ENDIF 43 : ENDIF 44 : INDIC1=JTYOBJ(I1) 45 : * TEST DE LA PRESENCE D'UN SEPARATEUR SINON RETOUR 46 : 47 : IF(INDIC1.NE.'SEPARATE'.AND.INDIC1.NE.'METHODOL') RETURN 48 : ICAS=1 49 : IF(INDIC1.EQ.'METHODOL') ICAS=2 50 : IF(I1.EQ.IHPILE) RETURN 51 : * write(6,*) ' rempil icas ',icas 52 : INDIC1=JTYOBJ(I2) 53 : INDIC2=JPOOB4(I2) 54 : IF(ICAS.EQ.2.AND.IMETH.EQ.1) THEN 55 : * le type est methode et l'a valeur pointe sur la chaine du nom 56 : INDIC1='METHODE ' 57 : INDIC2=INOOB1(JPOOB2(I2)) 58 : * write(6,*) ' rempil 1 indic2', indic2 59 : IF(JTYOBJ(I2).EQ.'MOT ') THEN 60 : INDIC2 = JPOOB4(I2) 61 : * write(6,*) ' rempil 2 indic2', indic2 62 : ENDIF 63 : ENDIF 64 : * if(icas.eq.2) then 65 : * write(6,*) ' type indice , valeur',indic1,indic2 66 : * endif 67 : SEGACT MTABLE 68 : NB=MLOTAB 69 : IF(NB.EQ.0) GO TO 15 70 : TYPOBJ=' ' 71 : MOTYP='MOT' 71 : CALL ACCTAB(MTABLE,MOTYP,IVAL,XER,'SOUSTYPE',IBOOL 72 : $ ,IOBJ,TYPOBJ,IVALRE,XER,CHARRE,IBOOL,IOBRE) 73 : IBOOL=.FALSE. 74 : IF(TYPOBJ.EQ.'MOT '.AND.CHARRE.EQ.'RESULTAT') 75 : $ IBOOL=.TRUE. 76 : C creation de indic3 pour aider l'optimiseur 77 : if(nbesc.ne.0) segact ipiloc 78 : INDIC3=MIN(INDIC2,XIFLOT(/1)) 79 : SEGACT MTABLE 80 : 81 : DO 10 IJ=1,NB 82 : * if( icas.eq.2) then 83 : * write(6,*) ' rempilindicetypevaleur',MTABTI(IJ),MTABII(IJ) 84 : * endif 85 : IF(MTABTI(IJ).NE.'METHODE') THEN 86 : IF (INDIC1.NE.MTABTI(IJ)) GOTO 10 87 : ELSE 88 : IF(INDIC1.NE.'MOT '.AND.INDIC1.NE.'METHODE') GO TO 10 89 : ENDIF 90 : IF (INDIC1.NE.'FLOTTANT') THEN 91 : IF (INDIC2.NE.MTABII(IJ)) GOTO 10 92 : ELSE 93 : IF (IBOOL) THEN 94 : XER=ABS((XIFLOT(INDIC3)-RMTABI(IJ))/ 95 : $ (ABS(XIFLOT(INDIC3))+MAX(1.D-20 ,ABS(XIFLOT(INDIC3)) 96 : $ )/ 1.D15)) 97 : * $ XIFLOT(INDIC2),RMTABI(IJ), XER 98 : IF(XER. GT . CRAT ) GO TO 10 99 : ELSE 100 : IF (XIFLOT(INDIC3).NE.RMTABI(IJ)) GOTO 10 101 : ENDIF 102 : ENDIF 103 : * if(icas.eq.2) write(6,*) 'rempil on a trouve' 104 : GOTO 20 105 : 10 CONTINUE 106 : 15 CONTINUE 107 : * PAS D'INDICE CORRECT ON FAIT UNE ERREUR 108 : IF(IMETH.EQ.2.AND.ICAS.EQ.2) THEN 109 : I3=I1 110 : ISUCC=1 111 : JTYOBJ(I3)='TABLE ' 112 : JPOOB4(I3)=MOBJCO 113 : if(nbesc.ne.0) segdes ipiloc 114 : return 115 : ELSE 116 : MOTERR=' ' 117 : IF ( INDIC1.EQ.'FLOTTANT') THEN 118 : REAERR(1)= XIFLOT(INDIC2) 118 : CALL ERREUR ( 534) 119 : 120 : ELSEIF (INDIC1.EQ.'MOT ') THEN 121 : CCC ** SI ON NE TROUVE PAS UN MOT ON CHERCHE S'IL N'Y A PAS LE MEME 122 : CCC MOT SANS LES BLANCS A LA FIN DU MOT 123 : * write(6,*) ' indic2' ,indic2 124 : * write(6,*) ' longueur de ipchar' , ipchar(/1) 125 : * write(6,*) ( ipchar (iou),iou=1,ipchar(/1)) 126 : IOD = IPCHAR(INDIC2 ) 127 : * write(6,*) ' iod ' , iod 128 : IOF= IPCHAR(INDIC2+1) 129 : 130 : IL2= LONG(ICHARA(IOD:IOF-1))+IOD-1 131 : DO 30 IJ=1,NB 132 : IP=MTABII(IJ) 133 : ID=IPCHAR(IP) 134 : IFI=IPCHAR(IP+1) 135 : IL1= LONG(ICHARA(ID:IFI-1))+ID-1 136 : IF(ICHARA(ID:IL1).EQ.ICHARA(IOD:IL2)) GO TO 20 137 : 30 CONTINUE 138 : IOM = MAX ( 8, IOF -IOD ) 139 : MOTERR(1:IOM)=ICHARA(IOD:IOF-1) 140 : IF(IOF-IOD.GT.8) MOTERR(9:11) = '...' 140 : CALL ERREUR (535) 141 : ELSE 142 : IF(ICAS.EQ.1) THEN 143 : MOTERR(1:8) = INDIC1 144 : INTERR(1)= INDIC2 144 : CALL ERREUR (171) 145 : ELSEIF(ICAS.EQ.2) THEN 146 : IF(IMETH.EQ.1) THEN 146 : CALL ERREUR(864) 147 : ELSE 147 : CALL ERREUR(865) 148 : ENDIF 149 : ENDIF 150 : ENDIF 151 : ENDIF 152 : IF(nbesc.ne.0) segdes ipiloc 153 : RETURN 154 : 20 CONTINUE 155 : * ON A TROUVE UN INDICE * si icas=2 et imeth=1 il faut tester que a vale 156 : * est bien un mot ou une procedur 157 : segact mtable*mod 158 : if( nbesc.ne.0) segdes ipiloc 159 : I3=I2 160 : ISUCC=1 161 : INDIC1=MTABTV(IJ) 162 : JTYOBJ(I3)=INDIC1 163 : JPOOB2(I3)=0 164 : if (indic1.eq.'ESCLAVE ') then 165 : LOMISA = .FALSE. 166 : if (.not.lodesl.or.nth.ne.0) lomisa =.true. 167 : mesres=MTABIV(IJ) 168 : if (iimpi .eq. 1234) write(ioimp,*) 169 : & 'un objet (ESCLAVE) de la table est utilisé',mesres 170 : C * mise a jour eventuelle et menage eventuel 171 : IF ( LOMISA ) THEN 172 : SEGACT MESRES 173 : NESRES = IESRES 174 : segdes mcoord 175 : segact nesres 176 : if (.not.loremp) then 177 : 5 continue 178 : segdes nesres*record 179 : segdes mesres 180 : SEGACT NESRES*(ECR=1,MOD) 181 : segact mesres 182 : if (.not.loremp) then 183 : * write(6,*) ' loremp pas vrai dans rempil ' 184 : goto 5 185 : endif 186 : endif 187 : segdes mesres 188 : segact mcoord 189 : if (iimpi .eq. 1234) 190 : & write(ioimp,*) 'le segment a ete mis a jour ',MESRES 191 : indic1=esrety 192 : JTYOBJ(I3)=INDIC1 192 : call tabesc(mtable,ij,nesres) 193 : C * menage eventuel 194 : SEGDES MESRES 195 : SEGDES NESRES*RECORD 196 : END IF 197 : endif 198 : IF(IMETH.EQ.1.AND.ICAS.EQ.2) THEN 199 : IF(INDIC1.NE.'MOT '.AND. INDIC1.NE.'PROCEDUR') THEN 200 : ISUCC=0 201 : if(nbesc.ne.0) segdes ipiloc 202 : RETURN 203 : ENDIF 204 : ENDIF 205 : IF (INDIC1.NE.'FLOTTANT') THEN 206 : JPOOB4(I3)=MTABIV(IJ) 207 : ELSE 208 : * SYNTONISER LA VALEUR AVEC LA PILE DES FLOTTANTS 209 : XXVA=RMTABV(IJ) 209 : call posree(xxva,iplac) 210 : JPOOB4(I3)=IPLAC 211 : ENDIF 212 : SEGDES MTABLE 213 : IF(ICAS.EQ.1) JPOOB1(I)=.FALSE. 214 : JPOOB1(I1)=.FALSE. 215 : IF(IMETH.EQ.2.AND.INDIC1.EQ.'PROCEDUR') THEN 216 : * on place l'objet mobjco dans la pile a la place du % 217 : * write(6,*) 'rempil on vient de trouver %procedur' 218 : JPOOB1(I1)=.TRUE. 219 : JPOOB4(I1)=MOBJCO 220 : JTYOBJ(I1) = 'OBJET ' 221 : ENDIF 222 : if(nbesc.ne.0) segdes ipiloc 223 : RETURN 224 : END 225 : 226 : 227 : 228 :
© Cast3M 2003 - All rights reserved.
Disclaimer