Esope source files

   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 : 
  70 :       CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  71 :       IF(IRET.EQ.0)RETURN
  72 : 
  73 :       SEGACT MELEME
  74 : 
  75 :       NBSOU1=LISOUS(/1)
  76 :       IF(NBSOU1.EQ.0)NBSOU1=1
  77 :       SEGINI CARA
  78 :       NBELT=0
  79 :       DO 11 L=1,NBSOU1
  80 :       IPT1=MELEME
  81 :       IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  82 :       SEGACT IPT1
  83 :       ITYP=IPT1.ITYPEL
  84 : C On vérifie la possibilité de l'opération
  85 :       IK=0
  86 :       DO 111 I=1,11
  87 :       IF(ITYP.EQ.KTA(I,1))IK=I
  88 :  111  CONTINUE
  89 : C     write(6,*)' ityp=',ityp
  90 : 
  91 :       IF(IK.EQ.0)THEN
  91 :       CALL ERREUR(29)
  92 :       ENDIF
  93 : 
  94 :       NBELEM=IPT1.NUM(/2)
  95 :       NBELT=NBELT+NBELEM
  96 :       KM(1,L)=NBELEM
  97 :       KM(3,L)=IK
  98 :  11   CONTINUE
  99 : C     write(6,*)' NBELEM=',nbelt,' IK=',ik
 100 : 
 101 :       NK=0
 102 :       DO 1 L=1,NBSOU1
 103 :       IPT1=MELEME
 104 :       IF(NBSOU1.NE.1)IPT1=LISOUS(L)
 105 :       SEGACT IPT1
 106 : C     write(6,*)' MELEME,IPT1=',MELEME,IPT1
 107 :       ITYP=IPT1.ITYPEL
 108 : 
 109 :       NBEL  =KM(1,L)
 110 :       IK    =KM(3,L)
 111 :       IDEC  =KTA(IK,5)
 112 :       NP    =IPT1.NUM(/1)
 113 :       NBNN  =KTA(IK,3)
 114 :       NBELEM=KTA(IK,4)*NBEL
 115 :       NBSOUS=0
 116 :       NBREF=0
 117 :       SEGINI IPT2
 118 : C     write(6,*)' NBELEM,NBNN=',NBELEM,NBNN,' NBEL=',nbel
 119 :       KM(2,L)=IPT2
 120 :       IPT2.ITYPEL=KTA(IK,2)
 121 :       NK=0
 122 :       DO 33 K=1,NBEL
 123 :       DO 331 M=1,KTA(IK,4)
 124 :       NK=NK+1
 125 : C     write(6,*)' NK=',nk,'M=',M,'IDEC=',IDEC,'nbnn=',nbnn
 126 :       DO 332 I=1,NBNN
 127 :       IPT2.NUM(I,NK)=IPT1.NUM(I12(I,M+IDEC),K)
 128 :  332  CONTINUE
 129 :  331  CONTINUE
 130 :  33   CONTINUE
 131 :  1    CONTINUE
 132 : 
 133 :       SEGDES IPT1,IPT2
 134 : 
 135 :       IF(NBSOU1.EQ.1)THEN
 136 :       IPT3=KM(2,1)
 137 :       ELSE
 138 :       NBSOUS=NBSOU1
 139 :       NBELEM=0
 140 :       NBNN=0
 141 :       NBREF=0
 142 :       SEGINI IPT3
 143 :       DO 785 L=1,NBSOU1
 144 :       IPT3.LISOUS(L)=KM(2,L)
 145 :  785  CONTINUE
 146 :       SEGDES IPT3
 147 :       ENDIF
 148 : 
 148 :       CALL ECROBJ('MAILLAGE',IPT3)
 149 : 
 150 :       RETURN
 151 :  1011 FORMAT('L=',I3,4X,15(1X,I5))
 152 :  1001 FORMAT(20(1X,I5))
 153 :       END
 154 :  
 155 :