Télécharger la plaquette Cast3M


fr en

Télécharger dtchpz.eso

Retour à la liste

Numérotation des lignes : 

dtchpz

  1. C DTCHPZ    SOURCE    CB215821  21/11/25    21:15:05     11201          
  2.               SUBROUTINE DTCHPZ(IRET,ktrace,msorse)
  3. C
  4. C **** DESTRUCTION D'UN CHPOINT: ON TUE LES VALEURS,LES MSOUPO,
  5. C **** LE CHAPEAU. IGEOC EST CONSERVE  SI PAS LECTURE DU MOT GEOM
  6. C
  7.       IMPLICIT INTEGER(I-N)
  8.       character*4 momot(1)
  9.       character*6 msorse
  10.       integer i,ico, idet,ipile, iret, ktrace, nat, nsoupo
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC COCOLL
  15. -INC SMCHPOI
  16. -INC SMELEME
  17. -INC TMCOLAC
  18.  
  19.       pointeur piles.LISPIL
  20.       pointeur jcolac.ICOLAC
  21.       pointeur jlisse.ILISSE
  22.       pointeur jtlacc.ITLACC
  23.       DATA MOMOT/'GEOM'/
  24.       iun=1
  25.       CALL LIRMOT(MOMOT,1,IDET,0)
  26.       MCHPOI=IRET
  27.       SEGACT MCHPOI*MOD
  28.       NSOUPO=IPCHP(/1)
  29.       DO 1 I=1,NSOUPO
  30.          MSOUPO=IPCHP(I)
  31.          SEGACT MSOUPO
  32.          MPOVAL=IPOVAL
  33.          MELEME=IGEOC
  34.          IF (IDET.EQ.1) THEN
  35.             if(meleme.eq.ktrace) then
  36.               msorse='MELEME'
  37.               ktrace=-ktrace
  38.             endif
  39.             SEGSUP MELEME
  40.             IF(IPSAUV.NE.0) THEN
  41.                ICOLAC=IPSAUV
  42.                SEGACT ICOLAC
  43.                ILISSE=ILISSG
  44.                SEGACT ILISSE*MOD
  45.                CALL TYPFIL('MAILLAGE',ICO)
  46.                ITLACC=KCOLA(ICO)
  47.                SEGACT ITLACC*MOD
  48.                CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
  49.                SEGDES ITLACC
  50.                SEGDES ILISSE
  51.                SEGDES ICOLAC
  52.             ENDIF
  53. C        Suppression du chpo des piles d'objets communiques
  54.             if(piComm.gt.0) then
  55.                piles=piComm
  56.                segact piles
  57.                call typfil('MAILLAGE',ico)
  58.                do ipile=1,piles.proc(/1)
  59.                   jcolac= piles.proc(ipile)
  60.                   if(jcolac.ne.0) then
  61. C                    normalement, deja active par detrui
  62. C                     segact jcolac
  63.                      jlisse=jcolac.ilissg
  64. C                    normalement, deja active par detrui
  65. C                     segact jlisse*mod
  66.                      jtlacc=jcolac.kcola(ico)
  67.                      segact jtlacc*mod
  68.                      call ajoun0(jtlacc,MELEME,jlisse,iun)
  69.                      segdes jtlacc
  70. C                    Faut-il desactiver jlisse et icolac ?
  71. C                    Non, ils sont actives par detrui et seul detrui
  72. C                    appelle cette fonction
  73.                   endif
  74.                enddo
  75.                segdes piles
  76.             endif
  77.          ENDIF
  78.          if( msoupo.eq.ktrace) then
  79.            msorse='MSOUPO'
  80.            ktrace=-ktrace
  81.          endif
  82.          if( mpoval.eq.ktrace) then
  83.            msorse='MPOVAL'
  84.            ktrace=-ktrace
  85.          endif
  86. C        Les MPOVAL ne sont plus necessairement dupliques
  87. C        SEGSUP MPOVAL
  88.  
  89.          SEGSUP MSOUPO
  90.  1    CONTINUE
  91.       NSOUPO=0
  92.       NAT=0
  93.       SEGADJ MCHPOI
  94.       SEGDES MCHPOI
  95.       IRET=0
  96.       RETURN
  97.       END
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  

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