Télécharger rempil.eso

Retour à la liste

Numérotation des lignes :

  1. C REMPIL SOURCE CB215821 19/11/15 21:16:04 10378
  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. segdes mcoord
  180. SEGACT MESRES
  181. if (.not.loremp) then
  182. 5 continue
  183. segdes mesres*record
  184. SEGACT MESRES*ECR=1
  185. if (.not.loremp) then
  186. * write(6,*) ' loremp pas vrai dans rempil '
  187. goto 5
  188. endif
  189. endif
  190. ** segdes mesres
  191. segact mcoord
  192. if (iimpi .eq. 1234)
  193. & write(ioimp,*) 'le segment a ete mis a jour ',MESRES
  194. indic1=esrety
  195. JTYOBJ(I3)(1:8)=INDIC1
  196. call tabesc(mtable,ij,mesres)
  197. C * menage eventuel
  198. SEGDES MESRES
  199. END IF
  200. endif
  201. IF(IMETH.EQ.1.AND.ICAS.EQ.2) THEN
  202. IF(INDIC1.NE.'MOT '.AND. INDIC1.NE.'PROCEDUR') THEN
  203. if(nbesc.ne.0) SEGDES,IPILOC
  204. RETURN
  205. ENDIF
  206. ENDIF
  207. IF (INDIC1.NE.'FLOTTANT') THEN
  208. JPOOB4(I3)=MTABIV(IJ)
  209. ELSE
  210. * SYNTONISER LA VALEUR AVEC LA PILE DES FLOTTANTS
  211. XXVA=RMTABV(IJ)
  212. call posree(xxva,iplac)
  213. JPOOB4(I3)=IPLAC
  214. ENDIF
  215. SEGDES MTABLE
  216. IF(ICAS.EQ.1) JPOOB1(I)=.FALSE.
  217. JPOOB1(I1)=.FALSE.
  218. IF(IMETH.EQ.2.AND.INDIC1.EQ.'PROCEDUR') THEN
  219. * on place l'objet mobjco dans la pile a la place du %
  220. * write(6,*) 'rempil on vient de trouver %procedur'
  221. JPOOB1(I1)=.TRUE.
  222. JPOOB4(I1)=MOBJCO
  223. JTYOBJ(I1)(1:8) = 'OBJET '
  224. ENDIF
  225. if(nbesc.ne.0) SEGDES,IPILOC
  226. RETURN
  227. END
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  

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