Télécharger rempil.eso

Retour à la liste

Numérotation des lignes :

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

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