Télécharger la plaquette Cast3M


fr en

Télécharger dtchpo.eso

Retour à la liste

Numérotation des lignes : 

dtchpo

  1. C DTCHPO    SOURCE    MB234859  22/10/27    21:15:01     11488          
  2.       SUBROUTINE DTCHPO(IRET)
  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.       integer i,ico, idet, ipile, iret,nat, nsoupo
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC COCOLL
  14. -INC SMCHPOI
  15. -INC SMELEME
  16. -INC TMCOLAC
  17.  
  18.       pointeur piles.LISPIL
  19.       pointeur jcolac.ICOLAC
  20.       pointeur jlisse.ILISSE
  21.       pointeur jtlacc.ITLACC
  22.       DATA MOMOT/'GEOM'/
  23.       iun=1
  24.       CALL LIRMOT(MOMOT,1,IDET,0)
  25.       if(ierr.ne.0) return
  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.             SEGSUP MELEME
  36.             IF(IPSAUV.NE.0) THEN
  37.                ICOLAC=IPSAUV
  38.                SEGACT ICOLAC
  39.                ILISSE=ILISSG
  40.                SEGACT ILISSE*MOD
  41.                CALL TYPFIL('MAILLAGE',ICO)
  42.                ITLACC=KCOLA(ICO)
  43.                SEGACT ITLACC*MOD
  44.                CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
  45.                SEGDES ITLACC
  46.                SEGDES ILISSE
  47.                SEGDES ICOLAC
  48.             ENDIF
  49. C        Suppression du meleme des piles d'objets communiques
  50.             if(piComm.gt.0) then
  51.                piles=piComm
  52.                segact piles
  53.                call typfil('MAILLAGE',ico)
  54.                do ipile=1,piles.proc(/1)
  55.                   jcolac= piles.proc(ipile)
  56.                   if(jcolac.ne.0) then
  57.                      segact jcolac
  58.                      jlisse=jcolac.ilissg
  59.                      segact jlisse*mod
  60.                      jtlacc=jcolac.kcola(ico)
  61.                      segact jtlacc*mod
  62.                      call ajoun0(jtlacc,MELEME,jlisse,iun)
  63.                      segdes jtlacc
  64.                      segdes jlisse
  65.                      segdes jcolac
  66.                   endif
  67.                enddo
  68.                segdes piles
  69.             endif
  70.          ENDIF
  71.          SEGSUP MPOVAL
  72.          SEGSUP MSOUPO
  73.  1    CONTINUE
  74.       NSOUPO=0
  75.       NAT=0
  76.       SEGADJ MCHPOI
  77. **    ipchp(1)=0
  78.       SEGDES MCHPOI
  79.       IRET=0
  80.       RETURN
  81.       END
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  

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