Sources Esope | Cast3M

regene
C REGENE    SOURCE    GOUNAND   21/04/13    21:15:12     10956          
      SUBROUTINE REGENE ( IPTT )
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC CCGEOME
      SEGMENT INOU(0)
      PARAMETER ( NKNE1=292)
      PARAMETER ( NKNE2=121)
      PARAMETER ( NKNEL=NKNE1+NKNE2)
      DIMENSION KNEL1(NKNE1),KNEL2(NKNE2),KNEL(NKNEL)
      EQUIVALENCE ( KNEL(1),kNEL1(1)),(KNEL(293),KNEL2(1))
      DIMENSION  KST(26),KPS1(2,26),KS1(2,45),KPI1(45) ,KPS2(2,26)
      DIMENSION  KSTT(6) ,KS2(2,38),KPI2(38)
      logical ltelq,FLNOVE
      CHARACTER*4 MOVERI(1)
C
C KST DONNE LE SOUS TYPE , KPS1(1, ) DONNE LE NB DE SEGMENT A TESTER
C KPS1(2, ) DONNE LA PLACE DANS LE TABLEAU KS1(KPS1(2,1) = 1)
C KS1(2, ) DONNE LES SEGMENTS A TESTER,KPI1(NKS1) SI NEGATIF DIT OU SE
C  METTRE DANS KNEL POUR FABRIQUER LE NOUVEL ELEMENT SI POSITIF DIT OU S
C  POSITIONNER DANS KPS2 POUR TESTS COMPLEMENTAIRES
C
c  CREATION : ???
C  #2204 chat, 1996/07/01 : regeneration des prismes en tetra et pyramides
c  #     bp,   2013/02/05 : SEG2->POI1 + ajout commentaires + ajout verif
c
c rem : tout n'est pas possible, car on peut obtenir des polygones et
c  polyhedres inconnu dans castem (ex.1 : qua4 avec 1 point sur l'axe
c + volu rota -> on obtient un polyhedre à 7 noeuds // ex.2: pri6 avec
c seulement noeud 1 = noeud 2 -> polyhedre à 5 noeuds avec 2 faces tri3
c et 2 faces qua4)
c
C rappel de numgeo : ITYPEL=
c  1 POI1, 2 SEG2, 3 SEG3, 4 TRI3, 5 TRI4, 6 TRI6, 7 TRI7,
c  8 QUA4, 9 QUA5, 10 QUA8, 11 QUA9, 12 RAC2, 13 RAC3,
c 14 CUB8, 15 CU20, 16 PRI6, 17 PR15, 18 LIA3, 19 LIA4, 20 LIA6, 21 LIA8,
c 22 MULT, 23 TET4, 24 TE10, 25 PYR5, 26 PY13, ...
 
C              1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
      DATA KST/0,1,2,2,2,3,3,4,4,6 ,6 , 0, 0,16,17,-1,-4,
     # 0,0,0,0,0,0,0,0,0/
      DATA KSTT/2,23,25,2,24,26/
C               1   2    3    4   5   6   7   8   9   10   11   12  13
      DATA KPS1/0,0,1,45,2,33,3,1,3,1,3,4,3,4,4,7,4,7,4,11,4,11,0,0,0,0,
C      14   15   16   17   18  19  20  21  22  23  24  25  26
     # 9,15,9,24,5,35,5,40,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
c              1            4            7                11
      DATA KS1/1,2,1,3,2,3, 1,3,1,5,3,5, 1,2,1,4,2,3,3,4, 1,3,1,7,3,5,
c           15                                   24
     # 5,7, 1,2,1,4,1,5,2,3,2,6,3,4,3,7,5,6,5,8, 1,3,1,7,1,13,3,5,3,15,
c                            33       35                   40
     # 5,7,5,17,13,15,13,19, 1,2,2,3, 1,2,4,5,1,4,2,5,3,6, 1,3,10,12,
c                      45
     # 1,10,3,12,5,14, 1,2/
c                1           4               7                   11
      DATA KPI1/-1, -3, -3, -5, -8, -8,-11, -14, -11, -14, -17, -23,
c                15                24                          33
     # -29, -35 ,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18, -1,-3,
c      35               40                 45
     # 19,20,21,22,-319,23,24,25,26,-400, -413/
c               1   ...                       ... 9
      DATA KPS2/2,1,2,3,2,5,1,7,1,8,1,9,1,10,1,11,1,12,
c     10   ...                             ... 18
     # 2,13,2,15,2,17,1,19,1,20,1,21,1,22,1,23,1,24,
c     19 ...         22
     # 1,25,1,26,3,27,2,30,
c     23 ...         26
     # 1,32,1,33,3,34,2,37/
c              1        2        3        4   5   6   7   8   9
      DATA KS2/4,3,5,6, 2,3,5,8, 4,8,2,6, 6,7,3,7,7,8,4,8,7,8,6,7,
c      10       11        12         13   14    15   16    17    18
     # 7,5,13,15,3,5,13,19,7,19,3,15,15,17,5,17,17,19,7,19,17,19,15,17,
c     19  20  21          22      23   24   25            26
     # 1,3,4,6,2,5,3,6,0,0,3,6,0,0,1,5,10,14,3,12,5,14,0,0,5,14,0,0/
c                 1         2        3        4   5   6   7    8    9
      DATA KPI2/-41 ,-47, -53,-59, -65,-71, -77,-83,-89,-95,-101,-107,
c        10        11        12        13   14   15   16   17   18
     # -113,-128,-143,-158,-173,-188,-203,-218,-233,-248,-263,-278,
c        19   20   21             22        23   24   25
     # -293,-297,-301,-305,-309,-297,-314,-324,-334,-344,-354,
c             26
     # -374,-364,-387/
      DATA KNEL1/1,3, 1,2, 1,4,5, 1,2,3, 1,3,4, 1,2,3, 1,4,5,6,7,8,
     # 1,2,3,4,5,6, 1,2,3,6,7,8 ,1,2,3,4,7,8,
     # 1,6,5,3,7,8, 1,3,4,5,7,8, 1,8,5,2,7,6, 1,2,3,5,6,7,
     # 1,6,2,4,7,3, 1,4,8,2,3,7, 1,2,4,5,6,8, 1,5,2,4,8,3,
     # 1,2,3,5,6,7, 1,4,5,2,3,6, 1,5,2,4,7,3, 1,4,8,2,3,6,
     # 1,10,15,14,13,9,8,16,20,7,11,17,18,19,12,
     # 1,4,5,6,7,8,9,11,12,13,16,17,18,19,20,
     # 1,12,19,20,13,9,2,18,14,3,11,17,16,15,10,
     # 1,2,3,4,5,6,9,10,11,13,14,15,16,17,18,
     # 1,14,15,10,3,2,8,16,4,7,18,17,11,5,6,
     # 1,8,7,12,19,20,2,6,18,3,4,5,11,17,16,
     # 1,2,3,6,7,8,9,10,12,13,14,15,18,19,20,
     # 1,9,13,14,15,2,8,20,16,7,12,19,18,17,6,
     # 1,2,3,4,5,8,9,10,11,13,14,15,16,17,20,
     # 1,8,7,20,13,9,2,6,14,3,4,5,16,15,10,
     # 1,9,13,10,3,2,8,20,4,7,12,19,11,5,6,
     # 1,8,7,12,19,9,2,6,18,3,4,5,11,17,10/
      DATA KNEL2/4,6,5,1,  1,2,3,4,  1,2,3,6,  1,2,3,5,
     # 2,3,6,5,1,  1,3,6,4,2,  1,2,5,4,3,
     # 10,15,14,13,12,11,7,9,8,1,  1,2,3,4,5,6,7,8,9,10,
     # 1,2,3,4,5,6,15,13,9,14,  1,2,3,4,5,6,11,8,13,12,
     # 1,2,3,4,5,6,7,11,15,10,
     # 3,4,5,9,14,13,12,8,2,6,15,11,1,  1,6,5,9,14,15,10,7,2,4,13,11,3,
     # 1,2,3,8,12,11,10,7,6,4,13,15,5,
     # 1/
      DATA MOVERI/'VERI'/
cbp : ajout possibilite de verifier
      IVERI=0
      CALL LIRMOT(MOVERI,1,IVERI,0)
      FLNOVE=(IVERI.eq.0)
C     DEBUT PROGRAMME
      IPT1=IPTT
      SEGACT IPT1
      MELEME=IPT1
      NBSO=LISOUS(/1)
      SEGINI INOU
      NBREF=0
      NBSOUS=0
      DO 1 II= 1,MAX(1,NBSO)
      IF (NBSO.NE.0) THEN
       MELEME=IPT1.LISOUS(II)
       SEGACT MELEME
      ENDIF
      IPT7=0
      IF(IIMPI.NE.0) WRITE(IOIMP,500) ITYPEL,KST(ITYPEL)
  500 FORMAT(' ITYPEL KST(ITYPEL) ',2I5)
      IF(KST(ITYPEL).EQ.0) INOU(**)=MELEME
      IF(KST(ITYPEL).EQ.0) GO TO 1000
      IA= KPS1(1,ITYPEL)
      NBELEM=NUM(/2)
      NBNN=NUM(/1)
      SEGINI IPT2
      IF( KST(ITYPEL).GT.0) THEN
         NBNN=NBNNE(KST(ITYPEL))
         SEGINI IPT3
         IPT3.ITYPEL=KST(ITYPEL)
      ELSE
         IPO = -KST(ITYPEL)
         NPO = KSTT(IPO)
         NBNN = NBNNE( KSTT(IPO + 1))
         SEGINI IPT3
         IPT3.ITYPEL=KSTT(IPO + 1)
         NBNN = NBNNE ( KSTT(IPO+2))
         SEGINI IPT7
         IPT7.ITYPEL=KSTT(IPO + 2)
         IF( NPO . GT . 2) THEN
             CALL ERREUR(19)
             RETURN
         ENDIF
      ENDIF
      IF(IIMPI.NE.0) WRITE(IOIMP,501) IA,NBNN
  501 FORMAT(' NB DE SEGMENT A TESTER,NB NOEUD DU SOUS TYPE',2I5)
      IPT2.ITYPEL=ITYPEL
      IEL2=0
      IEL3=0
      IEL7=0
C==== BOUCLE SUR LES ELEMENTS ========
      DO 3 JJ=1,NBELEM
      IB=KPS1(2,ITYPEL) -1
      DO 4 J=1,IA
      IB=IB+1
      IF(IIMPI.GE.5) WRITE(IOIMP,*) 'ON TESTE ',KS1(1,IB),KS1(2,IB)
      IF( NUM(KS1(1,IB),JJ) .NE. NUM(KS1(2,IB),JJ) ) GO TO 4
C  ** ON A TROUVER UNE EGALITE DE NOEUD. FAUT-IL FAIRE D'AUTRES TESTS
C
      IT1=KPI1(IB)
      IF(IT1.LT.0) GO TO 100
C     TESTS COMPLEMENTAIRES
      IC=KPS2(1,IT1)
      ID=KPS2(2,IT1)-1
      DO 5 K=1,IC
      ID=ID+1
      IF(IIMPI.GE.5) WRITE(IOIMP,*) 'on teste ',KS2(1,ID),KS2(2,ID)
      IF(KS2(1,ID).EQ.0) GO TO 51
      IF( NUM(KS2(1,ID),JJ) .NE. NUM(KS2(2,ID),JJ) ) GO TO 5
   51 CONTINUE
      IT2=KPI2(ID)
      IF(IT2.LT.0) IT1=IT2
      IF(IT2.LT.0) GO TO 100
   5  CONTINUE
C UN POINT DOUBLE MAIS PAS LES TESTS COMPLEMENTAIRES
      INTERR(1)=JJ
      CALL ERREUR(-303)
   4  CONTINUE
      IF(IIMPI.NE.0) WRITE(IOIMP,502) JJ
  502 FORMAT(' ELEM NUMERO ' ,I5,' PAS CHANGE ')
C PAS DE PTS DOUBLE ON RECOPIE
      IEL2=IEL2+1
      DO 6 L=1,NUM(/1)
      IPT2.NUM(L,IEL2)=NUM(L,JJ)
c       bp : ajout verif
        if(FLNOVE) goto 6
        if(L.le.1) goto 6
        do 62 L2=1,(L-1)
          if(IPT2.NUM(L2,IEL2).ne.IPT2.NUM(L,IEL2)) goto 62
          WRITE(IOIMP,*) 'Cas non prevu pour le maillage',IPT2
          INTERR(1)=IEL2
          CALL ERREUR(-303)
  62    continue
   6  CONTINUE
      IPT2.ICOLOR(IEL2)=ICOLOR(JJ)
      GO TO 3
  100 CONTINUE
      IPT5=IPT3
      IEL3=IEL3+1
      IEL5=IEL3
c     cas particulier ou on a le choix entre 2 type d elements
c     ex : PRI6 -> TET4 ou PYR5
      IF( IPT7.NE.0) THEN
       IF(IT1.EQ.-309.OR.IT1.EQ.-314.OR.IT1.EQ.-319.OR.IT1.EQ.-374
     # .OR.IT1.EQ.-387.OR.IT1.EQ.-400) THEN
        IPT5=IPT7
        IEL3=IEL3-1
        IEL7=IEL7+1
        IEL5=IEL7
       ENDIF
      ENDIF
      IPT5.ICOLOR(IEL5)=ICOLOR(JJ)
      IT1=-IT1
      IF(IIMPI.NE.0) WRITE(IOIMP,503) JJ
  503 FORMAT(' ELEM NUMERO ' ,I5,' CHANGER ')
      DO 101 L=1,IPT5.NUM(/1)
      IPT5.NUM(L,IEL5)=NUM(KNEL(IT1),JJ)
      IT1=IT1+1
c       bp : ajout verif
        if(FLNOVE) goto 101
        if(L.le.1) goto 101
        do 102 L2=1,(L-1)
          if(IPT5.NUM(L2,IEL5).ne.IPT5.NUM(L,IEL5)) goto 102
          WRITE(IOIMP,*) 'Cas non prevu pour le maillage',IPT5
          INTERR(1)=IEL5
          CALL ERREUR(-303)
 102    continue
 101  CONTINUE
   3  CONTINUE
C==== FIN DE BOUCLE SUR LES ELEMENTS ========
C
C ** ON REGARDE SI IPT2 ET IPT3 EXISTE VRAIMENT PUIS ON LES RECREE
C ** A LA BONNE DIMENSION
C
      IF(IEL2.EQ.0) GO TO 10
      IF(IEL2.EQ.NUM(/2)) THEN
      INOU(**)=MELEME
      SEGSUP IPT2,IPT3
      IF(IPT7.NE.0) SEGSUP IPT7
      GO TO 1000
      ELSE
      NBNN=IPT2.NUM(/1)
      NBELEM=IEL2
      SEGINI IPT4
      DO 11 K=1,IEL2
      IPT4.ICOLOR(K)=IPT2.ICOLOR(K)
      DO 11 L=1,NBNN
      IPT4.NUM(L,K)=IPT2.NUM(L,K)
 11   CONTINUE
      IPT4.ITYPEL=IPT2.ITYPEL
      SEGSUP IPT2
      INOU(**)=IPT4
      SEGDES IPT4
      ENDIF
  10  CONTINUE
      IF(IEL3.EQ.NUM(/2)) THEN
      INOU(**)=IPT3
      SEGDES IPT3
      SEGSUP IPT2
      IF(IPT7.NE.0) SEGSUP IPT7
      GO TO 1000
      ELSE
      NBNN=IPT3.NUM(/1)
      NBELEM=IEL3
      SEGINI IPT4
      DO 12 K=1,NBELEM
      IPT4.ICOLOR(K)=IPT3.ICOLOR(K)
      DO 12 L=1,NBNN
      IPT4.NUM(L,K)=IPT3.NUM(L,K)
  12  CONTINUE
      IPT4.ITYPEL=IPT3.ITYPEL
      SEGSUP IPT3
      SEGDES IPT4
      IF(IEL3.NE.0) INOU(**)=IPT4
      ENDIF
      IF(IEL7.EQ.NUM(/2)) THEN
      INOU(**)=IPT7
      SEGDES IPT7
      SEGSUP IPT3
      SEGSUP IPT2
      GO TO 1000
      ELSE
C# MC 03/11/97 : on passe ici avec IPT7=0 dans kp2_test.dgibi
      IF(IPT7.NE.0) THEN
      NBNN=IPT7.NUM(/1)
      NBELEM=IEL7
      SEGINI IPT4
      DO 13 K=1,NBELEM
      IPT4.ICOLOR(K)=IPT7.ICOLOR(K)
      DO 13 L=1,NBNN
      IPT4.NUM(L,K)=IPT7.NUM(L,K)
  13  CONTINUE
      IPT4.ITYPEL=IPT7.ITYPEL
      SEGSUP IPT7
      SEGDES IPT4
       IF(IEL7.NE.0)INOU(**)=IPT4
      ENDIF
      ENDIF
 
 1000 CONTINUE
      IF(NBSO.NE.0) SEGDES MELEME
    1 CONTINUE
      II=INOU(/1)
      IF(II.EQ.0) THEN
      IRETOU=IPT1
      GO TO 15
      ENDIF
      IRETOU=INOU(1)
      IF(II.EQ.1) GO TO 15
      DO 16 J=2,II
      INN=INOU(J)
      ltelq=.false.
      CALL FUSE( IRETOU,INN,IPT5,ltelq)
      IRETOU=IPT5
   16 CONTINUE
   15 CONTINUE
      IPTT=IRETOU
      RETURN
      END