Télécharger prochp.eso

Retour à la liste

Numérotation des lignes :

  1. C PROCHP SOURCE PV 20/03/30 21:22:49 10567
  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. NOCONS(i)=' '
  64. NOHARM(i)=NIFOUR
  65. ENDDO
  66. IGEOC=IPT3
  67. N=IPT3.NUM(/2)
  68. SEGINI,MPOVA5
  69. MPOVAL=MPOVA5
  70. IPOVAL=MPOVA5
  71. SEGDES,MSOUP5
  72. C Calcul des valeurs du CHPOINT
  73. SEGACT,IPT4,IPT3
  74. SEGACT,MCOORD
  75. SEGACT,ICP1*MOD
  76. DO i=1,N
  77. IF (ICP1(IPT3.NUM(1,i)).EQ.0) THEN
  78. ICP1(IPT3.NUM(1,i))=IPT4.NUM(1,i)
  79. ELSE IF (ICP1(IPT3.NUM(1,i)).NE.IPT4.NUM(1,i)) THEN
  80. GOTO 800
  81. ENDIF
  82. IREF4=(IPT4.NUM(1,i)-1)*idimp1
  83. IREF3=(IPT3.NUM(1,i)-1)*idimp1
  84. DO j=1,NC
  85. VPOCHA(i,j)=XCOOR(IREF4+j)-XCOOR(IREF3+j)
  86. ENDDO
  87. ENDDO
  88. SEGDES,MPOVA5,ICP1,IPT3
  89. RETURN
  90.  
  91. C Erreur dans le calcul du CHPOINT, incompatibilite entre les maillages
  92. 800 SEGSUP,MPOVA5,MSOUP5,MCHPO4,IPT3
  93. SEGDES,ICP1
  94. CALL ERREUR (878)
  95. RETURN
  96.  
  97. END
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  

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