Télécharger cquoi.eso

Retour à la liste

Numérotation des lignes :

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales