Télécharger la plaquette Cast3M


fr en

Télécharger detrui.eso

Retour à la liste

Numérotation des lignes : 

detrui

  1. C DETRUI    SOURCE    PASCAL    22/06/10    21:15:02     11377          
  2.       SUBROUTINE DETRUI
  3. C
  4. C  **** OPERATEUR DETR : DETRUIT UN OBJET DE TYPE SUIVANT:
  5. C  **** CHPOINT,RIGIDITE,MCHAML,LISTREEL,LISTENTI,LISTMOTS,SOLUTION,
  6. C  **** EVOLUTIO,ELEMENT,ATTACHE
  7. C
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8(A-H,O-Z)
  10.       character*(8) icara,typob1,charre
  11.       integer i,ico, icoo, id1, id2, idet, ii, iins, im
  12.       integer ind, iob, ipile, irat, iret, ireti, iretou
  13.       integer ith, ithh, ival, ivalre, ktrace, ml
  14.       integer nbelem,nbnn, nbref, nbsou, nbsous
  15.       real*8 xvalre
  16.       logical logr1
  17.       character*4 motout(2)
  18.       character*6 msorse
  19.       save ktrace
  20.  
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC CCNOYAU
  25. -INC COCOLL
  26. -INC CCASSIS
  27. -INC SMCOORD
  28. -INC SMELEME
  29. -INC SMLREEL
  30. -INC SMLENTI
  31. -INC SMLMOTS
  32. -INC TMCOLAC
  33. -INC SMTABLE
  34. -INC SMLOBJE
  35.  
  36.       character*(LONOM) icarb
  37.  
  38.       pointeur piles.LISPIL
  39.       pointeur jcolac.ICOLAC
  40.       pointeur jlisse.ILISSE
  41.       pointeur jtlacc.ITLACC
  42.  
  43.       data KTRACE /-1/
  44.       DATA MOTOUT/'TOUT','TRAC'/
  45.  
  46.       iun=1
  47.       icara=' '
  48.       call lirabj(ICARA,iob,1,iretou)
  49.       IF(IRETOU.EQ.0) THEN
  50.          CALL ERREUR (533)
  51.          RETURN
  52.       ENDIF
  53.       call refus
  54.       ith=0
  55.       ith=oothrd
  56.       if(ith.ne.0) then
  57.           call erreur (1010)
  58.           return
  59.       endif
  60. *  verif que l'objet n'est pas dans les queues d'execution
  61.       if (NBESC.NE.0) then
  62.          do ithh=1,nbesc
  63.             idet=0
  64.             mesins= mescl(ithh)
  65.             segact mesins*(mod,ecr=1)
  66.             do iins=1,nbins
  67.                mescla=lismes(iins)
  68.                if (mescla.ne.0) then
  69.                   segact mescla
  70.                   do im=1,100
  71.                      if (.not.esoplu(im)) then
  72.                         if (esopva(im).eq.iob.and.esopty(im).eq.icara)
  73.      >                     idet=nbins-iins+1
  74.                      endif
  75.                   enddo
  76.                   segdes mescla
  77.                else
  78.                write(6,*) ' mescla nul iins nbins ithh',iins,nbins,ithh
  79.                endif
  80.             enddo
  81.             if (idet.ne.0) then
  82. * objet en queue d'execution. On attend
  83. 20             if(nbins.ge.idet) then
  84. **         write(6,*)'on attend la fin de l''assistant nbins',ithh,nbins
  85.                   segdes mesins*record
  86.                   segact mesins*(mod,ecr=1)
  87.                   go to 20
  88.                endif
  89.             endif
  90.             segdes mesins*record
  91.          enddo
  92. *  blocage des assistants en fin d'instruction
  93.          mestra=imestr
  94.          segact mestra*mod
  95.          segdes mestra
  96.       endif
  97. *  plus rien en attente d'execution. on peut detruire
  98.       call ooohor(0)
  99.       icarb=' '
  100.       ICOO=0
  101.       IF(IPSAUV.NE.0) THEN
  102.          ICOLAC=IPSAUV
  103.          SEGACT ICOLAC
  104.          ILISSE=ILISSG
  105.          SEGACT ILISSE*MOD
  106.       ENDIF
  107. C     Activation des piles de communication si elles existent
  108.       if(piComm.gt.0) then
  109.          piles=piComm
  110.          segact piles
  111.          do ipile=1,piles.proc(/1)
  112.          jcolac= piles.proc(ipile)
  113.          if(jcolac.ne.0) then
  114.             segact jcolac
  115.             jlisse=jcolac.ilissg
  116.             segact jlisse*mod
  117.          endif
  118.          enddo
  119.       endif
  120.  
  121.       CALL LIRTAB('ESCLAVE',mtable,0,iretou)
  122.       if( iretou.ne.0) then
  123. * tc on prefere ne rien faire!
  124.          if(iretou.gt.0) goto 10000
  125.          call quenom (icarb)
  126.          call typfil ( 'TABLE' ,ICOO)
  127.          typob1=' '
  128.          segact mtable
  129.          ml=mlotab
  130.          ind=mtabii(2)
  131.          call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typob1,
  132.      >    ivalre,xvalre,charre,logr1,id1)
  133.          if (ierr.ne.0) goto 10000
  134. *        if (typob1.eq.'CHPOINT'.or.typob1.eq.'MCHAML')then
  135.          if (typob1.eq.'MCHAML')then
  136.             do i=2,ml
  137.             segact mtable
  138.             ind=mtabii(i)
  139.             call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  140.      >      typob1,ivalre,xvalre,charre,logr1,id2)
  141.             if (ierr.ne.0) goto 10000
  142. *            if (typob1.eq.'CHPOINT') call fuchpo(id1,id2,iretou)
  143.             if (typob1.eq.'MCHAML') call dtchaZ (id2,ktrace,msorse)
  144.             enddo
  145.          endif
  146.          GOTO 5000
  147.       endif
  148.       CALL LIRMOT(MOTOUT(2),1,ival,0)
  149.       if(ival.eq.1) then
  150.          call lirent (ival,1,iretou)
  151.          if( ierr.ne.0) goto 10000
  152.          ktrace=ival
  153.          goto 10000
  154.       endif
  155.       CALL LIROBJ('CHPOINT',IRET,0,IRETOU)
  156.       IF (IRETOU.EQ.1) THEN
  157.          IRETI=IRET
  158.          CALL TYPFIL('CHPOINT ',ICOO)
  159.          if(ith.eq.0) CALL QUENOM (ICARB)
  160.          CALL DTCHPZ(IRET,ktrace,msorse)
  161.          GO TO 5000
  162.       ENDIF
  163.       CALL LIROBJ('MCHAML  ',IRET,0,IRETOU)
  164.       IF (IRETOU.EQ.1) THEN
  165.          IRETI=IRET
  166.          CALL TYPFIL('MCHAML  ',ICOO)
  167.          if(ith.eq.0) CALL QUENOM (ICARB)
  168.          CALL DTCHAZ(IRET,KTRACE,msorse)
  169.          GO TO 5000
  170.       ENDIF
  171.       CALL LIROBJ('RIGIDITE',IRET,0,IRETOU)
  172.       IF (IRETOU.EQ.1) THEN
  173.          IRETI=IRET
  174.          CALL TYPFIL('RIGIDITE',ICOO)
  175.          if(ith.eq.0) CALL QUENOM (ICARB)
  176.          CALL DTRIGZ(IRET,KTRACE,msorse)
  177.          GO TO 5000
  178.       ENDIF
  179.       CALL LIROBJ('LISTREEL',IRET,0,IRETOU)
  180.       IF (IRETOU.EQ.1) THEN
  181.          IRETI=IRET
  182.          CALL TYPFIL('LISTREEL',ICOO)
  183.          if(ith.eq.0) CALL QUENOM (ICARB)
  184.          MLREEL=IRET
  185.          msorse='MLREEL'
  186.          IF(ktrace.eq.mlreel) ktrace=-ktrace
  187.          SEGSUP MLREEL
  188.          GO TO 5000
  189.       ENDIF
  190.       CALL LIROBJ('LISTENTI',IRET,0,IRETOU)
  191.       IF (IRETOU.EQ.1) THEN
  192.          IRETI=IRET
  193.          CALL TYPFIL('LISTENTI',ICOO)
  194.          if(ith.eq.0) CALL QUENOM (ICARB)
  195.          MLENTI=IRET
  196.          msorse='MLENTI'
  197.          if(ktrace.eq.mlenti) ktrace=-ktrace
  198.          SEGSUP MLENTI
  199.          GO TO 5000
  200.       ENDIF
  201.       CALL LIROBJ('LISTMOTS',IRET,0,IRETOU)
  202.       IF (IRETOU.EQ.1) THEN
  203.          IRETI=IRET
  204.          CALL TYPFIL('LISTMOTS',ICOO)
  205.          if(ith.eq.0) CALL QUENOM (ICARB)
  206.          MLMOTS=IRET
  207.          msorse='MLMOTS'
  208.          if(ktrace.eq.mlmots) ktrace=-ktrace
  209.          SEGSUP MLMOTS
  210.          GO TO 5000
  211.       ENDIF
  212.       CALL LIROBJ('SOLUTION',IRET,0,IRETOU)
  213.       IF (IRETOU.EQ.1) THEN
  214.          IRETI=IRET
  215.          CALL TYPFIL('SOLUTION',ICOO)
  216.          if(ith.eq.0) CALL QUENOM (ICARB)
  217.          CALL DTSOLZ(IRET,KTRACE,msorse)
  218.          GO TO 5000
  219.       ENDIF
  220.       CALL LIROBJ('EVOLUTIO',IRET,0,IRETOU)
  221.       IF (IRETOU.EQ.1) THEN
  222.          CALL TYPFIL('EVOLUTIO',ICOO)
  223.          if(ith.eq.0) CALL QUENOM (ICARB)
  224.          CALL LIRMOT(MOTOUT,1,IRAT,0)
  225.          CALL DTEVOZ(IRET,IRAT,KTRACE,msorse)
  226.          GO TO 5000
  227.       ENDIF
  228.       CALL LIROBJ('MAILLAGE',IRET,0,IRETOU)
  229.       IF (IRETOU.EQ.1) THEN
  230.          IRETI=IRET
  231.          CALL TYPFIL('MAILLAGE',ICOO)
  232.          if(ith.eq.0) CALL QUENOM (ICARB)
  233.          MELEME=IRET
  234.          CALL LIRMOT(MOTOUT,1,IRAT,0)
  235.          SEGACT MELEME*MOD
  236.          IF(IRAT.EQ.1) THEN
  237.             NBSOU=LISOUS(/1)
  238.             IF(NBSOU.GT.0) THEN
  239.                IF(IPSAUV.NE.0) THEN
  240.                   ICOLAC = IPSAUV
  241.                   CALL TYPFIL('MAILLAGE',ICO)
  242.                   ITLACC = KCOLA(ICO)
  243.                   SEGACT ITLACC*MOD
  244.                ENDIF
  245.                if(piComm.gt.0) then
  246.                   CALL TYPFIL('MAILLAGE',ICO)
  247.                   do ipile=1,piles.proc(/1)
  248.                   jcolac= piles.proc(ipile)
  249.                   if(jcolac.ne.0) then
  250.                      jlisse=jcolac.ilissg
  251.                      jtlacc=jcolac.kcola(ico)
  252.                      segact jtlacc*mod
  253.                   endif
  254.                   enddo
  255.                endif
  256.  
  257.                DO 1080 I=1,LISOUS(/1)
  258.                   IPT1=LISOUS(I)
  259.                   msorse='MELEME'
  260.                   if( ktrace.eq.ipt1) ktrace=-ktrace
  261.                   SEGSUP IPT1
  262.                   IF(IPSAUV.NE.0) then
  263.                      CALL AJOUN0(ITLACC,IPT1,ILISSE,iun)
  264.                      segdes ITLACC
  265.                   endif
  266. C       Suppression du maillage des piles d'objets communiques
  267.                   if(piComm.gt.0) then
  268.                      do ipile=1,piles.proc(/1)
  269.                         jcolac= piles.proc(ipile)
  270.                         if(jcolac.ne.0) then
  271.                            jlisse=jcolac.ilissg
  272.                            jtlacc=jcolac.kcola(ico)
  273.                            call ajoun0(jtlacc,IPT1,jlisse,iun)
  274.                            segdes jtlacc
  275.                         endif
  276.                      enddo
  277.                   endif
  278. 1080           CONTINUE
  279.                IF(IPSAUV.NE.0) THEN
  280.                   SEGDES ITLACC
  281.                ENDIF
  282.                if(piComm.gt.0) then
  283.                   do ipile=1,piles.proc(/1)
  284.                   jcolac= piles.proc(ipile)
  285.                   if(jcolac.ne.0) then
  286.                      jlisse=jcolac.ilissg
  287.                      jtlacc=jcolac.kcola(ico)
  288.                      segdes jtlacc
  289.                   endif
  290.                   enddo
  291.                endif
  292.  
  293.             ENDIF
  294.          ENDIF
  295.          NBNN=0
  296.          NBELEM=0
  297.          NBREF=0
  298.          NBSOUS=0
  299.          ITYPEL=0
  300.          SEGADJ MELEME
  301.          GO TO 5000
  302.       ENDIF
  303.       CALL LIROBJ('CONFIGUR',IRET,0,IRETOU)
  304.       IF (IRETOU.EQ.1) THEN
  305.          IRETI=IRET
  306.          CALL TYPFIL('CONFIGUR',ICOO)
  307.          if(ith.eq.0) CALL QUENOM (ICARB)
  308.          II=MCOORD
  309.          MCOORD=IRET
  310.          IF(IRET.EQ.II) goto 10000
  311. *        SEGSUP MCOORD
  312.          segdes mcoord
  313.          MCOORD=II
  314.          GO TO 5000
  315.       ENDIF
  316.       CALL LIROBJ('ATTACHE ',IRET,0,IRETOU)
  317.       IF (IRETOU.EQ.1) THEN
  318.          IRETI=IRET
  319.          CALL TYPFIL('ATTACHE ',ICOO)
  320.          if(ith.eq.0) CALL QUENOM (ICARB)
  321.          CALL DTMATZ(IRET,KTRACE,msorse)
  322.          GO TO 5000
  323.       ENDIF
  324.       CALL LIROBJ('SUPERELE',IRET,0,IRETOU)
  325.       IF (IRETOU.EQ.1) THEN
  326.          IRETI=IRET
  327.          CALL TYPFIL('SUPERELE',ICOO)
  328.          if(ith.eq.0) CALL QUENOM (ICARB)
  329.          CALL DTSUPZ(IRET,KTRACE,msorse)
  330.          GO TO 5000
  331.       ENDIF
  332.       CALL LIROBJ('LISTOBJE',IRET,0,IRETOU)
  333.       IF (IRETOU.EQ.1) THEN
  334.          IRETI=IRET
  335.          CALL TYPFIL('LISTOBJE',ICOO)
  336.          if(ith.eq.0) CALL QUENOM (ICARB)
  337.          MLOBJE=IRET
  338.          msorse='MLOBJE'
  339.          if (ktrace.eq.mlobje) ktrace=-ktrace
  340.          SEGSUP, MLOBJE
  341.          GO TO 5000
  342.       ENDIF
  343.  
  344. C     L OPERATEUR DETRUIRE IGNORE LES AUTRE TYPES LUS (ENTIER, etc.)
  345.       GOTO 10000
  346.  
  347.  5000 CONTINUE
  348.       IF(ith.eq.0.and.ICARB.NE.'        ')
  349.      >      CALL NOMOBJ('ANNULE  ',ICARB,0)
  350.       IF( IPSAUV.NE.0) THEN
  351.          IF(ICOO.NE.0) THEN
  352.             ITLACC = KCOLA(ICOO)
  353.             SEGACT ITLACC*MOD
  354.             CALL AJOUN0(ITLACC,IRETI,ILISSE,iun)
  355.             SEGDES ITLACC
  356.          ENDIF
  357.       ENDIF
  358. C     Desactivation des piles de communication si elles existent
  359.       if(piComm.gt.0) then
  360.          if(icoo.ne.0) then
  361.             do ipile=1,piles.proc(/1)
  362.             jcolac= piles.proc(ipile)
  363.             if(jcolac.ne.0) then
  364.                jlisse=jcolac.ilissg
  365.                jtlacc=jcolac.kcola(icoo)
  366.                segact jtlacc*mod
  367.                call ajoun0(jtlacc,ireti,jlisse,iun)
  368.                segdes jtlacc
  369.             endif
  370.             enddo
  371.          endif
  372.       endif
  373.       if(ktrace.le.-2) then
  374.          ktrace = abs(ktrace)
  375.          interr(1)=ktrace
  376.          moterr(1:8)=icara
  377.          moterr(9:14)=msorse
  378.          call erreur (1011)
  379.          CALL ANABAC
  380.       endif
  381. *  liberer les assistants
  382. 10000 continue
  383.       IF( IPSAUV.NE.0) THEN
  384.          SEGDES ILISSE,ICOLAC
  385.       ENDIF
  386. C     Desactivation des piles de communication si elles existent
  387.       if(piComm.gt.0) then
  388.         do ipile=1,piles.proc(/1)
  389.           jcolac= piles.proc(ipile)
  390.           if(jcolac.ne.0) then
  391.             jlisse=jcolac.ilissg
  392.             segdes jlisse,jcolac
  393.           endif
  394.         enddo
  395.         segdes piles
  396.       endif
  397.  
  398.       END
  399.  
  400.  
  401.  
  402.  

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