Télécharger la plaquette Cast3M


fr en

Télécharger cuplis.eso

Retour à la liste

Numérotation des lignes : 

cuplis

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

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