Télécharger la plaquette Cast3M


fr en

Télécharger prochp.eso

Retour à la liste

Numérotation des lignes : 

prochp

  1. C PROCHP    SOURCE    PV        22/01/18    21:15:07     11267          
  2.  
  3. C=======================================================================
  4. C  Sous programme appele par PROPER et DEDU1
  5. C  Creation du CHPOINT MCHPO4 de deplacement du MAILLAGE elementaire
  6. C  IPT1 vers le MAILLAGE elementaire IPT2
  7. C  11/1997 : KICH
  8. C  10/2003 : Modifications pour integration du cas IDIM=1
  9. C=======================================================================
  10.  
  11.       SUBROUTINE PROCHP (IPT1,IPT2,MCHPO4,IP1)
  12.  
  13.       IMPLICIT INTEGER(I-N)
  14.       IMPLICIT REAL*8 (A-H,O-Z)
  15.  
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC SMCOORD
  20. -INC SMELEME
  21. -INC CCGEOME
  22. -INC SMCHPOI
  23.  
  24.       SEGMENT ICPR(nbpts)
  25.       SEGMENT ICP1(nbpts)
  26.  
  27.       idimp1=IDIM+1
  28.  
  29.       ICP1=IP1
  30. C  Determination des noeuds supports du CHPOINT
  31.       SEGINI,IPT3=IPT1
  32.       CALL CHANGE(IPT3,1)
  33.       SEGINI,IPT4=IPT2
  34.       CALL CHANGE(IPT4,1)
  35.  
  36. C  Initialisation du CHPOINT de nature DISCRETE sur un unique MAILLAGE
  37.       NSOUPO=1
  38.       NAT=2
  39.       SEGINI,MCHPO4
  40.       MCHPOI=MCHPO4
  41.       JATTRI(1)=1
  42.       MTYPOI='DEPLACEM'
  43.       MOCHDE='CHAMP CREE PAR PROPER'
  44.       IFOPOI=IFOUR
  45.       NC=IDIM
  46.       SEGINI,MSOUP5
  47.       IPCHP(1)=MSOUP5
  48.       MSOUPO=MSOUP5
  49.       SEGDES,MCHPO4
  50.       IF (IFOMOD.EQ.3) THEN
  51.         NOCOMP(1)='UX  '
  52.       ELSE IF (IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN
  53.         NOCOMP(1)='UR  '
  54.       ELSE IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1) THEN
  55.         NOCOMP(1)='UR  '
  56.         NOCOMP(2)='UZ  '
  57.       ELSE
  58.         NOCOMP(1)='UX  '
  59.         NOCOMP(2)='UY  '
  60.         IF (NC.GE.3) NOCOMP(3)='UZ  '
  61.       ENDIF
  62.       DO i=1,NC
  63.         NOHARM(i)=NIFOUR
  64.       ENDDO
  65.       IGEOC=IPT3
  66.       N=IPT3.NUM(/2)
  67.       SEGINI,MPOVA5
  68.       MPOVAL=MPOVA5
  69.       IPOVAL=MPOVA5
  70.       SEGDES,MSOUP5
  71. C  Calcul des valeurs du CHPOINT
  72.       SEGACT,IPT4,IPT3
  73.       SEGACT,MCOORD
  74.       SEGACT,ICP1*MOD
  75.       DO i=1,N
  76.         IF (ICP1(IPT3.NUM(1,i)).EQ.0) THEN
  77.           ICP1(IPT3.NUM(1,i))=IPT4.NUM(1,i)
  78.         ELSE IF (ICP1(IPT3.NUM(1,i)).NE.IPT4.NUM(1,i)) THEN
  79.           GOTO 800
  80.         ENDIF
  81.         IREF4=(IPT4.NUM(1,i)-1)*idimp1
  82.         IREF3=(IPT3.NUM(1,i)-1)*idimp1
  83.         DO j=1,NC
  84.           VPOCHA(i,j)=XCOOR(IREF4+j)-XCOOR(IREF3+j)
  85.         ENDDO
  86.       ENDDO
  87.       SEGDES,MPOVA5,ICP1,IPT3
  88.       RETURN
  89.  
  90. C  Erreur dans le calcul du CHPOINT, incompatibilite entre les maillages
  91.  800  SEGSUP,MPOVA5,MSOUP5,MCHPO4,IPT3
  92.       SEGDES,ICP1
  93.       CALL ERREUR (878)
  94.       RETURN
  95.  
  96.       END
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  

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