Télécharger cuplis.eso

Retour à la liste

Numérotation des lignes :

  1. C CUPLIS SOURCE PV 17/12/05 21:15:46 9646
  2. subroutine cuplis(argume,bu,bufPos,jcolac,NivErr)
  3. C=======================================================================
  4. C Sous-programme cuplis (Collaborateur UnPAQuettage LIste)
  5. C Lit la liste d'objet argume dans le buffer, cree les objets et les
  6. C enregistre dans la pile jcolac
  7. C=======================================================================
  8.  
  9. integer iPile
  10. integer iPoint,nNoeud
  11. integer iPoPi
  12. integer bufPos
  13. integer nivErr
  14. integer nNoRe,nNoCo
  15. integer iNoRe
  16. integer poCoLo
  17. integer iArgu,nArg
  18. integer nbpts
  19. character*(8) typNom
  20. -INC CCOPTIO
  21. -INC TMCOLAC
  22. -INC SMCOORD
  23. segment BUFFER
  24. character ffer(lonBuf)
  25. endsegment
  26. segment LISARG
  27. character*8 nom(nArg)
  28. integer adress(nArg)
  29. endsegment
  30. segment LISNOD
  31. integer liste(nNoeud)
  32. endsegment
  33. pointeur jcolac.ICOLAC
  34. pointeur pile.ITLACC
  35. pointeur bu.BUFFER
  36. pointeur invPil.ILISSE
  37. pointeur argume.LISARG
  38. pointeur temCoo.MCOORD
  39.  
  40. C Liste de passage de la numerotation actuelle vers la numerotation
  41. C de communication
  42. pointeur co2ac.LISNOD
  43. C write(ioimp,*) 'Entree dans CUPLIS'
  44. C Parcourir la liste pour connaitre le nombre de noeud a ajouter
  45. C segact mcoord*mod
  46. invPil = jcolac.ilissg
  47. nNoeud=0
  48. nNoRe=0
  49. C Allocation de l'espace pour les nouveaux noeuds
  50. nArg=argume.adress(/1)
  51. do iArgu =1,nArg
  52. typNom = argume.nom(iArgu)
  53. if(typNom.eq.'POINT ') then
  54. nNoRe=nNoRe+1
  55. iNoRe=argume.adress(iArgu)
  56. if(iNoRe.gt.nNoeud) then
  57. nNoeud=iNoRe
  58. endif
  59. endif
  60. enddo
  61. C Allocation d'un config tampon
  62. if(nNoRe.gt.0) then
  63. nbpts = nNoRe
  64. segini temCoo
  65. iNoRe=0
  66. endif
  67.  
  68. C Parcourir la liste et depaquer les objets
  69.  
  70. nivErr=0
  71.  
  72. C lonBuf=bu.ffer(/2)
  73. do 3 iArgu =1,nArg
  74. C recuperer son type
  75. typNom = argume.nom(iArgu)
  76. C recuper le numero de pile associe
  77. call typfil (typNom,iPile)
  78. pile=jcolac.kcola(iPile)
  79. iPoPi = argume.adress(iArgu)
  80. if(iimpi.ge.7) then
  81. write(ioimp,*) 'Extraction d un objet',typNom, iPoPi
  82. endif
  83. if(iPoPi.eq.0) then
  84. if(iimpi.ge.7) then
  85. write(ioimp,*) 'Position dans la pile incorrecte'
  86. write(ioimp,*) 'Passage a l objet suivant'
  87. endif
  88. goto 3
  89. endif
  90.  
  91. C Redirection vers le traitement correspondant au type de la pile
  92. goto(
  93. & 0100, 0200, 0300, 0400, 0500, 0600, 0700, 0800, 0900, 1000,
  94. & 1100, 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000,
  95. & 2100, 2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 3000,
  96. & 3100, 3200, 3300, 3400, 3500, 3600, 3700, 3800, 3900, 4000,
  97. & 4100, 4200, 4300, 4400, 4500, 4600, 4700), iPile
  98. goto 2
  99. c ******************** meleme ********************
  100. 0100 continue
  101. iPoint=0
  102. call cupmel(bu,bufPos,iPoint)
  103. call placn(pile,iPoint,iPoPi,invPil,1)
  104. goto 1
  105. c ******************** chpoint ********************
  106. 0200 continue
  107. iPoint=0
  108. call cupcpo(bu,bufPos,iPoint)
  109. call placn(pile,iPoint,iPoPi,invPil,1)
  110. goto 1
  111. c ******************** mrigid ********************
  112. 0300 continue
  113. iPoint=0
  114. call cuprig(bu,bufPos,iPoint)
  115. call placn(pile,iPoint,iPoPi,invPil,1)
  116. goto 1
  117. c ******************** ********************
  118. 0400 continue
  119. goto 1
  120. c ******************** ********************
  121. 0500 continue
  122. goto 1
  123. c ******************** bloq ********************
  124. 0600 continue
  125. goto 1
  126. c ******************** elem ********************
  127. 0700 continue
  128. goto 1
  129. c ******************** msolut ********************
  130. 0800 continue
  131. goto 1
  132. c ******************** mstruc ********************
  133. 0900 continue
  134. goto 1
  135. c ******************** mtable ********************
  136. 1000 continue
  137. goto 1
  138. c ******************** ********************
  139. 1100 continue
  140. goto 1
  141. c ******************** msostu ********************
  142. 1200 continue
  143. goto 1
  144. c ******************** imatri ********************
  145. 1300 continue
  146. goto 1
  147. c ******************** mjonct ********************
  148. 1400 continue
  149. goto 1
  150. c ******************** mattac ********************
  151. 1500 continue
  152. goto 1
  153. c ******************** mmatri ********************
  154. 1600 continue
  155. goto 1
  156. c ******************** mdefor ********************
  157. 1700 continue
  158. goto 1
  159. c ******************** mlreel ********************
  160. 1800 continue
  161. goto 1
  162. c ******************** mlenti ********************
  163. 1900 continue
  164. goto 1
  165. c ******************** mcharg ********************
  166. 2000 continue
  167. goto 1
  168. c ******************** ********************
  169. 2100 continue
  170. goto 1
  171. c ******************** mevoll ********************
  172. 2200 continue
  173. goto 1
  174. c ******************** superele ********************
  175. 2300 continue
  176. goto 1
  177. c ******************** logique ********************
  178. 2400 continue
  179. C iPoint=0
  180. C call cuplog(bu,bufPos,iPoint)
  181. C call placn(pile,iPoint,iPoPi,invPil,0)
  182. goto 1
  183. c ******************** flottant ********************
  184. 2500 continue
  185. C iPoint=0
  186. C call cupree(bu,bufPos,iPoint)
  187. C call placn(pile,iPoint,iPoPi,invPil,0)
  188. goto 1
  189. c ******************** entier ********************
  190. 2600 continue
  191. C iPoint=0
  192. C call cupent(bu,bufPos,iPoint)
  193. C call placn(pile,iPoint,iPoPi,invPil,0)
  194. goto 1
  195. c ******************** mot ********************
  196. 2700 continue
  197. C iPoint=0
  198. C call cupmot(bu,bufPos,iPoint)
  199. C call placn(pile,iPoint,iPoPi,invPil,0)
  200. goto 1
  201. c ******************** texte ********************
  202. 2800 continue
  203. goto 1
  204. c ******************** listmots ********************
  205. 2900 continue
  206. goto 1
  207. c ******************** vecteur ********************
  208. 3000 continue
  209. goto 1
  210. c ******************** vectd ********************
  211. 3100 continue
  212. goto 1
  213. c ******************** point ********************
  214. 3200 continue
  215. iNoRe=iNoRe+1
  216. iPoint=iNoRe
  217. call cupnod(bu,bufPos,iPoint,temCoo)
  218. goto 1
  219. c ******************** config ********************
  220. 3300 continue
  221. iPoint=0
  222. call cupcfg(bu,bufPos,iPoint)
  223. call placn(pile,iPoint,iPoPi,invPil,1)
  224. goto 1
  225. c ******************** mlchpo ********************
  226. 3400 continue
  227. goto 1
  228. c ******************** mbasem ********************
  229. 3500 continue
  230. goto 1
  231. c ******************** procedur ********************
  232. 3600 continue
  233. goto 1
  234. c ******************** bloc ********************
  235. 3700 continue
  236. goto 1
  237. c ******************** mmodel ********************
  238. 3800 continue
  239. iPoint=0
  240. call cupmod(bu,bufPos,iPoint)
  241. call placn(pile,iPoint,iPoPi,invPil,1)
  242. goto 1
  243. c ******************** mchaml ********************
  244. 3900 continue
  245. iPoint=0
  246. call cupchm(bu,bufPos,iPoint)
  247. call placn(pile,iPoint,iPoPi,invPil,1)
  248. goto 1
  249. c ******************** minte ********************
  250. 4000 continue
  251. iPoint=0
  252. call cupmin(bu,bufPos,iPoint)
  253. call placn(pile,iPoint,iPoPi,invPil,1)
  254. goto 1
  255. c ******************** nuage ********************
  256. 4100 continue
  257. goto 1
  258. c ******************** matrak ********************
  259. 4200 continue
  260. goto 1
  261. c ******************** matrik ********************
  262. 4300 continue
  263. goto 1
  264. c ******************** objet ********************
  265. 4400 continue
  266. goto 1
  267. c ******************** methode ********************
  268. 4500 continue
  269. goto 1
  270. c ******************** esclave ********************
  271. 4600 continue
  272. goto 1
  273. c ******************** fantome ********************
  274. 4700 continue
  275. goto 1
  276. c **************************************************
  277. C Gestion des erreurs
  278. 2 continue
  279. write(ioimp,*) 'Probleme dans la pile',typNom, iPile
  280. moterr(1:8)=typNom
  281. call erreur (336)
  282. goto 1
  283. C Fin du case
  284. 1 continue
  285. if(iimpi.ge.7) then
  286. write(ioimp,*) 'Objet recu. Taille de la pile',pile.itlac(/1)
  287. write(ioimp,*) 'Pointeur: ',iPoint
  288. write(ioimp,*) 'Position du buffer',bufPos
  289. endif
  290. C Fin de la boucle sur les piles
  291. 3 continue
  292. C Enregistrement des noeuds recus dans la configuration actuelle
  293.  
  294.  
  295. C Creation des nouveaux noeuds
  296. if(nNoRe.gt.0) then
  297. co2ac=jcolac.kcola(32)
  298. nNoCo=co2ac.liste(/1)
  299. if(nNoeud.gt.nNoCo) then
  300. segadj co2ac
  301. endif
  302. C segdes mcoord
  303. segact mcoord*mod
  304. nbpts= mcoord.xcoor(/1)/(idim+1)
  305. poCoLo= (IDIM+1)*nbpts
  306. do iArgu =1,nArg
  307. if(argume.nom(iArgu).eq.'POINT ') then
  308. nbpts=nbpts+1
  309. co2ac.liste(argume.adress(iArgu))=nbpts
  310. endif
  311. enddo
  312. segadj mcoord
  313. do iNoRe =1,nNoRe*(IDIM+1)
  314. mcoord.xcoor(poCoLo+iNoRe)=temCoo.xcoor(iNoRe)
  315. enddo
  316. segdes mcoord
  317. segsup temCoo
  318. endif
  319. C write(ioimp,*) 'Sortie de CUPLIS'
  320. end
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  

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