Télécharger cquoi.eso

Retour à la liste

Numérotation des lignes :

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

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