Télécharger chpcoo.eso

Retour à la liste

Numérotation des lignes :

  1. C CHPCOO SOURCE CB215821 19/08/01 21:15:14 10279
  2. C CREE UN (DES) CHAMP(S) POINT TYPE SCAL A PARTIR DES COORDONNEES.
  3. C
  4. SUBROUTINE CHPCOO (IVAL,MELEME)
  5. C
  6. C IVAL VAUT 1 ON VEUT CREER UN SEUL CHPOINT CONTENANT LA
  7. C 1 ERE COORDONNES DES NOEUDS DE L'OBJET IMELE
  8. C 2 IDEM POUR LA 2 EME COORDONNEES
  9. C 3 IDEM POUR LA 3 EME COORDONNEES
  10. C 0 ON CREE AUTANT DE CHPOINT QUE IDIM
  11. C IMELE EST LE POINTEUR SUR L'OBJET GEOMETRIQUE
  12. C
  13. IMPLICIT INTEGER(I-N)
  14. C
  15. CHARACTER*4 MOCURV(1)
  16. C
  17. DATA MOCURV/ 'CURV' /
  18. C
  19. -INC CCOPTIO
  20. -INC SMELEME
  21. -INC SMCHPOI
  22. -INC SMCOORD
  23.  
  24. SEGACT MELEME
  25.  
  26. C---- CAS DU MAILLAGE VIDE
  27. C
  28. ISOU1=LISOUS(/1)
  29. IF (ITYPEL.EQ.0.AND.ISOU1.EQ.0) THEN
  30. NAT=1
  31. NSOUPO=0
  32. SEGINI,MCHPOI
  33. MCHPOI.IFOPOI=IFOUR
  34. MCHPOI.JATTRI(1)=1
  35. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  36. CALL ECROBJ('CHPOINT ',MCHPOI)
  37. IF (IVAL.EQ.0) THEN
  38. IF (IDIM.EQ.2) THEN
  39. SEGINI,MCHPO1
  40. MCHPO1.IFOPOI=IFOUR
  41. MCHPO1.JATTRI(1)=1
  42. CALL ACTOBJ('CHPOINT ',MCHPO1,1)
  43. CALL ECROBJ('CHPOINT ',MCHPO1)
  44. ELSEIF (IDIM.EQ.3) THEN
  45. SEGINI,MCHPO1
  46. MCHPO1.IFOPOI=IFOUR
  47. MCHPO1.JATTRI(1)=1
  48. CALL ACTOBJ('CHPOINT ',MCHPO1,1)
  49. CALL ECROBJ('CHPOINT ',MCHPO1)
  50. SEGINI,MCHPO2
  51. MCHPO2.IFOPOI=IFOUR
  52. MCHPO2.JATTRI(1)=1
  53. CALL ACTOBJ('CHPOINT ',MCHPO2,1)
  54. CALL ECROBJ('CHPOINT ',MCHPO2)
  55. ENDIF
  56. ENDIF
  57. RETURN
  58. ENDIF
  59. C
  60. C
  61. C
  62. C---- CAS DE L'OPTION "CURV"
  63. C
  64. CALL LIRMOT(MOCURV,1,IPLAC,0)
  65. IF (IERR.NE.0) RETURN
  66. IF (IPLAC.EQ.1) THEN
  67. C
  68. IF (ISOU1.NE.0) THEN
  69. C write(6,*) ' ITYPEL,ISOU1',ITYPEL,ISOU1
  70. CALL ERREUR(853)
  71. RETURN
  72. ENDIF
  73. C
  74. IF (ITYPEL.EQ.2) THEN
  75. IPT2 = MELEME
  76. CALL CHANGE(IPT2,1)
  77.  
  78. IPT1 = MELEME
  79. NBEL1 = IPT1.NUM(/2)
  80. SEGACT MCOORD
  81. C
  82. NAT = 1
  83. NSOUPO = 1
  84. SEGINI, MCHPOI
  85. MTYPOI = ' '
  86. MOCHDE = ' CHPOINT de coordonnee curviligne '
  87. JATTRI(1) = 1
  88. IFOPOI = IFOMOD
  89. C
  90. NC = 1
  91. SEGINI, MSOUPO
  92. IPCHP(1) = MSOUPO
  93. NOCOMP(1) = 'SCAL'
  94. NOCONS(1) = ' '
  95. IGEOC = IPT2
  96. C
  97. N = IPT2.NUM(/2)
  98. SEGINI, MPOVAL
  99. IPOVAL = MPOVAL
  100. C
  101. VPOCHA(1,1) = 0.D0
  102. XS1 = 0.D0
  103. ID1 = IDIM + 1
  104. IPP = IPT1.NUM(1,1) - 1
  105. DO 20 K=1,NBEL1
  106. IP1 = IPT1.NUM(1,K) - 1
  107. IP2 = IPT1.NUM(2,K) - 1
  108. IF (IP1.NE.IPP) THEN
  109. CALL ERREUR(942)
  110. RETURN
  111. ENDIF
  112. C
  113. XSI1 = 0.D0
  114. DO 2 I=1,IDIM
  115. XI1 = XCOOR(IP1*ID1+I)
  116. XI2 = XCOOR(IP2*ID1+I)
  117. XSI1 = XSI1 + (XI2 - XI1)**2
  118. 2 CONTINUE
  119. XS1 = XS1 + SQRT(XSI1)
  120. VPOCHA(K+1,1) = XS1
  121. IPP = IP2
  122. 20 CONTINUE
  123. ELSE
  124. C write(6,*) ' ITYPEL,ISOU1',ITYPEL,ISOU1
  125. CALL ERREUR(853)
  126. RETURN
  127. ENDIF
  128. C
  129. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  130. CALL ECROBJ('CHPOINT ',MCHPOI)
  131. C
  132. RETURN
  133. ENDIF
  134. C
  135. C
  136. C
  137. C---- AUTRES CAS
  138. C
  139. IF( ITYPEL.NE.1) CALL CHANGE (MELEME,1)
  140. NBPOIN=NUM(/2)
  141. SEGACT MCOORD
  142. NDE=1
  143. NFI=IDIM+1
  144. IF(IVAL.NE.0) THEN
  145. NDE=IVAL
  146. NFI=IVAL+1
  147. ENDIF
  148. NSOUPO=1
  149. NC=1
  150. N=NBPOIN
  151. IA=NFI-NDE
  152. DO 10 IAA=1,IA
  153. IRR= NFI-IAA
  154. NAT=1
  155. SEGINI MCHPOI
  156. MOCHDE=' chpoint de coordonnees '
  157. MTYPOI=' '
  158. JATTRI(1) = 1
  159. IPPOI=MCHPOI
  160. SEGINI MSOUPO
  161. SEGINI MPOVAL
  162. IPCHP(1)=MSOUPO
  163. IFOPOI = IFOMOD
  164. NOCOMP(1)='SCAL'
  165. NOHARM(1)=NIFOUR
  166. IGEOC=MELEME
  167. IPOVAL=MPOVAL
  168. DO 1 I= 1 ,N
  169. I1=NUM(1,I)
  170. I2=(I1-1)*(IDIM+1)
  171. VPOCHA(I,1)=XCOOR(I2+IRR)
  172. 1 CONTINUE
  173. CALL ACTOBJ('CHPOINT ',IPPOI,1)
  174. CALL ECROBJ('CHPOINT ',IPPOI)
  175. 10 CONTINUE
  176. END
  177.  
  178.  
  179.  

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