Télécharger chdite.eso

Retour à la liste

Numérotation des lignes :

  1. C CHDITE SOURCE BP208322 17/03/30 21:15:04 9385
  2. SUBROUTINE CHDITE(IPCH,IPT1,IPT2,ICPR,IARG,ISENS)
  3.  
  4. *PM 05/07/2007
  5. * Il faut éviter de fermer accidentellement le maillage à transformer
  6. * si par malheur c'est le même que celui support du champ-point
  7.  
  8. IMPLICIT INTEGER(I-N)
  9. implicit real*8 (a-h,o-z)
  10. -INC CCOPTIO
  11. -INC SMELEME
  12. -INC SMCOORD
  13. -INC SMCHPOI
  14. SEGMENT/MTRAV/(VA(max(2,NIN),NMIL),IPASS(KPOI))
  15. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  16. CHARACTER*4 NAMEU(4),NOMIN(3)
  17. DATA NAMEU(1),NAMEU(2),NAMEU(3)/'UX ','UY ','UZ '/
  18. DATA NAMEU(4)/'UR '/
  19. C
  20. SEGACT MCOORD
  21. NBSOUS=0
  22. NBREF=IPT1.LISREF(/1)
  23. IF (IARG.EQ.0) NBREF=0
  24. NBNN=IPT1.NUM(/1)
  25. NBELEM=IPT1.NUM(/2)
  26. SEGINI IPT2
  27. IPT2.ITYPEL=IPT1.ITYPEL
  28. DO 10 I=1,NBELEM
  29. 10 IPT2.ICOLOR(I)=IPT1.ICOLOR(I)
  30. C
  31. C ON FABRIQUE LA LISTE DES INCONNUES POSSIBLES
  32. C
  33. NIN=IDIM
  34. NMIL=XCOOR(/1)/(IDIM+1)
  35. IF(IFOUR.EQ.0.OR.IFOUR.EQ.1) THEN
  36. NOMIN(1)=NAMEU(4)
  37. NOMIN(2)=NAMEU(3)
  38. ELSE
  39. NOMIN(1)=NAMEU(1)
  40. NOMIN(2)=NAMEU(2)
  41. IF(IDIM.EQ.3) NOMIN(3)=NAMEU(3)
  42. ENDIF
  43. C
  44. C ON RECUPERE LE CHPOINT
  45. C
  46. MCHPOI=IPCH
  47. SEGACT MCHPOI
  48. C
  49. KPOI=0
  50. DO 1 I = 1,IPCHP(/1)
  51. MSOUPO=IPCHP(I)
  52. SEGACT MSOUPO
  53. KPOI1=NOCOMP(/2)
  54. KPOI=MAX(KPOI,KPOI1)
  55. SEGDES MSOUPO
  56. 1 CONTINUE
  57. C
  58. SEGINI MTRAV
  59. DO 70 I=1,IPCHP(/1)
  60. MSOUPO=IPCHP(I)
  61. SEGACT MSOUPO
  62. JCOMP=0
  63. DO 71 K=1,NOCOMP(/2)
  64. IPASS(K)=0
  65. DO 710 KN=1,NIN
  66. IF(NOMIN(KN).EQ.NOCOMP(K)) GO TO 73
  67. 710 CONTINUE
  68. GO TO 71
  69. 73 CONTINUE
  70. IPASS(K)=KN
  71. JCOMP=JCOMP+1
  72. 71 CONTINUE
  73. IF(JCOMP.EQ.0) GO TO 770
  74. MELEME=IGEOC
  75. SEGACT MELEME
  76. MPOVAL=IPOVAL
  77. SEGACT MPOVAL
  78. DO 78 K=1,NUM(/2)
  79. K2= NUM(1,K)
  80. IF(K2.EQ.0) GO TO 78
  81. DO 74 KK=1,NOCOMP(/2)
  82. K1=IPASS(KK)
  83. IF(K1.EQ.0) GO TO 74
  84. VA(K1,K2)=VPOCHA(K,KK)
  85. 74 CONTINUE
  86. 78 CONTINUE
  87. SEGDES MPOVAL
  88. *PM
  89. IF(MELEME.NE.IPT1) SEGDES MELEME
  90. 770 SEGDES MSOUPO
  91. 70 CONTINUE
  92. *
  93. NBPTB=XCOOR(/1)/(IDIM+1)
  94. NBPTS=NBPTB+NBNN*NBELEM
  95. SEGADJ MCOORD
  96. NBPTS=NBPTB
  97. DO 11 J=1,NBELEM
  98. DO 11 I=1,NBNN
  99. IF (ICPR(IPT1.NUM(I,J)).NE.0) GOTO 3
  100. IREF=IPT1.NUM(I,J)*(IDIM+1)
  101. XCOOR(NBPTS*(IDIM+1)+1)
  102. . = VA(1,IPT1.NUM(I,J))*ISENS + XCOOR(IREF-IDIM)
  103. XCOOR(NBPTS*(IDIM+1)+2)
  104. . = VA(2,IPT1.NUM(I,J))*ISENS + XCOOR(IREF-IDIM+1)
  105. IF (IDIM.GE.3) XCOOR(NBPTS*(IDIM+1)+3)
  106. . = VA(3,IPT1.NUM(I,J))*ISENS+XCOOR(IREF-IDIM+2)
  107. XCOOR(NBPTS*(IDIM+1)+(IDIM+1))=XCOOR(IREF)
  108. NBPTS=NBPTS+1
  109. IPT2.NUM(I,J)=NBPTS
  110. ICPR(IPT1.NUM(I,J))=IPT2.NUM(I,J)
  111. GOTO 11
  112. 3 IPT2.NUM(I,J)=ICPR(IPT1.NUM(I,J))
  113. 11 CONTINUE
  114. SEGADJ MCOORD
  115. *
  116. SEGSUP MTRAV
  117. SEGDES MCHPOI
  118. RETURN
  119. END
  120.  
  121.  
  122.  
  123.  
  124.  

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