Télécharger quelqu.eso

Retour à la liste

Numérotation des lignes :

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

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