Télécharger la plaquette Cast3M


fr en

Télécharger cq2l.eso

Retour à la liste

Numérotation des lignes : 

cq2l

  1. C CQ2L      SOURCE    MAGN      18/05/16    21:15:00     9823           
  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.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMLENTI
  18.  
  19.       SEGMENT CARA
  20.       INTEGER KM(6,NBSOU1)
  21.       ENDSEGMENT
  22.  
  23.       DIMENSION I12(8,43)
  24.       DATA I12/
  25. C SEG2 2
  26.      &   1,2,6*0, 2,3,6*0,
  27. C TRI7 3
  28.      &   1,2,7,6,4*0, 2,3,4,7,4*0, 6,7,4,5,4*0,
  29. C QUA9 4
  30.      &   1,2,9,8,4*0, 2,3,4,9,4*0, 9,4,5,6,4*0, 8,9,6,7,4*0,
  31. C CU27 8
  32.      &   1,2,25,8,9,21,27,24,  2,3,4,25,21,10,22,27,
  33.      &   4,5,6,25,22,11,23,27,  6,7,8,25,23,12,24,27,
  34.      &   9,21,27,24,13,14,26,20, 21,10,22,27,14,15,16,26,
  35.      &   27,22,11,23,26,16,17,18, 27,23,12,24,26,18,19,20,
  36. C PR21 6
  37.      &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,
  38.      &21,18,10,11,20,15,16,8,17,21,11,12,13,20,17,9,18,21,13,14,15,20,
  39. C TRI6 4
  40.      & 1,2,6,5*0,  2,3,4,5*0, 4,5,6,5*0, 6,2,4,5*0,
  41. C PR18 8
  42.      & 1,2,6,7,16,18,2*0,2,3,4,16,8,17,2*0,4,5,6,17,9,18,2*0,
  43.      & 2,4,6,16,17,18,2*0,7,16,18,10,11,15,2*0,16,8,17,11,12,13,2*0,
  44.      & 18,17,9,15,13,14,2*0, 16,17,18,11,13,15,2*0,
  45. C TE10 8
  46.      & 1,2,6,7,4*0,7,6,8,2,4*0,7,6,8,9,4*0,7,8,9,10,4*0,
  47.      & 2,3,4,8,4*0,6,5,4,9,4*0,9,2,4,8,4*0,9,2,4,6,4*0/
  48.  
  49. C Tetrahèdres macro
  50.       DIMENSION IT12(8,8)
  51.       DATA IT12/
  52.      & 1,2,6,7,4*0  ,7,6,2,9,4*0  ,7,2,8,9,4*0  ,7,8,9,10,4*0,
  53.      & 2,3,4,8,4*0  ,6,5,4,9,4*0  ,9,2,4,8,4*0  ,9,2,4,6,4*0/
  54. C pyramide macro
  55.       DIMENSION IP12(8,10)
  56.       DATA IP12/
  57.      & 1,2,14,8,9,3*0,  2,3,4,14,10,3*0,  4,5,6,14,11,3*0,
  58.      & 6,7,8,14,12,3*0,  9,10,11,12,13,3*0,  9,10,11,12,14,3*0,
  59.      & 2,14,10,9,4*0,  4,14,10,11,4*0,  6,11,14,12,4*0,  9,10,14,12,4*0/
  60.  
  61.       DIMENSION KTA(11,5)
  62.       DATA KTA/3,7,11,33,34,35,36,6 ,40,24,26,
  63.      &         2,8,8 ,14,14,23,25,4 ,16,23,25,
  64. C NBNN (des linéaires)
  65.      &   2,   4,   4,   8,   8,   4,   5,   3,   6,   4,   5,
  66. C nb  d'éléments du découpage
  67.      &   2,   3,   4,   8,   6,   8,   6,   4,   8,   8,   8,
  68. C IDEC  seg3 tri7 qua9 cu27 pr21 te15 py19 tri6 pr18 te10 py14
  69.      &   0,   2,   5,   9,   17,  00,  00,  23,  27,  00, 00/
  70.  
  71. C SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19  TRI6 PR18 TE10 PY14
  72. C  3    7    11   33   34   35   36    6    40   24   ??
  73. C SEG2 QUA4 QUA4 CUB8 CUB8 TET4 PYR5  TRI3 PRI6 TET4 PYR5
  74. C  2    8    8    14   14   23   25    4    16   23   25
  75.  
  76. C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
  77. C  3    6    10   15   17   24   26
  78.  
  79. C*************************************************************
  80.  
  81. C     write(6,*)' I12 '
  82. C     do 460 l=1,35
  83. C     write(6,1001)(I12(k,l),k=1,8)
  84. C460  continue
  85. C     write(6,*)' CQ2L alias decl '
  86.  
  87.       CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  88.       IF(IRET.EQ.0)RETURN
  89.  
  90.       SEGACT MELEME
  91.  
  92.       NBSOU1=LISOUS(/1)
  93.       IF(NBSOU1.EQ.0)NBSOU1=1
  94.       SEGINI CARA
  95.       NBELT=0
  96.       DO 11 L=1,NBSOU1
  97.       IPT1=MELEME
  98.       IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  99.       SEGACT IPT1
  100.       ITYP=IPT1.ITYPEL
  101. C On vérifie la possibilité de l'opération
  102.       IK=0
  103.       DO 111 I=1,11
  104.       IF(ITYP.EQ.KTA(I,1))IK=I
  105.  111  CONTINUE
  106. C     write(6,*)' ityp=',ityp,' IK=',IK
  107.  
  108.       IF(IK.EQ.0)THEN
  109.       CALL ERREUR(29)
  110.       ENDIF
  111.  
  112.       NBELEM=IPT1.NUM(/2)
  113.       NBELT=NBELT+NBELEM
  114.       KM(1,L)=NBELEM
  115.       KM(3,L)=IK
  116.  11   CONTINUE
  117. C     write(6,*)' NBELEM=',nbelt,' IK=',ik
  118.  
  119.       NK=0
  120.       DO 1 L=1,NBSOU1
  121.       IPT1=MELEME
  122.       IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  123.       SEGACT IPT1
  124. C     write(6,*)' MELEME,IPT1=',MELEME,IPT1
  125.       ITYP=IPT1.ITYPEL
  126.  
  127.       NBEL  =KM(1,L)
  128.       IK    =KM(3,L)
  129.  
  130.       IF(IK.EQ.7)THEN
  131.       NBNN  =4
  132.       NBELEM=4*NBEL
  133.       NBSOUS=0
  134.       NBREF=0
  135.       SEGINI IPT5
  136. C     write(6,*)' NBELEM,NBNN=',NBELEM,NBNN,' NBEL=',nbel
  137.       KM(5,L)=IPT5
  138.       IPT5.ITYPEL=23
  139.       ENDIF
  140.  
  141.       IDEC  =KTA(IK,5)
  142.       NP    =IPT1.NUM(/1)
  143.       NBNN  =KTA(IK,3)
  144.       NBELEM=KTA(IK,4)*NBEL
  145.       NBSOUS=0
  146.       NBREF=0
  147.       SEGINI IPT2
  148. C     write(6,*)' NBELEM,NBNN=',NBELEM,NBNN,' NBEL=',nbel
  149.       KM(2,L)=IPT2
  150.       IPT2.ITYPEL=KTA(IK,2)
  151.       NK=0
  152.       NK3=0
  153.       DO 33 K=1,NBEL
  154.       DO 331 M=1,KTA(IK,4)
  155.       NK=NK+1
  156.       NK3=NK3+1
  157. C     write(6,*)' NK=',nk,'M=',M,'IDEC=',IDEC,'nbnn=',nbnn
  158.  
  159.       IF(IK.EQ.10)THEN
  160.       DO 333 I=1,NBNN
  161.       IPT2.NUM(I,NK)=IPT1.NUM(IT12(I,M),K)
  162.  333  CONTINUE
  163.       ENDIF
  164.       IF(IK.EQ.7)THEN
  165.       DO 334 I=1,NBNN
  166.       IPT2.NUM(I,NK)=IPT1.NUM(IP12(I,M),K)
  167.  334  CONTINUE
  168.       IF(M.LE.4)THEN
  169.       DO 335 I=1,(NBNN-1)
  170.       IPT5.NUM(I,NK3)=IPT1.NUM(IP12(I,M+6),K)
  171.  335  CONTINUE
  172.       ENDIF
  173.       ENDIF
  174.       IF(IK.NE.10.AND.IK.NE.7)THEN
  175.       DO 332 I=1,NBNN
  176.       IPT2.NUM(I,NK)=IPT1.NUM(I12(I,M+IDEC),K)
  177.  332  CONTINUE
  178.       ENDIF
  179.  
  180.  331  CONTINUE
  181.  33   CONTINUE
  182.  1    CONTINUE
  183.  
  184.       SEGDES IPT1,IPT2
  185.       IF(IK.EQ.7)THEN
  186.       SEGDES IPT5
  187.       ENDIF
  188.  
  189.       IF(NBSOU1.EQ.1.AND.IK.NE.7)THEN
  190.       IPT3=KM(2,1)
  191.       ELSE
  192.       NBSOUS=NBSOU1
  193.       IF(IK.EQ.7)NBSOUS=NBSOUS+NBSOU1
  194.       NBELEM=0
  195.       NBNN=0
  196.       NBREF=0
  197.       SEGINI IPT3
  198.       DO 785 L=1,NBSOU1
  199.       IPT3.LISOUS(L)=KM(2,L)
  200.  785  CONTINUE
  201.  
  202.       IF(IK.EQ.7)THEN
  203.       DO 786 L=1,NBSOU1
  204.       LL=L+NBSOU1
  205.       IPT3.LISOUS(LL)=KM(5,L)
  206.  786  CONTINUE
  207.       ENDIF
  208.  
  209.       SEGDES IPT3
  210.       ENDIF
  211.  
  212.       CALL ECROBJ('MAILLAGE',IPT3)
  213.  
  214.       RETURN
  215.  1011 FORMAT('L=',I3,4X,15(1X,I5))
  216.  1001 FORMAT(20(1X,I5))
  217.       END
  218.  
  219.  
  220.  
  221.  

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