1 : C CQUOI SOURCE PV 06/04/10 21:15:13 5393 2 : SUBROUTINE CQUOI(MCHAR,ITYPE,IVAL,RVAL,CVAL,LVAL,IOBJ) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C 6 : C a partir d'un nom dans la chaine MCHAR(<500caracteres) 7 : C fournit l'objet qui ay est attache si cela est possible 8 : C SI ITYPE n'est pas blanc on impose le type de l'objet 9 : C attendu (erreur sinon) 10 : C en sortie ; ITYPE type de l'objet 11 : C IVAL RVAL CVAL LVAL IOBJ donne la valeur 12 : C associee dans le cas d'entier, de flottant, de mot 13 : C de logique ou d'objet 14 : C 15 : -INC CCOPTIO 16 : -INC CCNOYAU 17 : -INC CCREDLE 18 : -INC SMBLOC 19 : -INC SMTABLE 20 : CHARACTER*(*) MCHAR,CVAL 21 : CHARACTER*8 ITYPE,LTYPE,JTYPE,ITYP1 22 : CHARACTER*(8) INDIC1 ,TYPOBJ ,MOTYP,CHARRE 23 : CHARACTER*500 CMTEXT 24 : LOGICAL LVAL,ICOND,IBOOL 25 : ICOND=.FALSE. 26 : IF(ITYPE.NE.' ') ICOND=.TRUE. 27 : ITYP1=ITYPE 28 : IF(ITYPE.EQ.'FLOTTANT') ITYP1='ENTIER ' 29 : LECTAB=0 30 : IF(ITYPE.EQ.'TABLE ') THEN LECTAB=1 31 : CRIT = 1.D0 / 3.D0 32 : CRAT =ABS( CRIT * 3.D0 - 1.d0 )* 1000. 33 : C-- ON SAUVE TEXT DE FACON A LE SURCHARGER TEMPORAIREMENT 34 : * CMTEXT(1:500)=TEXT(1:500) 35 : * NRAN1=NRAN 36 : * ICOUR1=ICOUR 37 : * IFINA1=IFINAN 38 : * IPREC1=IPREC 39 : segini sredle 40 : C-- ON PLACE L'OBJET DE TYPE TEXTE DANS TEXT 41 : LENI=LEN(MCHAR) 42 : TEXT(1:500)=MCHAR(1:LENI) 43 : NRAN= 0 44 : IPREC=1 45 : IFINAN=LENI 46 : ICOUR=LENI 47 : INSTAB=0 48 : KER=0 49 : * write(6,*) ' avant appel redlec text', text(1:20) 49 : CALL REDLEC(sredle) 50 : IF(IRE.EQ.0) THEN 50 : CALL ERREUR(21) 51 : ENDIF 52 : * write(6,*) ' ire ', ire 53 : C IRE = 0 FIN DE PHRASE 54 : * write(6,*) MOT(1:20) 54 : CALL PRENOM(IPLAMO,0,sredle) 55 : LTYPE=INOOB2(IPLAMO) 56 : IPLAFI=IOUEP2(IPLAMO) 57 : * write(6,*) iplamo,ltype,iplafi 58 : MTABLE=IOUEP2(IPLAMO) 59 : 25 CONTINUE 60 : IF(LTYPE.EQ.'TABLE '.OR.LTYPE.EQ.'OBJET ')THEN 61 : * write(6,*) ' on a bien trouve une table ou un objet' 61 : CALL REDLEC(sredle) 62 : IF(IRE.EQ.0) THEN 63 : GO TO 500 64 : ENDIF 64 : CALL PRENOM(IPLAMA,0,sredle) 65 : JTYPE=INOOB2(IPLAMA) 66 : * write(6,*) ' jtype ',jtype 67 : IF( JTYPE.EQ.'SEPARATE'.OR.JTYPE.EQ.'METHODOL')THEN 67 : CALL REDLEC(sredle) 68 : IF(IRE.EQ.0) THEN 69 : KER=1 70 : GO TO 500 71 : ENDIF 72 : * write(6, *) 'ire au deuxieme appel redlec', ire 72 : CALL PRENOM (IPLAMA,0,sredle) 73 : INDIC1=INOOB2(IPLAMA) 74 : INDIC2=IOUEP2(IPLAMA) 75 : SEGACT MTABLE 76 : NB=MLOTAB 77 : IF(NB.EQ.0) THEN 78 : KER=1 79 : GOTO 500 80 : ENDIF 81 : TYPOBJ=' ' 82 : MOTYP='MOT' 82 : CALL ACCTAB(MTABLE,MOTYP,IVAL,XER,'SOUSTYPE',IBOOL 83 : $ ,IOBJ,TYPOBJ,IVALRE,XER,CHARRE,IBOOL,IOBRE) 84 : IBOOL=.FALSE. 85 : IF(TYPOBJ.EQ.'MOT '.AND.CHARRE.EQ.'RESULTAT') 86 : $ IBOOL=.TRUE. 87 : DO 10 IJ=1,NB 88 : IF (INDIC1.NE.MTABTI(IJ)) GOTO 10 89 : IF (INDIC1.NE.'FLOTTANT') THEN 90 : IF (INDIC2.NE.MTABII(IJ)) GOTO 10 91 : ELSE 92 : IF (IBOOL) THEN 93 : XER=ABS((XIFLOT(INDIC2)-RMTABI(IJ))/ 94 : $ (ABS(XIFLOT(INDIC2))+MAX(1.D-20 ,ABS(XIFLOT(INDIC2)) 95 : $ )/ 1.D15)) 96 : IF(XER. GT . CRAT ) GO TO 10 97 : ELSE 98 : IF (XIFLOT(INDIC2).NE.RMTABI(IJ)) GOTO 10 99 : ENDIF 100 : ENDIF 101 : GOTO 20 102 : 10 CONTINUE 103 : C pas d'indice dans la table 104 : KER=1 105 : GO TO 500 106 : 20 LTYPE=MTABTV(IJ) 107 : IF (LTYPE.NE.'FLOTTANT') THEN 108 : IPLAFI=MTABIV(IJ) 109 : ELSE 110 : * SYNTONISER LA VALEUR AVEC LA PILE DES FLOTTANTS 111 : XXVA=RMTABV(IJ) 112 : DO 1000 J=1,LMNREE 113 : IF(XIFLOT(J).NE.XXVA) GO TO 1000 114 : C LA VALEUR EXISTE DEJA EN J IEME POSITION 115 : IPLAFI=J 116 : GO TO 1100 117 : 1000 CONTINUE 118 : C LA VALEUR N'EXISTE PAS 119 : LMNREE=LMNREE+1 120 : segdes ipiloc 121 : segact ipiloc*mod 122 : IL=XIFLOT(/1) 123 : IF(LMNREE.GT.IL) THEN 124 : LMxx=LMNREE+100 125 : lmmm=ichara(/1) 126 : lmcc=ipchar(/1) 127 : lmll=iplogi(/1) 128 : SEGADJ IPiloc 129 : ENDIF 130 : XIFLOT(LMNREE)=XXVA 131 : IPLAFI=LMNREE 132 : segdes ipiloc 133 : 1100 CONTINUE 134 : ENDIF 135 : SEGDES MTABLE 136 : MTABLE = IPLAFI 137 : GO TO 25 138 : ELSE 139 : KER=1 140 : GO TO 500 141 : ENDIF 142 : ENDIF 143 : 500 CONTINUE 144 : C 145 : C on arrive ici avec LTYPE et IPLAFI et KER 146 : C 147 : IF(KER.EQ.1) THEN 148 : IF(ICOND) THEN 149 : MOTERR(1:8)=ITYPE 149 : CALL ERREUR(37) 150 : ELSE 150 : CALL ERREUR(21) 151 : ENDIF 152 : GO TO 3000 153 : ELSE 154 : IF(ICOND) THEN 155 : IF(LTYPE.NE.ITYPE.AND.LTYPE.NE.ITYP1) THEN 156 : MOTERR(1:8)=ITYPE 156 : CALL ERREUR(37) 157 : GO TO 3000 158 : ENDIF 159 : IF(LTYPE.NE.ITYPE) THEN 160 : RVAL=IPLAFI 161 : GO TO 3000 162 : ENDIF 163 : ENDIF 164 : ITYPE=LTYPE 165 : IF(ITYPE.EQ.'MOT ') THEN 166 : IP=IPLAFI 167 : ID=IPCHAR(IP) 168 : IFI=IPCHAR(IP+1) 169 : CVAL=ICHARA(ID:IFI-1) 170 : IVAL=MIN(LEN(CVAL),IFI - ID ) 171 : ELSEIF(ITYPE.EQ.'LOGIQUE ') THEN 172 : LVAL=IPLOGI(IPLAFI) 173 : ELSEIF(ITYPE.EQ.'FLOTTANT') THEN 174 : RVAL=XIFLOT(IPLAFI) 175 : ELSEIF(ITYPE.EQ.'ENTIER ') THEN 176 : IVAL=IPLAFI 177 : ELSE 178 : IOBJ=IPLAFI 179 : ENDIF 180 : ENDIF 181 : 3000 CONTINUE 182 : C 183 : C on remet la pile de lecture en place 184 : C 185 : * TEXT(1:500)=CMTEXT(1:500) 186 : * IFINAN=IFINA1 187 : * IPREC=IPREC1 188 : * ICOUR=ICOUR1 189 : * NRAN=NRAN1 190 : segsup sredle 191 : RETURN 192 : END 193 : 194 : 195 : 196 : 197 : 198 : 199 : 200 :
© Cast3M 2003 - All rights reserved.
Disclaimer