Télécharger rempil.eso

Retour à la liste

Numérotation des lignes :

rempil
  1. C REMPIL SOURCE CB215821 21/06/30 21:15:07 11053
  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.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMTABLE
  18. -INC SMBLOC
  19. -INC SMCOORD
  20. -INC CCASSIS
  21. REAL*8 XXVA,XER,CRIT,CRAT
  22. CHARACTER*(8) INDIC1 ,TYPOBJ ,MOTYP,CHARRE ,INDIC4
  23. CHARACTER*26 ICHA
  24. CHARACTER*72 MOTASS
  25. LOGICAL IBOOL
  26. LOGICAL LOMISA,ILOREMP
  27. nth=0
  28. if (nbesc.ne.0) nth=oothrd
  29. * write(6,*) ' nth nbesc ', nth,nbesc
  30. if(nbesc.ne.0) segact ipiloc
  31. IMETH=ISUCC
  32. CRIT = 1.D0 / 3.D0
  33. CRAT =ABS( CRIT * 3.D0 - 1.d0 )* 1000.
  34. MTABLE=JPOOB4(I)
  35. I1=I+1
  36. I2=I+2
  37. IF(IMETH.EQ.2) THEN
  38. I1=I
  39. I2=I+1
  40. MTABLE=MOBJCO
  41. * write(6,*) ' rempil imeth mobjco', imeth,mobjco
  42. IF(MOBJCO.EQ.0) THEN
  43. CALL ERREUR(863)
  44. RETURN
  45. ENDIF
  46. ENDIF
  47. INDIC1=JTYOBJ(I1)(1:8)
  48. * TEST DE LA PRESENCE D'UN SEPARATEUR SINON RETOUR
  49.  
  50. IF(INDIC1.NE.'SEPARATE'.AND.INDIC1.NE.'METHODOL') RETURN
  51. ICAS=1
  52. IF(INDIC1.EQ.'METHODOL') ICAS=2
  53. IF(I1.EQ.IHPILE) RETURN
  54. * write(6,*) ' rempil icas ',icas
  55. INDIC1=JTYOBJ(I2)(1:8)
  56. INDIC2=JPOOB4(I2)
  57. IF(ICAS.EQ.2.AND.IMETH.EQ.1) THEN
  58. * le type est methode et l'a valeur pointe sur la chaine du nom
  59. INDIC2=INOOB1(JPOOB2(I2))
  60. * write(6,*) ' rempil 1 indic2', indic2
  61. IF(INDIC1.EQ.'MOT ') THEN
  62. INDIC2 = JPOOB4(I2)
  63. * write(6,*) ' rempil 2 indic2', indic2
  64. ENDIF
  65. INDIC1='METHODE '
  66. ENDIF
  67. * if(icas.eq.2) then
  68. * write(6,*) ' type indice , valeur',indic1,indic2
  69. * endif
  70. SEGACT MTABLE
  71. NB=MLOTAB
  72. IF(NB.EQ.0) GO TO 15
  73. TYPOBJ=' '
  74. MOTYP='MOT'
  75. CALL ACCTAB(MTABLE,MOTYP,IVAL,XER,'SOUSTYPE',IBOOL
  76. $ ,IOBJ,TYPOBJ,IVALRE,XER,CHARRE,IBOOL,IOBRE)
  77. IBOOL=.FALSE.
  78. IF(TYPOBJ.EQ.'MOT '.AND.CHARRE.EQ.'RESULTAT')
  79. $ IBOOL=.TRUE.
  80. C creation de indic3 pour aider l'optimiseur
  81. if(nbesc.ne.0) segact ipiloc
  82. INDIC3=MIN(INDIC2,XIFLOT(/1))
  83. SEGACT MTABLE
  84.  
  85. DO 10 IJ=1,NB
  86. * if( icas.eq.2) then
  87. * write(6,*) ' rempilindicetypevaleur',MTABTI(IJ),MTABII(IJ)
  88. * endif
  89. INDIC4 = MTABTI(IJ)(1:8)
  90. IF(INDIC4.NE.'METHODE ') THEN
  91. IF (INDIC1.NE.INDIC4) GOTO 10
  92. ELSE
  93. IF(INDIC1.NE.'MOT '.AND.INDIC1.NE.'METHODE ') GO TO 10
  94. ENDIF
  95. IF (INDIC1.NE.'FLOTTANT') THEN
  96. IF (INDIC2.NE.MTABII(IJ)) GOTO 10
  97. ELSE
  98. IF (IBOOL) THEN
  99. XER=ABS((XIFLOT(INDIC3)-RMTABI(IJ))/
  100. $ (ABS(XIFLOT(INDIC3))+MAX(1.D-20 ,ABS(XIFLOT(INDIC3))
  101. $ )/ 1.D15))
  102. * $ XIFLOT(INDIC2),RMTABI(IJ), XER
  103. IF(XER. GT . CRAT ) GO TO 10
  104. ELSE
  105. IF (XIFLOT(INDIC3).NE.RMTABI(IJ)) GOTO 10
  106. ENDIF
  107. ENDIF
  108. * if(icas.eq.2) write(6,*) 'rempil on a trouve'
  109. GOTO 20
  110. 10 CONTINUE
  111. 15 CONTINUE
  112. * PAS D'INDICE CORRECT ON FAIT UNE ERREUR
  113. IF(IMETH.EQ.2.AND.ICAS.EQ.2) THEN
  114. I3=I1
  115. JTYOBJ(I3)(1:8)='TABLE '
  116. JPOOB4(I3)=MOBJCO
  117. if(nbesc.ne.0) SEGDES,IPILOC
  118. return
  119. ELSE
  120. MOTERR=' '
  121. IF ( INDIC1.EQ.'FLOTTANT') THEN
  122. REAERR(1)= XIFLOT(INDIC2)
  123. CALL ERREUR ( 534)
  124.  
  125. ELSEIF (INDIC1.EQ.'MOT ') THEN
  126. CCC ** SI ON NE TROUVE PAS UN MOT ON CHERCHE S'IL N'Y A PAS LE MEME
  127. CCC MOT SANS LES BLANCS A LA FIN DU MOT
  128. * write(6,*) ' indic2' ,indic2
  129. * write(6,*) ' longueur de ipchar' , ipchar(/1)
  130. * write(6,*) ( ipchar (iou),iou=1,ipchar(/1))
  131. IOD = IPCHAR(INDIC2 )
  132. * write(6,*) ' iod ' , iod
  133. IOF= IPCHAR(INDIC2+1)
  134.  
  135. IL2= LONG(ICHARA(IOD:IOF-1))+IOD-1
  136. DO 30 IJ=1,NB
  137. IP=MTABII(IJ)
  138. ID=IPCHAR(IP)
  139. ** IFI=IPCHAR(IP+1)
  140. ** IL1= LONG(ICHARA(ID:IFI-1))+ID-1
  141. ** IF(ICHARA(ID:IL1).EQ.ICHARA(IOD:IL2)) GO TO 20
  142. if (indic2.eq.ip) goto 20
  143. 30 CONTINUE
  144. MOTERR =ICHARA(IOD:IOF-1)
  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.  

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