Télécharger excoor.eso

Retour à la liste

Numérotation des lignes :

  1. C EXCOOR SOURCE PASCAL 12/12/12 21:15:06 7605
  2. C EXTRAIT LA IEME COORDONNEE D'UN POINT. SI IDIM+1 REND LA DENSITE
  3. C SI PAS DE NOMBRE SPECIFIE REND TOUTES LES COORDONNEES
  4. C DANS LE CAS D'OBJET MELEME FAIT LA MEME CHOSE SAUF QU'IL CREE
  5. C AUTANT DE CHPOIN QUE IDIM
  6.  
  7. SUBROUTINE EXCOOR
  8.  
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8(A-H,O-Z)
  11.  
  12. -INC CCOPTIO
  13. -INC SMCOORD
  14. -INC SMCHAML
  15.  
  16. PARAMETER ( NBTYP = 4 )
  17. CHARACTER*8 LISTYP(NBTYP),MOTYPE
  18. *
  19. DATA LISTYP/'POINT ','MAILLAGE','MCHAML ', 'CHPOINT '/
  20. *
  21. * LECTURE DE LA COMPOSANTE ( EVENTUELLE )
  22. *
  23. CALL LIRENT(ICOMP,0,IRT2)
  24. *
  25. CALL QUETYP(MOTYPE,0,IRETOU)
  26. IF (IRETOU.EQ.0) THEN
  27. CALL ERREUR ( 533)
  28. RETURN
  29. ENDIF
  30. CALL PLACE(LISTYP,NBTYP,IPOS,MOTYPE)
  31. IF (IPOS.EQ.0) THEN
  32. MOTERR(1:8)=MOTYPE
  33. CALL ERREUR(39)
  34. RETURN
  35. ENDIF
  36. CALL LIROBJ(MOTYPE,IRT1,1,IRETOU)
  37. *
  38. IF(IPOS.NE.1) THEN
  39. IF((ICOMP.LE.0.OR.ICOMP.GT.IDIM+1).AND.IRT2.EQ.1) THEN
  40. INTERR(1)=ICOMP
  41. CALL ERREUR(36)
  42. RETURN
  43. ENDIF
  44. IF(IRT2.EQ.0) THEN
  45. IVAL=0
  46. ELSE
  47. IVAL=ICOMP
  48. ENDIF
  49. ENDIF
  50. *
  51. GO TO (100,200,300,400),IPOS
  52. C
  53. C CAS DU POINT
  54. C
  55. 100 CONTINUE
  56. IP=IRT1
  57. IC=ICOMP
  58. IF (IRT2.EQ.1.AND.(IC.LE.0.OR.IC.GT.IDIM+1)) CALL ERREUR(36)
  59. IF (IERR.NE.0) RETURN
  60. SEGACT MCOORD
  61. IREF=(IP-1)*(IDIM+1)
  62. IF(IRT2.EQ.0) GOTO 10
  63. XRET=XCOOR(IREF+IC)
  64. CALL ECRREE(XRET)
  65. GOTO 20
  66. 10 CONTINUE
  67. DO 11 I=1,IDIM
  68. II=IDIM+1-I
  69. XRET=XCOOR(IREF+II)
  70. CALL ECRREE(XRET)
  71. 11 CONTINUE
  72. 20 CONTINUE
  73. RETURN
  74. C
  75. C CAS DU MELEME
  76. C
  77. 200 CONTINUE
  78. CALL CHPCOO(IVAL,IRT1)
  79. RETURN
  80. C
  81. C CAS DU MCHAML
  82. C
  83. 300 CONTINUE
  84. IPCHE1=0
  85. IPCHE2=0
  86. IPCHE3=0
  87. MCHEL1=IRT1
  88. SEGACT,MCHEL1
  89. I1=MCHEL1.IMACHE(/1)
  90. C MCHAML VIDE
  91. IF (I1.EQ.0) THEN
  92. SEGDES,MCHEL1
  93. N1=0
  94. N3=0
  95. L1=8
  96. SEGINI,MCHEL2
  97. MCHEL2.IFOCHE=IFOUR
  98. MCHEL2.TITCHE=' '
  99. SEGDES,MCHEL2
  100. IPCHE1=MCHEL2
  101. IF (IVAL.EQ.0) THEN
  102. IF (IDIM.EQ.2) THEN
  103. SEGINI,MCHEL3
  104. MCHEL3.IFOCHE=IFOUR
  105. MCHEL3.TITCHE=' '
  106. SEGDES,MCHEL3
  107. IPCHE2=MCHEL3
  108. ELSEIF (IDIM.EQ.3) THEN
  109. SEGINI,MCHEL3
  110. MCHEL3.IFOCHE=IFOUR
  111. MCHEL3.TITCHE=' '
  112. SEGDES,MCHEL3
  113. IPCHE2=MCHEL3
  114. SEGINI,MCHEL4
  115. MCHEL4.IFOCHE=IFOUR
  116. MCHEL4.TITCHE=' '
  117. SEGDES,MCHEL4
  118. IPCHE3=MCHEL4
  119. ENDIF
  120. ENDIF
  121. C MCHAML NON VIDE
  122. ELSE
  123. CALL CHELCO(IVAL,IRT1,IPCHE1,IPCHE2,IPCHE3)
  124. ENDIF
  125. IF(IERR.EQ.0)THEN
  126. CALL ECROBJ('MCHAML',IPCHE1)
  127. IF(IPCHE2.NE.0)CALL ECROBJ('MCHAML',IPCHE2)
  128. IF(IPCHE3.NE.0)CALL ECROBJ('MCHAML',IPCHE3)
  129. ENDIF
  130. RETURN
  131. C
  132. C CAS DU CHPOINT
  133. C
  134. 400 CONTINUE
  135. CALL CHPTCO(IVAL,IRT1)
  136.  
  137. RETURN
  138. END
  139.  
  140.  
  141.  
  142.  

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