Télécharger tq2cf.eso

Retour à la liste

tq2cf
C TQ2CF     SOURCE    CB215821  26/08/24    21:18:40     12622          
      SUBROUTINE TQ2CF(MAIL,MELEMQ,MELEM1,MF1,MELAF,
     & MPFD,MFD,MFD2,MFF2,NOMC,IKR)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C*************************************************************************
C     Ce SP cree à partir de QCF (MAIL) les connectivités suivantes
C     MELEMQ = MAIL ou le QCF correspondant si MAIL non QCF
C     Si NOMC=CENTRE on ne calcule que les CENTREs
C
C               A : Connectivites elements  -> faces     (ELTFA)  MELAF
C               B : Support geometrique des centres      (CENTRE) MELEM1
C               C : Connectivites faces -> sommets       (FACEP)  MPFD
C               D : Connectivites faces -> elements      (FACEL)  MFD
C partitionne   D': Connectivites faces -> elements      (FACEL2) MFD2
C               E : Support geometrique des faces        (FACE)   MF1
C               F : Connectivite entre tous les noeuds   (MAILFACE) MFF2
C                    d'une face
C
C     IKT = 0 Ce n'était pas des QCF
C     IKT = 1 C'était des QCF
C     IKL = 0 Ce n'était pas des Lineaires
C     IKL = 1 C'était des Lineaires
C     IKR = 0 Famille non reconnue
C     IKR = 1 C'était des QCF
C     IKR = 2 C'était des Lineaires
C     IKR = 3 C'était des Macro
C
C*************************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC CCGEOME
-INC SMELEME
      POINTEUR MELEM1.MELEME,MF1.MELEME,MELAF.MELEME,MPFD.MELEME
      POINTEUR MFD.MELEME,MFD2.MELEME,MFF2.MELEME
-INC SMLENTI
      PARAMETER (NBTE=21)
      CHARACTER*8 NOM8,LTYPL(NBTE),NOMC
      DIMENSION ITC(7),KTA(7,3),JNF(6,7),KNPF(6,7)
      DIMENSION INPF(8),INPP(8),INPT(8),INPT2(8),INPT3(8),INPT4(8)
 
      DATA LTYPL/
     &  'SEG3    ','TRI7    ','QUA9    ',
     &  'CU27    ','PR21    ','TE15    ','PY19    ',
     &  'SEG2    ','TRI3    ','QUA4    ',
     &  'CUB8    ','PRI6    ','TET4    ','PYR5    ',
     &  'SEG3    ','TRI6    ','QUA9    ',
     &  'CU27    ','PR18    ','TE10    ','PY14    '/
 
      DATA ITC/ 2,7,9,27,21,15,19/
 
      DATA KTA/
C nb de faces par type d'élément
     &         2, 3, 4, 6, 5, 4, 5,
C numero type elt pour conectivités elt -> face
     &         2, 4, 8,16,25,23,9,
C Idc3
     &         20,22,25, 0, 6,11,15/
 
      DATA INPT/1,0,3,0,0,6,0,10/
C?    DATA INPT2/1,0,2,0,0,4,0,8/
      DATA INPT2/2,0,3,0,0,5,0,9/
C                seg2,seg3,tri4,qua5
C
C  nombre de noeuds a prendre en compte pour les faces
      DATA INPT3/1,0,3,0,0,7,0,9/
C  type des elements correspondants a des faces
      DATA INPT4/1,0,3,0,0,7,0,11/
C                poi1,seg3,tri7,qua9
C
      DATA KNPF/
     &          1,1,0,0,0,0,
     &          3,3,3,0,0,0,
     &          3,3,3,3,0,0,
     &          8,8,8,8,8,8,
     &          6,6,8,8,8,0,
     &          6,6,6,6,0,0,
     &          8,6,6,6,6,0/
 
C CORRESPONDANCE
C  maillage        SEG3  TRI7  QUA9  CU20  PR21  TE15  PY19
C                   |     |     |     |     |     |     |
C                   V     V     V     V     V     V     V
C   faces          SEG2  TRI3  QUA4  PRI6  PYR5  TET4  QUA5
C
C ALIAS            seg2  tri3  qua4  pri6  pyr5  tet4  qua5
C ALIAS numero      2     4     8     16    25    23    9
 
 
      DATA JNF/1,3,0,0,0,0,
     &         2,4,6,0,0,0,              2,4,6,8,0,0,
     &         25,26,21,22,23,24,        19,20,16,17,18,0,
     &         12,11,13,14,0,0,          14,15,16,17,18,0/
 
      DIMENSION INF(8,29)
C CU20
      DATA INF/1,2,3,4,5,6,7,8,      13,14,15,16,17,18,19,20,
     &         1,2,3,10,15,14,13,9,  3,4,5,11,17,16,15,10,
     &         5,6,7,12,19,18,17,11, 7,8,1,9,13,20,19,12,
C PR15
     &         1,2,3,4,5,6,0,0,      10,11,12,13,14,15,0,0,
     &         1,2,3,8 ,12,11,10,7,  3,4,5,9 ,14,13,12,8 ,
     &         5,6,1,7,10,15,14,9 ,
C TE15
     &  1,2,3,8,10,7,0,0, 1,2,3,4,5,6,0,0, 3,4,5,9,10,8,0,0,
     &  1,6,5,9,10,7,0,0,
C PY15
     &  1,2,3,4,5,6,7,8,  1,2,3,10,13,9,0,0,  3,4,5,11,13,10,0,0,
     &  5,6,7,12,13,11,0,0,  7,8,1,9,13,12,0,0,
C SEG3
     &  1,0,0,0,0,0,0,0, 3,0,0,0,0,0,0,0,
C TRI7
     &  1,2,3,0,0,0,0,0, 3,4,5,0,0,0,0,0, 5,6,1,0,0,0,0,0,
C QUA9
     &  1,2,3,0,0,0,0,0, 3,4,5,0,0,0,0,0, 5,6,7,0,0,0,0,0,
     &  7,8,1,0,0,0,0,0/
 
C****
C   description des faces avec les points centre des surfaces
      DIMENSION INF2(9,29)
C CU27
      DATA INF2/1,2,3,4,5,6,7,8,25,     13,14,15,16,17,18,19,20,26,
     &          1,2,3,10,15,14,13,9,21,  3,4,5,11,17,16,15,10,22,
     &          5,6,7,12,19,18,17,11,23, 7,8,1,9,13,20,19,12,24,
C PR21
     &         1,2,3,4,5,6,19,0,0,      10,11,12,13,14,15,20,0,0,
     &         1,2,3,8 ,12,11,10,7,16,  3,4,5,9 ,14,13,12,8 ,17,
     &         5,6,1,7,10,15,14,9 ,18,
C TE15
     &  1,2,3,8,10,7,12,0,0,   1,2,3,4,5,6,11,0,0,
     &  3,4,5,9,10,8,13,0,0,   1,6,5,9,10,7,14,0,0,
C PY19
     &  1,2,3,4,5,6,7,8,14,  1,2,3,10,13,9,15,0,0,
     &  3,4,5,11,13,10,16,0,0, 5,6,7,12,13,11,17,0,0,
     &  7,8,1,9,13,12,18,0,0,
C SEG3
     &  1,0,0,0,0,0,0,0,0, 3,0,0,0,0,0,0,0,0,
C TRI7
     &  1,2,3,0,0,0,0,0,0, 3,4,5,0,0,0,0,0,0, 5,6,1,0,0,0,0,0,0,
C QUA9
     &  1,2,3,0,0,0,0,0,0, 3,4,5,0,0,0,0,0,0, 5,6,7,0,0,0,0,0,0,
     &  7,8,1,0,0,0,0,0,0/
 
C****
      MELEME=MAIL
      MELEMQ=MAIL
      IKR=0
      IPAS=0
 111  CONTINUE
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
C On regarde à qui on a à faire
C     SONT ce des QCF IKT=1  ?
      IKKT=1
      IKKL=1
      IKKM=1
      NBELEM=0
      NBSOU1=NBSOUS
      IF(NBSOU1.EQ.0)NBSOU1=1
      DO 1670 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NOM8=NOMS(IPT1.ITYPEL)//'    '
      CALL OPTLI(IP,LTYPL,NOM8,NBTE)
      IF(IP.EQ.0.OR.IP.GT.7)IKKT=0
      IF(IP.LT.8.OR.IP.GT.14)IKKL=0
      IF(IP.LT.15.OR.IP.GT.21)IKKM=0
      NBELEM=NBELEM+IPT1.NUM(/2)
 1670 CONTINUE
 
      IF(IPAS.EQ.0)THEN
      IF(IKKT.NE.0)IKR=1
      IF(IKKL.NE.0)IKR=2
      IF(IKKM.NE.0)IKR=3
      ENDIF
 
      IF(IKKT.EQ.0.AND.IKKL.EQ.0)RETURN
      IF(IKKL.NE.0)THEN
      CALL ECROBJ('MAILLAGE',MELEME)
      CALL CHANQU
      CALL C20227
      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      MELEMQ=MELEME
      IPAS=1
      GO TO 111
      ELSEIF(IKKM.NE.0)THEN
      CALL ECROBJ('MAILLAGE',MELEME)
      CALL CQ2L
      CALL CHANQU
      CALL C20227
      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      MELEMQ=MELEME
      IPAS=1
      GO TO 111
      ENDIF
C Ce sont des quadratiques
 
      NBPT=nbpts
      JG=NBPT
      SEGINI MLENTI,MLENT1
 
C ****** Création Pts CENTRE
      NBELC=NBELEM
      NBNN=1
      NBSOUS=0
      NBREF=0
      SEGINI MELEM1
      MELEM1.ITYPEL=1
 
      CALL INITI(INPF,8,0)
 
      NPTF=0
      K0=0
      DO 1671 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NBEL=IPT1.NUM(/2)
      NP  =IPT1.NUM(/1)
      NOM8=NOMS(IPT1.ITYPEL)//'    '
      CALL OPTLI(IP,LTYPL,NOM8,7)
      NBF=KTA(IP,1)
      IC =ITC(IP)
 
      DO 1672 K=1,NBEL
      K0=K0+1
      MELEM1.NUM(1,K0)=IPT1.NUM(IC,K)
      MELEM1.ICOLOR(K0)=6
      DO 1673 I=1,NBF
      ITF=LECT(IPT1.NUM(JNF(I,IP),K))
      IF(ITF.NE.0)GO TO 1673
      NPTF=NPTF+1
      LECT(IPT1.NUM(JNF(I,IP),K))=NPTF
      MLENT1.LECT(NPTF)=IPT1.NUM(JNF(I,IP),K)
      NPF=KNPF(I,IP)
      INPF(NPF)=INPF(NPF)+1
 1673 CONTINUE
 
 1672 CONTINUE
 1671 CONTINUE
      call crech1(melem1,1)
      SEGINI, MLENT2=MLENTI
 
      IF(NOMC.EQ.'CENTRE')GO TO 1901
 
C ****** Création Pts FACE
      NBELEM=NPTF
      NBNN=1
      NBSOUS=0
      NBREF=0
      SEGINI MF1
      MF1.ITYPEL=1
 
      DO 1674 K=1,NPTF
      MF1.NUM(1,K)=MLENT1.LECT(K)
      MF1.ICOLOR(K)=4
 1674 CONTINUE
 
C ****** Création ELTFA
      NBSOUS=NBSOU1
      NBREF=0
      NBNN=0
      NBELEM=0
      SEGINI MELAF
 
      DO 1771 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NBELEM=IPT1.NUM(/2)
      NP  =IPT1.NUM(/1)
      NOM8=NOMS(IPT1.ITYPEL)//'    '
      CALL OPTLI(IP,LTYPL,NOM8,7)
      NBNN=KTA(IP,1)
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      IPT2.ITYPEL=KTA(IP,2)
      MELAF.LISOUS(L)=IPT2
 
 
      DO 1772 K=1,NBELEM
      DO 1773 I=1,NBNN
      IPT2.NUM(I,K)=IPT1.NUM(JNF(I,IP),K)
      IPT2.ICOLOR(K)=1
      MLENT1.LECT(NPTF)=IPT1.NUM(JNF(I,IP),K)
 1773 CONTINUE
 
 1772 CONTINUE
 1771 CONTINUE
 
      IF(NBSOU1.EQ.1)THEN
      IPT2=MELAF.LISOUS(1)
      SEGSUP MELAF
      MELAF=IPT2
      ENDIF
 
C ****** Création FACEL
      SEGACT MELEME,MELEM1
      NBNN=3
      NBELEM=NPTF
      NBSOUS=0
      NBREF=0
      SEGINI MFD
      MFD.ITYPEL=3
      K0=0
      DO 1781 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NBEL=IPT1.NUM(/2)
      NOM8=NOMS(IPT1.ITYPEL)//'    '
      CALL OPTLI(IP,LTYPL,NOM8,7)
      NBF=KTA(IP,1)
 
      DO 1987 K=1,NBEL
      K0=K0+1
      DO 1782 I=1,NBF
      I2=IPT1.NUM(JNF(I,IP),K)
      NF=LECT(I2)
      MFD.NUM(2,NF)=I2
      MFD.ICOLOR(NF)=2
      I3=MFD.NUM(3,NF)
      NC=MELEM1.NUM(1,K0)
      IF(I3.EQ.0)THEN
      MFD.NUM(1,NF)=NC
      MFD.NUM(3,NF)=NC
      MFD.ICOLOR(NF)=2
      ELSE
        IF(NC.LT.I3)THEN
        MFD.NUM(1,NF)=NC
        MFD.ICOLOR(NF)=2
        ELSE
        MFD.NUM(1,NF)=I3
        MFD.NUM(3,NF)=NC
        MFD.ICOLOR(NF)=2
        ENDIF
      ENDIF
 1782 CONTINUE
 1987 CONTINUE
 1781 CONTINUE
 
C ******* Mise au propre FACEL dans le cas Navier-Stokes
      NBNN=2
      NBELEM=NPTF
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      IPT2.ITYPEL=2
 
      NBNN=3
      NBELEM=NPTF
      NBSOUS=0
      NBREF=0
      SEGINI IPT3
      IPT3.ITYPEL=3
 
      I2=0
      I3=0
 
      NBEL=MFD.NUM(/2)
      DO 1783 K=1,NBEL
      N1=MFD.NUM(1,K)
      NC=MFD.NUM(2,K)
      N3=MFD.NUM(3,K)
      IF(N1.EQ.N3)THEN
      I2=I2+1
      IPT2.NUM(1,I2)=N1
      IPT2.NUM(2,I2)=NC
      IPT2.ICOLOR(I2)=3
      ELSE
      I3=I3+1
      IPT3.NUM(1,I3)=N1
      IPT3.NUM(2,I3)=NC
      IPT3.NUM(3,I3)=N3
      IPT3.ICOLOR(I3)=3
      ENDIF
 1783 CONTINUE
 
      NBNN=2
      NBELEM=I2
      NBSOUS=0
      NBREF=0
      SEGADJ IPT2
 
      NBNN=3
      NBELEM=I3
      NBSOUS=0
      NBREF=0
      SEGADJ IPT3
 
      NBNN=0
      NBELEM=0
      NBSOUS=2
      NBREF=0
      SEGINI MFD2
      MFD2.LISOUS(1)=IPT3
      MFD2.LISOUS(2)=IPT2
 
C ****** Création FACEP
      CALL INITI(INPP,8,0)
      NS=0
      DO 1780 L=1,8
      NBELEM=INPF(L)
      INPF(L)=0
      IF(NBELEM.EQ.0)GO TO 1780
      NS=NS+1
      NBNN=(L+1)/2+1
      NBSOUS=0
      NBREF=0
      SEGINI IPT3
      INPP(L)=IPT3
      IPT3.ITYPEL=INPT2(L)
 
 1780 CONTINUE
 
      SEGACT MELEME
 
      DO 1881 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NBEL=IPT1.NUM(/2)
      NOM8=NOMS(IPT1.ITYPEL)//'    '
      CALL OPTLI(IP,LTYPL,NOM8,7)
      NBF=KTA(IP,1)
      IDC3=KTA(IP,3)
      DO 1882 K=1,NBEL
      DO 1883 I=1,NBF
      I2=IPT1.NUM(JNF(I,IP),K)
      NF=LECT(I2)
      IF(NF.EQ.0)GO TO 1883
      LECT(I2)=0
      NPF=KNPF(I,IP)
      IPT3=INPP(NPF)
      SEGACT IPT3*MOD
      IPOS=INPF(NPF)+1
      INPF(NPF)=IPOS
      J3=0
      DO 1884 J=1,NPF,2
      J3=J3+1
      IPT3.NUM(J3,IPOS)=IPT1.NUM(INF(J,I+IDC3),K)
      IPT3.ICOLOR(IPOS)=5
 1884 CONTINUE
      IPT3.NUM(J3+1,IPOS)=I2
      IPT3.ICOLOR(IPOS)=5
 1883 CONTINUE
 1882 CONTINUE
 1881 CONTINUE
 
      NBSOUS=0
      DO 1885 I=1,8
      IF(INPP(I).NE.0)NBSOUS=NBSOUS+1
 1885 CONTINUE
 
      IF(NBSOUS.EQ.1)THEN
      MPFD=IPT3
      ELSE
      NBREF=0
      NBELEM=0
      NBNN=0
      SEGINI MPFD
      NS=0
      DO 1886 I=1,8
      IF(INPP(I).NE.0)THEN
      NS=NS+1
      MPFD.LISOUS(NS)=INPP(I)
      ENDIF
 1886 CONTINUE
      ENDIF
 
C ****** Création MAILFACE
C     !!!!! atention on reutilise INPF
      CALL INITI(INPP,8,0)
      NS=0
      DO 1970 L=1,8
      NBELEM=INPF(L)
      INPF(L)=0
      IF(NBELEM.EQ.0)GO TO 1970
      NS=NS+1
      NBNN=INPT3(L)
      NBSOUS=0
      NBREF=0
      SEGINI IPT3
      INPP(L)=IPT3
      IPT3.ITYPEL=INPT4(L)
 
 1970 CONTINUE
 
      SEGACT MELEME
 
      DO 1981 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NBEL=IPT1.NUM(/2)
      NOM8=NOMS(IPT1.ITYPEL)//'    '
      CALL OPTLI(IP,LTYPL,NOM8,7)
      NBF=KTA(IP,1)
      IDC3=KTA(IP,3)
      DO 1982 K=1,NBEL
      DO 1983 I=1,NBF
      I2=IPT1.NUM(JNF(I,IP),K)
      NF=MLENT2.LECT(I2)
      IF(NF.EQ.0)GO TO 1983
      MLENT2.LECT(I2)=0
      NPF=KNPF(I,IP)
      IPT3=INPP(NPF)
      SEGACT IPT3*MOD
      IPOS=INPF(NPF)+1
      INPF(NPF)=IPOS
      NPPF=INPT3(NPF)
      DO 1984 J=1,NPPF
      IPT3.NUM(J,IPOS)=IPT1.NUM(INF2(J,I+IDC3),K)
 1984 CONTINUE
      IPT3.ICOLOR(IPOS)=5
 1983 CONTINUE
 1982 CONTINUE
 1981 CONTINUE
 
      NBSOUS=0
      DO 1985 I=1,8
      IF(INPP(I).NE.0)NBSOUS=NBSOUS+1
 1985 CONTINUE
 
      IF(NBSOUS.EQ.1)THEN
      MFF2=IPT3
      ELSE
      NBREF=0
      NBELEM=0
      NBNN=0
      SEGINI MFF2
      NS=0
      DO 1986 I=1,8
      IF(INPP(I).NE.0)THEN
      NS=NS+1
      MFF2.LISOUS(NS)=INPP(I)
      ENDIF
 1986 CONTINUE
      ENDIF
C     write(6,*)' **** voici MAILFACE dans tq2cf *** '
C     call ecmail(mff2)
C     write(6,*) '*********************** '
C
 1901 CONTINUE
      SEGSUP MLENTI,MLENT1,MLENT2
 1001 FORMAT(20(1X,I5))
      END
 
 
 
 
 

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