Télécharger cquoi.eso

Retour à la liste

Numérotation des lignes :

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

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