Télécharger cq2l.eso

Retour à la liste

Numérotation des lignes :

  1. C CQ2L SOURCE CHAT 05/01/12 22:26:47 5004
  2. SUBROUTINE CQ2L
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C***********************************************************************
  6. C
  7. C Ce SP fait un decoupage en élément linéaire de QCF ou MACRO
  8. C
  9. C
  10. C
  11. C***********************************************************************
  12. -INC SMELEME
  13. -INC SMCOORD
  14. -INC CCOPTIO
  15. -INC SMLENTI
  16.  
  17. SEGMENT CARA
  18. INTEGER KM(6,NBSOU1)
  19. ENDSEGMENT
  20.  
  21. DIMENSION I12(8,35)
  22. DATA I12/
  23. C SEG2 2
  24. & 1,2,6*0, 2,3,6*0,
  25. C TRI7 3
  26. & 1,2,7,6,4*0, 2,3,4,7,4*0, 6,7,4,5,4*0,
  27. C QUA9 4
  28. & 1,2,9,8,4*0, 2,3,4,9,4*0, 9,4,5,6,4*0, 8,9,6,7,4*0,
  29. C CU27 8
  30. & 1,2,25,8,9,21,27,24, 2,3,4,25,21,10,22,27,
  31. & 4,5,6,25,22,11,23,27, 6,7,8,25,23,12,24,27,
  32. & 9,21,27,24,13,14,26,20, 21,10,22,27,14,15,16,26,
  33. & 27,22,11,23,26,16,17,18, 27,23,12,24,26,18,19,20,
  34. C PR21 6
  35. &1,2,19,6,7,16,21,18,2,3,4,19,16,8,17,21,4,5,6,19,17,9,18,21,7,16,
  36. &21,18,10,11,20,15,16,8,17,21,11,12,13,20,17,9,18,21,13,14,15,20,
  37. C TRI6 4
  38. & 1,2,6,5*0, 2,3,4,5*0, 4,5,6,5*0, 6,2,4,5*0,
  39. C PR18 8
  40. & 1,2,6,7,16,18,2*0,2,3,4,16,8,17,2*0,4,5,6,17,9,18,2*0,
  41. & 2,4,6,16,17,18,2*0,7,16,18,10,11,15,2*0,16,8,17,11,12,13,2*0,
  42. & 18,17,9,15,13,14,2*0, 16,17,18,11,13,15,2*0/
  43. C tetrahedre et pyramide non fait
  44.  
  45. DIMENSION KTA(11,5)
  46. DATA KTA/3,7,11,33,34,35,36,6 ,40,24,00,
  47. & 2,8,8 ,14,14,23,25,4 ,16,23,25,
  48. C NBNN
  49. & 2,4,4 ,8 ,8 ,4 ,5 ,3 ,6 ,4 ,5 ,
  50. C nb d'éléments du découpage
  51. & 2,3,4 ,8 ,6 ,8 ,8 ,4 ,8 ,8 ,8 ,
  52. C IDEC seg3 tri7 qua9 cu27 pr21 te15 py19 tri6 pr18
  53. & 0, 2, 5, 9, 17, 00, 00, 23, 27, 00,00/
  54.  
  55. C SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19 TRI6 PR18 TE10 PY14
  56. C 3 7 11 33 34 35 36 6 40 24 ??
  57. C SEG2 QUA4 QUA4 CUB8 CUB8 TET4 PYR5 TRI3 PRI6 TET4 PYR5
  58. C 2 8 8 14 14 23 25 4 16 23 25
  59.  
  60. C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
  61. C 3 6 10 15 17 24 26
  62.  
  63. C*************************************************************
  64.  
  65. C write(6,*)' I12 '
  66. C do 460 l=1,35
  67. C write(6,1001)(I12(k,l),k=1,8)
  68. C460 continue
  69. C write(6,*)' CQ2L alias decl '
  70.  
  71. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  72. IF(IRET.EQ.0)RETURN
  73.  
  74. SEGACT MELEME
  75.  
  76. NBSOU1=LISOUS(/1)
  77. IF(NBSOU1.EQ.0)NBSOU1=1
  78. SEGINI CARA
  79. NBELT=0
  80. DO 11 L=1,NBSOU1
  81. IPT1=MELEME
  82. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  83. SEGACT IPT1
  84. ITYP=IPT1.ITYPEL
  85. C On vérifie la possibilité de l'opération
  86. IK=0
  87. DO 111 I=1,11
  88. IF(ITYP.EQ.KTA(I,1))IK=I
  89. 111 CONTINUE
  90. C write(6,*)' ityp=',ityp
  91.  
  92. IF(IK.EQ.0)THEN
  93. CALL ERREUR(29)
  94. ENDIF
  95.  
  96. NBELEM=IPT1.NUM(/2)
  97. NBELT=NBELT+NBELEM
  98. KM(1,L)=NBELEM
  99. KM(3,L)=IK
  100. 11 CONTINUE
  101. C write(6,*)' NBELEM=',nbelt,' IK=',ik
  102.  
  103. NK=0
  104. DO 1 L=1,NBSOU1
  105. IPT1=MELEME
  106. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  107. SEGACT IPT1
  108. C write(6,*)' MELEME,IPT1=',MELEME,IPT1
  109. ITYP=IPT1.ITYPEL
  110.  
  111. NBEL =KM(1,L)
  112. IK =KM(3,L)
  113. IDEC =KTA(IK,5)
  114. NP =IPT1.NUM(/1)
  115. NBNN =KTA(IK,3)
  116. NBELEM=KTA(IK,4)*NBEL
  117. NBSOUS=0
  118. NBREF=0
  119. SEGINI IPT2
  120. C write(6,*)' NBELEM,NBNN=',NBELEM,NBNN,' NBEL=',nbel
  121. KM(2,L)=IPT2
  122. IPT2.ITYPEL=KTA(IK,2)
  123. NK=0
  124. DO 33 K=1,NBEL
  125. DO 331 M=1,KTA(IK,4)
  126. NK=NK+1
  127. C write(6,*)' NK=',nk,'M=',M,'IDEC=',IDEC,'nbnn=',nbnn
  128. DO 332 I=1,NBNN
  129. IPT2.NUM(I,NK)=IPT1.NUM(I12(I,M+IDEC),K)
  130. 332 CONTINUE
  131. 331 CONTINUE
  132. 33 CONTINUE
  133. 1 CONTINUE
  134.  
  135. SEGDES IPT1,IPT2
  136.  
  137. IF(NBSOU1.EQ.1)THEN
  138. IPT3=KM(2,1)
  139. ELSE
  140. NBSOUS=NBSOU1
  141. NBELEM=0
  142. NBNN=0
  143. NBREF=0
  144. SEGINI IPT3
  145. DO 785 L=1,NBSOU1
  146. IPT3.LISOUS(L)=KM(2,L)
  147. 785 CONTINUE
  148. SEGDES IPT3
  149. ENDIF
  150.  
  151. CALL ECROBJ('MAILLAGE',IPT3)
  152.  
  153. RETURN
  154. 1011 FORMAT('L=',I3,4X,15(1X,I5))
  155. 1001 FORMAT(20(1X,I5))
  156. END
  157.  
  158.  
  159.  

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