Télécharger excoor.eso

Retour à la liste

Numérotation des lignes :

  1. C EXCOOR SOURCE CB215821 19/10/25 21:15:10 10352
  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. CALL ACTOBJ('MCHAML',MCHEL1,1)
  89. I1=MCHEL1.IMACHE(/1)
  90. C MCHAML VIDE
  91. IF (I1.EQ.0) THEN
  92. N1=0
  93. N3=0
  94. L1=8
  95. SEGINI,MCHEL2
  96. MCHEL2.IFOCHE=IFOUR
  97. MCHEL2.TITCHE=' '
  98. IPCHE1=MCHEL2
  99. IF (IVAL.EQ.0) THEN
  100. IF (IDIM.EQ.2) THEN
  101. SEGINI,MCHEL3
  102. MCHEL3.IFOCHE=IFOUR
  103. MCHEL3.TITCHE=' '
  104. IPCHE2=MCHEL3
  105. ELSEIF (IDIM.EQ.3) THEN
  106. SEGINI,MCHEL3
  107. MCHEL3.IFOCHE=IFOUR
  108. MCHEL3.TITCHE=' '
  109. IPCHE2=MCHEL3
  110. SEGINI,MCHEL4
  111. MCHEL4.IFOCHE=IFOUR
  112. MCHEL4.TITCHE=' '
  113. IPCHE3=MCHEL4
  114. ENDIF
  115. ENDIF
  116. C MCHAML NON VIDE
  117. ELSE
  118. CALL CHELCO(IVAL,IRT1,IPCHE1,IPCHE2,IPCHE3)
  119. ENDIF
  120. IF(IERR.EQ.0)THEN
  121. CALL ACTOBJ('MCHAML',IPCHE1,1)
  122. CALL ECROBJ('MCHAML',IPCHE1)
  123. IF(IPCHE2.NE.0)THEN
  124. CALL ACTOBJ('MCHAML',IPCHE2,1)
  125. CALL ECROBJ('MCHAML',IPCHE2)
  126. ENDIF
  127. IF(IPCHE3.NE.0)THEN
  128. CALL ACTOBJ('MCHAML',IPCHE3,1)
  129. CALL ECROBJ('MCHAML',IPCHE3)
  130. ENDIF
  131. ENDIF
  132. RETURN
  133. C
  134. C CAS DU CHPOINT
  135. C
  136. 400 CONTINUE
  137. CALL CHPTCO(IVAL,IRT1)
  138.  
  139. END
  140.  
  141.  

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