Télécharger quelqu.eso

Retour à la liste

Numérotation des lignes :

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

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