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

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