Télécharger rempil.eso

Retour à la liste

Numérotation des lignes :

  1. C REMPIL SOURCE PV 18/12/06 21:15:43 10030
  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 ,INDIC4
  21. CHARACTER*26 ICHA
  22. CHARACTER*72 MOTASS
  23. LOGICAL IBOOL
  24. LOGICAL LOMISA,ILOREMP
  25. nth=0
  26. if (nbesc.ne.0) nth=oothrd
  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)(1:8)
  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)(1:8)
  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. INDIC2=INOOB1(JPOOB2(I2))
  58. * write(6,*) ' rempil 1 indic2', indic2
  59. IF(INDIC1.EQ.'MOT ') THEN
  60. INDIC2 = JPOOB4(I2)
  61. * write(6,*) ' rempil 2 indic2', indic2
  62. ENDIF
  63. INDIC1='METHODE '
  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. INDIC4 = MTABTI(IJ)(1:8)
  88. IF(INDIC4.NE.'METHODE ') THEN
  89. IF (INDIC1.NE.INDIC4) GOTO 10
  90. ELSE
  91. IF(INDIC1.NE.'MOT '.AND.INDIC1.NE.'METHODE ') GO TO 10
  92. ENDIF
  93. IF (INDIC1.NE.'FLOTTANT') THEN
  94. IF (INDIC2.NE.MTABII(IJ)) GOTO 10
  95. ELSE
  96. IF (IBOOL) THEN
  97. XER=ABS((XIFLOT(INDIC3)-RMTABI(IJ))/
  98. $ (ABS(XIFLOT(INDIC3))+MAX(1.D-20 ,ABS(XIFLOT(INDIC3))
  99. $ )/ 1.D15))
  100. * $ XIFLOT(INDIC2),RMTABI(IJ), XER
  101. IF(XER. GT . CRAT ) GO TO 10
  102. ELSE
  103. IF (XIFLOT(INDIC3).NE.RMTABI(IJ)) GOTO 10
  104. ENDIF
  105. ENDIF
  106. * if(icas.eq.2) write(6,*) 'rempil on a trouve'
  107. GOTO 20
  108. 10 CONTINUE
  109. 15 CONTINUE
  110. * PAS D'INDICE CORRECT ON FAIT UNE ERREUR
  111. IF(IMETH.EQ.2.AND.ICAS.EQ.2) THEN
  112. I3=I1
  113. JTYOBJ(I3)(1:8)='TABLE '
  114. JPOOB4(I3)=MOBJCO
  115. if(nbesc.ne.0) SEGDES,IPILOC
  116. return
  117. ELSE
  118. MOTERR=' '
  119. IF ( INDIC1.EQ.'FLOTTANT') THEN
  120. REAERR(1)= XIFLOT(INDIC2)
  121. CALL ERREUR ( 534)
  122.  
  123. ELSEIF (INDIC1.EQ.'MOT ') THEN
  124. CCC ** SI ON NE TROUVE PAS UN MOT ON CHERCHE S'IL N'Y A PAS LE MEME
  125. CCC MOT SANS LES BLANCS A LA FIN DU MOT
  126. * write(6,*) ' indic2' ,indic2
  127. * write(6,*) ' longueur de ipchar' , ipchar(/1)
  128. * write(6,*) ( ipchar (iou),iou=1,ipchar(/1))
  129. IOD = IPCHAR(INDIC2 )
  130. * write(6,*) ' iod ' , iod
  131. IOF= IPCHAR(INDIC2+1)
  132.  
  133. IL2= LONG(ICHARA(IOD:IOF-1))+IOD-1
  134. DO 30 IJ=1,NB
  135. IP=MTABII(IJ)
  136. ID=IPCHAR(IP)
  137. ** IFI=IPCHAR(IP+1)
  138. ** IL1= LONG(ICHARA(ID:IFI-1))+ID-1
  139. ** IF(ICHARA(ID:IL1).EQ.ICHARA(IOD:IL2)) GO TO 20
  140. if (indic2.eq.ip) goto 20
  141. 30 CONTINUE
  142. IOM = MAX ( 8, IOF -IOD )
  143. MOTERR(1:IOM)=ICHARA(IOD:IOF-1)
  144. IF(IOF-IOD.GT.8) MOTERR(9:11) = '...'
  145. CALL ERREUR (535)
  146. ELSE
  147. IF(ICAS.EQ.1) THEN
  148. MOTERR(1:8) = INDIC1
  149. INTERR(1)= INDIC2
  150. CALL ERREUR (171)
  151. ELSEIF(ICAS.EQ.2) THEN
  152. IF(IMETH.EQ.1) THEN
  153. CALL ERREUR(864)
  154. ELSE
  155. CALL ERREUR(865)
  156. ENDIF
  157. ENDIF
  158. ENDIF
  159. ENDIF
  160. IF(nbesc.ne.0) SEGDES,IPILOC
  161. RETURN
  162. 20 CONTINUE
  163. * ON A TROUVE UN INDICE * si icas=2 et imeth=1 il faut tester que a vale
  164. * est bien un mot ou une procedur
  165. segact mtable*mod
  166. if( nbesc.ne.0) SEGDES,IPILOC
  167. I3=I2
  168. INDIC1=MTABTV(IJ)(1:8)
  169. JTYOBJ(I3)(1:8)=INDIC1
  170. JPOOB2(I3)=0
  171. if (indic1.eq.'ESCLAVE ') then
  172. LOMISA = .FALSE.
  173. if (.not.lodesl.or.nth.ne.0) lomisa =.true.
  174. mesres=MTABIV(IJ)
  175. if (iimpi .eq. 1234) write(ioimp,*)
  176. & 'un objet (ESCLAVE) de la table est utilisé',mesres
  177. C * mise a jour eventuelle et menage eventuel
  178. IF ( LOMISA ) THEN
  179. SEGACT MESRES
  180. NESRES = IESRES
  181. segdes mcoord
  182. segact nesres
  183. if (.not.loremp) then
  184. 5 continue
  185. segdes nesres*record
  186. segdes mesres
  187. SEGACT NESRES*(ECR=1,MOD)
  188. segact mesres
  189. if (.not.loremp) then
  190. * write(6,*) ' loremp pas vrai dans rempil '
  191. goto 5
  192. endif
  193. endif
  194. segdes mesres
  195. segact mcoord
  196. if (iimpi .eq. 1234)
  197. & write(ioimp,*) 'le segment a ete mis a jour ',MESRES
  198. indic1=esrety
  199. JTYOBJ(I3)(1:8)=INDIC1
  200. call tabesc(mtable,ij,nesres)
  201. C * menage eventuel
  202. SEGDES MESRES
  203. SEGDES NESRES*RECORD
  204. END IF
  205. endif
  206. IF(IMETH.EQ.1.AND.ICAS.EQ.2) THEN
  207. IF(INDIC1.NE.'MOT '.AND. INDIC1.NE.'PROCEDUR') THEN
  208. if(nbesc.ne.0) SEGDES,IPILOC
  209. RETURN
  210. ENDIF
  211. ENDIF
  212. IF (INDIC1.NE.'FLOTTANT') THEN
  213. JPOOB4(I3)=MTABIV(IJ)
  214. ELSE
  215. * SYNTONISER LA VALEUR AVEC LA PILE DES FLOTTANTS
  216. XXVA=RMTABV(IJ)
  217. call posree(xxva,iplac)
  218. JPOOB4(I3)=IPLAC
  219. ENDIF
  220. SEGDES MTABLE
  221. IF(ICAS.EQ.1) JPOOB1(I)=.FALSE.
  222. JPOOB1(I1)=.FALSE.
  223. IF(IMETH.EQ.2.AND.INDIC1.EQ.'PROCEDUR') THEN
  224. * on place l'objet mobjco dans la pile a la place du %
  225. * write(6,*) 'rempil on vient de trouver %procedur'
  226. JPOOB1(I1)=.TRUE.
  227. JPOOB4(I1)=MOBJCO
  228. JTYOBJ(I1)(1:8) = 'OBJET '
  229. ENDIF
  230. if(nbesc.ne.0) SEGDES,IPILOC
  231. RETURN
  232. END
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  

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