Télécharger chdite.eso

Retour à la liste

Numérotation des lignes :

  1. C CHDITE SOURCE FANDEUR 17/11/14 21:15:02 9617
  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.  
  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. C Cas 3D :
  34. IF (IFOMOD.EQ.2) THEN
  35. NOMIN(1) = NAMEU(1)
  36. NOMIN(2) = NAMEU(2)
  37. NOMIN(3) = NAMEU(3)
  38. C Cas 2D PLAN :
  39. ELSE IF (IFOMOD.EQ.-1) THEN
  40. NOMIN(1) = NAMEU(1)
  41. NOMIN(2) = NAMEU(2)
  42. C Cas 2D AXIS/ FOUR :
  43. ELSE IF (IFOMOD.EQ.0 .OR. IFOMOD.EQ.1) THEN
  44. NOMIN(1) = NAMEU(4)
  45. NOMIN(2) = NAMEU(3)
  46. C Cas 1D PLAN :
  47. ELSE IF (IFOMOD.EQ.3) THEN
  48. NOMIN(1) = NAMEU(1)
  49. C Cas 1D AXIS / SPHE :
  50. ELSE IF (IFOMOD.EQ.4 .OR. IFOMOD.EQ.5) THEN
  51. NOMIN(1) = NAMEU(4)
  52. C Cas Frequentiel ???
  53. ELSE IF (IFOMOD.EQ.6) THEN
  54. NOMIN(1) = NAMEU(1)
  55. NOMIN(2) = NAMEU(2)
  56. IF (IDIM.EQ.3) NOMIN(3) = NAMEU(3)
  57. C Autres cas : non prevus !
  58. ELSE
  59. CALL ERREUR(5)
  60. RETURN
  61. ENDIF
  62. C
  63. C ON RECUPERE LE CHPOINT
  64. C
  65. MCHPOI=IPCH
  66. SEGACT MCHPOI
  67. C
  68. KPOI=0
  69. DO 1 I = 1,IPCHP(/1)
  70. MSOUPO=IPCHP(I)
  71. SEGACT MSOUPO
  72. KPOI1=NOCOMP(/2)
  73. KPOI=MAX(KPOI,KPOI1)
  74. ** SEGDES MSOUPO
  75. 1 CONTINUE
  76.  
  77. NMIL = XCOOR(/1)/(IDIM+1)
  78. NIN = IDIM
  79. SEGINI MTRAV
  80.  
  81. DO 70 I=1,IPCHP(/1)
  82. MSOUPO=IPCHP(I)
  83. ** SEGACT MSOUPO
  84. JCOMP=0
  85. DO 71 K=1,NOCOMP(/2)
  86. IPASS(K)=0
  87. DO 710 KN=1,NIN
  88. IF(NOMIN(KN).EQ.NOCOMP(K)) GO TO 73
  89. 710 CONTINUE
  90. GO TO 71
  91. 73 CONTINUE
  92. IPASS(K)=KN
  93. JCOMP=JCOMP+1
  94. 71 CONTINUE
  95. IF(JCOMP.EQ.0) GO TO 770
  96. MELEME=IGEOC
  97. SEGACT MELEME
  98. MPOVAL=IPOVAL
  99. SEGACT MPOVAL
  100. DO 78 K=1,NUM(/2)
  101. K2= NUM(1,K)
  102. IF(K2.EQ.0) GO TO 78
  103. DO 74 KK=1,NOCOMP(/2)
  104. K1=IPASS(KK)
  105. IF(K1.EQ.0) GO TO 74
  106. VA(K1,K2)=VPOCHA(K,KK)
  107. 74 CONTINUE
  108. 78 CONTINUE
  109. SEGDES MPOVAL
  110. *PM
  111. IF(MELEME.NE.IPT1) SEGDES MELEME
  112. 770 SEGDES MSOUPO
  113. 70 CONTINUE
  114. *
  115. NBPTB=XCOOR(/1)/(IDIM+1)
  116. NBPTS=NBPTB+NBNN*NBELEM
  117. SEGADJ MCOORD
  118. NBPTS=NBPTB
  119. DO 11 J=1,NBELEM
  120. DO 11 I=1,NBNN
  121. IF (ICPR(IPT1.NUM(I,J)).NE.0) GOTO 3
  122. IREF=IPT1.NUM(I,J)*(IDIM+1)
  123. XCOOR(NBPTS*(IDIM+1)+1)
  124. . = VA(1,IPT1.NUM(I,J))*ISENS + XCOOR(IREF-IDIM)
  125. XCOOR(NBPTS*(IDIM+1)+2)
  126. . = VA(2,IPT1.NUM(I,J))*ISENS + XCOOR(IREF-IDIM+1)
  127. IF (IDIM.GE.3) XCOOR(NBPTS*(IDIM+1)+3)
  128. . = VA(3,IPT1.NUM(I,J))*ISENS+XCOOR(IREF-IDIM+2)
  129. XCOOR(NBPTS*(IDIM+1)+(IDIM+1))=XCOOR(IREF)
  130. NBPTS=NBPTS+1
  131. IPT2.NUM(I,J)=NBPTS
  132. ICPR(IPT1.NUM(I,J))=IPT2.NUM(I,J)
  133. GOTO 11
  134. 3 IPT2.NUM(I,J)=ICPR(IPT1.NUM(I,J))
  135. 11 CONTINUE
  136. SEGADJ MCOORD
  137.  
  138. SEGSUP MTRAV
  139. SEGDES MCHPOI
  140.  
  141. RETURN
  142. END
  143.  
  144.  
  145.  

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