Télécharger prochp.eso

Retour à la liste

Numérotation des lignes :

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

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