C CUPLIS SOURCE PV090527 26/03/12 08:44:57 12495 subroutine cuplis(argume,bu,bufPos,jcolac,NivErr) C======================================================================= C Sous-programme cuplis (Collaborateur UnPAQuettage LIste) C Lit la liste d'objet argume dans le buffer, cree les objets et les C enregistre dans la pile jcolac C======================================================================= integer iPile integer iPoint,nNoeud integer iPoPi integer bufPos integer nivErr integer nNoRe,nNoCo integer iNoRe integer poCoLo integer iArgu,nArg character*(8) typNom -INC PPARAM -INC CCOPTIO -INC TMCOLAC -INC SMCOORD segment BUFFER character ffer(lonBuf) endsegment segment LISARG character*8 nom(nArg) integer adress(nArg) endsegment segment LISNOD integer liste(nNoeud) endsegment pointeur jcolac.ICOLAC pointeur pile.ITLACC pointeur bu.BUFFER pointeur invPil.ILISSE pointeur argume.LISARG pointeur temCoo.MCOORD C Liste de passage de la numerotation actuelle vers la numerotation C de communication pointeur co2ac.LISNOD C write(ioimp,*) 'Entree dans CUPLIS' C Parcourir la liste pour connaitre le nombre de noeud a ajouter C segact mcoord*mod invPil = jcolac.ilissg nNoeud=0 nNoRe=0 C Allocation de l'espace pour les nouveaux noeuds nArg=argume.adress(/1) do iArgu =1,nArg typNom = argume.nom(iArgu) if(typNom.eq.'POINT ') then nNoRe=nNoRe+1 iNoRe=argume.adress(iArgu) if(iNoRe.gt.nNoeud) then nNoeud=iNoRe endif endif enddo C Allocation d'un config tampon if(nNoRe.gt.0) then nbpts = nNoRe segini temCoo iNoRe=0 endif C Parcourir la liste et depaquer les objets nivErr=0 C lonBuf=bu.ffer(/2) do 3 iArgu =1,nArg C recuperer son type typNom = argume.nom(iArgu) C recuper le numero de pile associe call typfil (typNom,iPile) pile=jcolac.kcola(iPile) iPoPi = argume.adress(iArgu) if(iimpi.ge.7) then write(ioimp,*) 'Extraction d un objet',typNom, iPoPi endif if(iPoPi.eq.0) then if(iimpi.ge.7) then write(ioimp,*) 'Position dans la pile incorrecte' write(ioimp,*) 'Passage a l objet suivant' endif goto 3 endif C Redirection vers le traitement correspondant au type de la pile goto( & 0100, 0200, 0300, 0400, 0500, 0600, 0700, 0800, 0900, 1000, & 1100, 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, & 2100, 2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 3000, & 3100, 3200, 3300, 3400, 3500, 3600, 3700, 3800, 3900, 4000, & 4100, 4200, 4300, 4400, 4500, 4600, 4700), iPile goto 2 c ******************** meleme ******************** 0100 continue iPoint=0 call cupmel(bu,bufPos,iPoint) call placn(pile,iPoint,iPoPi,invPil,1) goto 1 c ******************** chpoint ******************** 0200 continue iPoint=0 call cupcpo(bu,bufPos,iPoint) call placn(pile,iPoint,iPoPi,invPil,1) goto 1 c ******************** mrigid ******************** 0300 continue iPoint=0 call cuprig(bu,bufPos,iPoint) call placn(pile,iPoint,iPoPi,invPil,1) goto 1 c ******************** ******************** 0400 continue goto 1 c ******************** ******************** 0500 continue goto 1 c ******************** bloq ******************** 0600 continue goto 1 c ******************** elem ******************** 0700 continue goto 1 c ******************** msolut ******************** 0800 continue goto 1 c ******************** mstruc ******************** 0900 continue goto 1 c ******************** mtable ******************** 1000 continue goto 1 c ******************** ******************** 1100 continue goto 1 c ******************** msostu ******************** 1200 continue goto 1 c ******************** imatri ******************** 1300 continue goto 1 c ******************** mjonct ******************** 1400 continue goto 1 c ******************** mattac ******************** 1500 continue goto 1 c ******************** mmatri ******************** 1600 continue goto 1 c ******************** mdefor ******************** 1700 continue goto 1 c ******************** mlreel ******************** 1800 continue goto 1 c ******************** mlenti ******************** 1900 continue goto 1 c ******************** mcharg ******************** 2000 continue goto 1 c ******************** ******************** 2100 continue goto 1 c ******************** mevoll ******************** 2200 continue goto 1 c ******************** superele ******************** 2300 continue goto 1 c ******************** logique ******************** 2400 continue C iPoint=0 C call cuplog(bu,bufPos,iPoint) C call placn(pile,iPoint,iPoPi,invPil,0) goto 1 c ******************** flottant ******************** 2500 continue C iPoint=0 C call cupree(bu,bufPos,iPoint) C call placn(pile,iPoint,iPoPi,invPil,0) goto 1 c ******************** entier ******************** 2600 continue C iPoint=0 C call cupent(bu,bufPos,iPoint) C call placn(pile,iPoint,iPoPi,invPil,0) goto 1 c ******************** mot ******************** 2700 continue C iPoint=0 C call cupmot(bu,bufPos,iPoint) C call placn(pile,iPoint,iPoPi,invPil,0) goto 1 c ******************** texte ******************** 2800 continue goto 1 c ******************** listmots ******************** 2900 continue goto 1 c ******************** vecteur ******************** 3000 continue goto 1 c ******************** vectd ******************** 3100 continue goto 1 c ******************** point ******************** 3200 continue iNoRe=iNoRe+1 iPoint=iNoRe call cupnod(bu,bufPos,iPoint,temCoo) goto 1 c ******************** config ******************** 3300 continue iPoint=0 call cupcfg(bu,bufPos,iPoint) call placn(pile,iPoint,iPoPi,invPil,1) goto 1 c ******************** mlchpo ******************** 3400 continue goto 1 c ******************** mbasem ******************** 3500 continue goto 1 c ******************** procedur ******************** 3600 continue goto 1 c ******************** bloc ******************** 3700 continue goto 1 c ******************** mmodel ******************** 3800 continue iPoint=0 call cupmod(bu,bufPos,iPoint) call placn(pile,iPoint,iPoPi,invPil,1) goto 1 c ******************** mchaml ******************** 3900 continue iPoint=0 call cupchm(bu,bufPos,iPoint) call placn(pile,iPoint,iPoPi,invPil,1) goto 1 c ******************** minte ******************** 4000 continue iPoint=0 call cupmin(bu,bufPos,iPoint) call placn(pile,iPoint,iPoPi,invPil,1) goto 1 c ******************** nuage ******************** 4100 continue goto 1 c ******************** matrak ******************** 4200 continue goto 1 c ******************** matrik ******************** 4300 continue goto 1 c ******************** objet ******************** 4400 continue goto 1 c ******************** methode ******************** 4500 continue goto 1 c ******************** esclave ******************** 4600 continue goto 1 c ******************** fantome ******************** 4700 continue goto 1 c ************************************************** C Gestion des erreurs 2 continue write(ioimp,*) 'Probleme dans la pile',typNom, iPile moterr(1:8)=typNom call erreur (336) goto 1 C Fin du case 1 continue if(iimpi.ge.7) then write(ioimp,*) 'Objet recu. Taille de la pile',pile.itlac(/1) write(ioimp,*) 'Pointeur: ',iPoint write(ioimp,*) 'Position du buffer',bufPos endif C Fin de la boucle sur les piles 3 continue C Enregistrement des noeuds recus dans la configuration actuelle C Creation des nouveaux noeuds if(nNoRe.gt.0) then co2ac=jcolac.kcola(32) nNoCo=co2ac.liste(/1) if(nNoeud.gt.nNoCo) then segadj co2ac endif C segdes mcoord segact mcoord*mod nbpts= mcoord.xcoor(/1)/(idim+1) poCoLo= (IDIM+1)*nbpts do iArgu =1,nArg if(argume.nom(iArgu).eq.'POINT ') then nbpts=nbpts+1 co2ac.liste(argume.adress(iArgu))=nbpts endif enddo segadj mcoord do iNoRe =1,nNoRe*(IDIM+1) mcoord.xcoor(poCoLo+iNoRe)=temCoo.xcoor(iNoRe) enddo segdes mcoord segsup temCoo endif C write(ioimp,*) 'Sortie de CUPLIS' end