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    CB215821  25/06/20    21:15:03     12290          
  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. C            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. C         SEGSUP MPOVAL
  72. C         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.  
  100.  

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