Télécharger quelqu.eso

Retour à la liste

Numérotation des lignes :

  1. C QUELQU SOURCE GF238795 18/02/05 21:15:45 9726
  2. C OPERATEUR QUELQUONQUE (ie QUELCONQUE ;)
  3. C
  4. SUBROUTINE QUELQU
  5. C
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8(A-H,O-Z)
  8. C
  9. -INC CCOPTIO
  10. -INC CCGEOME
  11. -INC SMELEME
  12. -INC SMLREEL
  13. CHARACTER*4 ITSEG(2)
  14. INTEGER IRETOU,IRETO1,IRETO2,IRETO3
  15. DATA ITSEG/'SEG2','SEG3'/
  16. SEGMENT IBUF(0)
  17. IRETOU=0
  18. IRETO1=0
  19. IRETO2=0
  20. IRETO3=0
  21.  
  22. CALL LIRMOT(ITSEG,2,ITYP,1)
  23. IF (IERR.NE.0) RETURN
  24. SEGINI IBUF
  25. C
  26. CALL LIROBJ('LISTREEL',MLREE1,0,IRETO1)
  27. IF(IRETO1.NE.0)THEN
  28. SEGACT MLREE1
  29. JG1=MLREE1.PROG(/1)
  30. IF (IDIM.GE.2) THEN
  31. CALL LIROBJ('LISTREEL',MLREE2,1,IRETO2)
  32. C ON DOIT LIRE UNE DEUXIEME PROGRESSION
  33. IF(IRETO2.EQ.0) RETURN
  34. SEGACT MLREE2
  35. IF(IDIM.EQ.3)THEN
  36. CALL LIROBJ('LISTREEL',MLREE3,1,IRETO3)
  37. C ON DOIT LIRE UNE TROISIEME PROGRESSION EN 3 D
  38. IF(IRETO3.EQ.0)RETURN
  39. SEGACT MLREE3
  40. ENDIF
  41. JG2=MLREE2.PROG(/1)
  42. C LES DEUX PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR
  43. IF(JG2.NE.JG1) CALL ERREUR(577)
  44. IF(IDIM.EQ.3) THEN
  45. JG3=MLREE3.PROG(/1)
  46. C LES DEUX PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR
  47. IF(JG3.NE.JG1)CALL ERREUR(577)
  48. ENDIF
  49. ENDIF
  50. C LES PROGRESSIONS DOIVENT AVOIR UNE LONGUEUR SUFFISANTE
  51. IF(JG1.LE.ITYP) CALL ERREUR(725)
  52. IF(ITYP.EQ.2)THEN
  53. C LIGNE CONSTITUEE DE SEG3 :
  54. C LES PROGRESSIONS DOIVENT AVOIR UNE LONGUEUR ADEQUATE
  55. IQUOT=(JG1-3)/2
  56. IREST=JG1-3-2*IQUOT
  57. IF(IREST.NE.0) CALL ERREUR(726)
  58. ENDIF
  59. YG2=0.D0
  60. ZG3=0.D0
  61. DO 10 IG1=1,JG1
  62. XG1=MLREE1.PROG(IG1)
  63. IF (IDIM.GE.2) YG2=MLREE2.PROG(IG1)
  64. IF (IDIM.EQ.3) ZG3=MLREE3.PROG(IG1)
  65. CALL CREPO1(XG1,YG2,ZG3,IPO)
  66. IBUF(**)=IPO
  67. 10 CONTINUE
  68. SEGDES MLREE1
  69. IF(IRETO2.EQ.1) SEGDES MLREE2
  70. IF(IRETO3.EQ.1) SEGDES MLREE3
  71. ELSE
  72. *
  73. 20 CONTINUE
  74. CALL LIROBJ('POINT ',IP,0,IRETOU)
  75. IF (IRETOU.NE.0) THEN
  76. IBUF(**)=IP
  77. GOTO 20
  78. ENDIF
  79. CALL LIROBJ('MAILLAGE',IPT1,0,IRETOU)
  80. IF (IRETOU.EQ.1) THEN
  81. SEGACT IPT1
  82. IF ((IPT1.ITYPEL).NE.1) CALL ERREUR(426)
  83. NBNN = IPT1.NUM(/1)
  84. NBELEM = IPT1.NUM(/2)
  85. DO 21 I=1,NBELEM
  86. IBUF(**)= IPT1.NUM(1,I)
  87. 21 CONTINUE
  88. SEGDES IPT1
  89. ENDIF
  90. ENDIF
  91. NBP=IBUF(/1)
  92. NBNN=ITYP+1
  93. NBSOUS=0
  94. NBREF=0
  95. NBELEM=(NBP-1)/(NBNN-1)
  96. IF (NBELEM.LE.0.OR.NBELEM*(NBNN-1).NE.(NBP-1)) CALL ERREUR(20)
  97. IF (IERR.NE.0) RETURN
  98. SEGINI MELEME
  99. ITYPEL=NBNN
  100. DO 30 IEL=1,NBELEM
  101. DO 40 IN=1,NBNN
  102. NUM(IN,IEL)=IBUF((IEL-1)*(NBNN-1)+IN)
  103. 40 CONTINUE
  104. ICOLOR(IEL)=IDCOUL
  105. 30 CONTINUE
  106. SEGDES MELEME
  107. SEGSUP IBUF
  108. CALL ECROBJ('MAILLAGE',MELEME)
  109. END
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  

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