Télécharger la plaquette Cast3M


fr en

Télécharger kcha2.eso

Retour à la liste

Numérotation des lignes : 

kcha2

  1. C KCHA2     SOURCE    CB215821  20/11/25    13:30:54     10792          
  2. C
  3.       SUBROUTINE KCHA2(IPCHE,IPGEOM,IPCENT,IRET)
  4. C-----------------------------------------------------------------------
  5. C Transforme un MCHAML constant par élément en un CHPO de support CENTRE
  6. C-----------------------------------------------------------------------
  7. C
  8. C--------------------
  9. C Paramètres Entrée :
  10. C--------------------
  11. C
  12. C  IPCHE  :   pointeur sur le champ  par         élément
  13. C             Le champ n'a qu'une composante   reelle
  14. C
  15. C  IPGEOM :   pointeur sur le maillage quaf ou de base (issu de la table domaine).
  16. C  IPCENT :   pointeur sur le maillage des points centres
  17. C             (issu de la table domaine).
  18. C
  19. C-------------------
  20. C Paramètre Sortie :
  21. C-------------------
  22. C
  23. C  IRET  :    pointeur sur le CHPO de support centre
  24. C
  25. C-----------------------------------------------------------------------
  26. C
  27. C   Subroutine appelée par KCHA.
  28. C
  29. C-----------------------------------------------------------------------
  30.  
  31.       IMPLICIT INTEGER(I-N)
  32.       IMPLICIT REAL*8 (A-H,O-Z)
  33. C
  34. C
  35.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC SMCHAML
  39. -INC SMCHPOI
  40. -INC SMELEME
  41.  
  42.       SEGMENT ITRA
  43. *       LTAB(IE,IP) : indice dans le chpocentre du point IE de la partition IP
  44.         INTEGER LTAB(NBELM,NPAR)
  45.       ENDSEGMENT
  46.       SEGMENT JTRA
  47. *       JTAB(IZ) : indice dans le chpocentre de départ des points pour le sous-maillage IZ
  48. *       ZTAB(IP) : nb de noeuds de la partition IP
  49. *       ITAB(IP) : pointeur sur sous-zone identifiée à la partition IP
  50. *       KTAB(IP) : nb d'éléments de cette sous-zone
  51. *       OTAB(IP) : numéro d'ordre de cette sous-zone dans IPGEOM
  52.         INTEGER JTAB(NBS),ZTAB(NPAR)
  53.         INTEGER ITAB(NPAR),KTAB(NPAR),OTAB(NPAR)
  54.       ENDSEGMENT
  55.       SEGMENT KTRA
  56. *       MTAB(IC) : nom de la composante IC du chamelem
  57. *       NTAB(IC,IP) : numéro, dans chaque partition IP, de la
  58. *                     sous-partition ayant pour composante la composante
  59. *                     IC de la première partition
  60.         CHARACTER*(LOCOMP) MTAB(MCOM)
  61.         INTEGER NTAB(NC,NPAR)
  62.       ENDSEGMENT
  63.        SEGMENT KSIPP
  64.          INTEGER ISPT(NBEL3)
  65.       ENDSEGMENT
  66. *
  67. *     NBS  : nombre de sous-zones du maillage
  68. *
  69.       IPT1   = IPGEOM
  70.       SEGACT IPT1
  71.       NBO    = IPT1.LISOUS(/1)
  72.       IF(NBO.EQ.0) THEN
  73.         NBS  = 1
  74.       ELSE
  75.         NBS  = NBO
  76.       ENDIF
  77. *
  78. *     NPAR : nombre de partitions du chamelem
  79. *
  80.       MCHELM = IPCHE
  81.       SEGACT MCHELM
  82.       NPAR   = IMACHE(/1)
  83. *
  84. *     NBELM : nombre maximal d'éléments parmi toutes les partitions
  85. *
  86.       NBELM  = 0
  87.       DO IP =1,NPAR
  88.         IPT2  = IMACHE(IP)
  89.         SEGACT IPT2
  90.         NBEL  = IPT2.NUM(/2)
  91.         NP    = IPT2.NUM(/1)
  92.         NBELM = MAX(NBEL,NBELM)
  93. *        IF(NBEL.GT.NBELM) THEN
  94. *          NBELM = NBEL
  95. *        ENDIF
  96.         SEGACT IPT2
  97.       ENDDO
  98. *
  99. *     Initialisation des segments de travail
  100. *
  101.       SEGINI ITRA
  102.       SEGINI JTRA
  103.  
  104.       IF(NBO.EQ.0) THEN
  105.         JTAB(1)=0
  106.       ENDIF
  107.  
  108.       DO IO=2,NBS
  109.         IPT3    = IPT1.LISOUS(IO-1)
  110.         SEGACT IPT3
  111.         NB      = IPT3.NUM(/2)
  112.         JTAB(IO)= JTAB(IO-1) + NB
  113.         SEGACT IPT3
  114.       ENDDO
  115. *
  116. *     Correspondance des maillages des partitions du chamelem
  117. *     avec les sous-maillages du maillage
  118. *
  119.  
  120. *     Test des nombres de noeuds par éléments
  121.       DO IP=1,NPAR
  122. *       pour chaque partition IP
  123.         IPT2    = IMACHE(IP)
  124.         SEGACT IPT2
  125.         NP      = IPT2.NUM(/1)
  126.         ZTAB(IP)= IPT2.NUM(/2)
  127.         DO IZ=1,NBS
  128. *         pour chaque sous-maillage IZ
  129.           IF(NBO.EQ.0)THEN
  130.             IPT3 = IPT1
  131.           ELSE
  132.             IPT3 = IPT1.LISOUS(IZ)
  133.             SEGACT IPT3
  134.           ENDIF
  135.           NP3 = IPT3.NUM(/1)
  136.           IF(NP.EQ.NP3) THEN
  137. C           On a trouve 2 sous-maillages ayant le meme nbre de noeuds
  138. C           pour qu'ils puissent correspondre, ils doivent avoir 1
  139. C           element commun
  140.             NBEL3=IPT3.NUM(/2)
  141.             ITEST=0
  142.             DO 30 I0=1,NP
  143.                I1=IPT2.NUM(I0,1)
  144.                DO 20 I2=1,NBEL3
  145.                   DO 15 I3=1,NP3
  146.                      IF(IPT3.NUM(I3,I2).EQ.I1)THEN
  147.                         ITEST=ITEST+1
  148.                         GO TO 25
  149.                      ENDIF
  150.    15             CONTINUE
  151.    20          CONTINUE
  152.    25          CONTINUE
  153.    30       CONTINUE
  154.             IF(ITEST.EQ.NP)THEN
  155.                ITAB(IP)=IPT3
  156.                KTAB(IP)=IPT3.NUM(/2)
  157.                OTAB(IP)=IZ
  158.                IF(NBO.GT.0)THEN
  159.                  SEGACT IPT3
  160.                ENDIF
  161.                GO TO 3
  162.             ENDIF
  163.           ENDIF
  164.         ENDDO
  165. C       On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou de
  166. C       constituant correspondant à l'objet MODELE
  167.         CALL ERREUR(472)
  168.         RETURN
  169.   3     CONTINUE
  170.         SEGACT IPT2
  171.       ENDDO
  172.  
  173. *     Test des numéros de noeud
  174. C      les tests qui suivent sont extremement long pour un gros maillage
  175. C     on va affecter a chaque element un poids egal a la somme des numeros
  176. C     de ses noeuds et on ne comparera les numeros de noeuds que pour les
  177. C     elements qui auront le meme poids.
  178.       DO IP =1,NPAR
  179.         IPT2  = IMACHE(IP)
  180.         SEGACT IPT2
  181.         IPT4  = ITAB(IP)
  182.         SEGACT IPT4
  183.         NBEL2 = ZTAB(IP)
  184.         NBEL3 = KTAB(IP)
  185.         NP    = IPT2.NUM(/1)
  186. C
  187.         SEGINI KSIPP
  188.         DO JE=1,NBEL3
  189.            ISP2=0
  190.            DO JP=1,NP
  191.                ISP2=ISP2+IPT4.NUM(JP,JE)
  192.            ENDDO
  193.         ISPT(JE)=ISP2
  194.         ENDDO
  195.  
  196. C
  197.         DO IE = 1,NBEL2
  198.           IP1 = IPT2.NUM(1,IE)
  199.           ISP1=0
  200.           DO II=1,NP
  201.               ISP1= ISP1+IPT2.NUM(II,IE)
  202.           ENDDO
  203.           DO JE = 1,NBEL3
  204.             IF(ISPT(JE).EQ.ISP1) THEN
  205.             DO JP=1,NP
  206.               IP2=IPT4.NUM(JP,JE)
  207.               IF(IP2.EQ.IP1) THEN
  208.                 ITEST = 1
  209.                 DO KP=1,NP-1
  210.                   JEE = JP+KP
  211.                   JEP = JEE / NP
  212.                   JEE = JEE - JEP * NP
  213.                   IF(JEE.EQ.0)THEN
  214.                      JEE = NP
  215.                   ENDIF
  216.                   KJ = IPT4.NUM(JEE,JE)
  217.                   KI = IPT2.NUM(KP+1,IE)
  218.                   IF(KJ.EQ.KI) THEN
  219.                     ITEST=ITEST+1
  220.                   ELSE
  221.                     GO TO 4
  222.                   ENDIF
  223.                 ENDDO
  224.                 IF(ITEST.EQ.NP) THEN
  225.                   LTAB(IE,IP)=JE+JTAB(OTAB(IP))
  226.                   GO TO 5
  227.                 ENDIF
  228.   4             CONTINUE
  229.               ENDIF
  230.             ENDDO
  231.             ENDIF
  232.           ENDDO
  233. C         On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou de
  234. C         constituant correspondant à l'objet MODELE
  235.           CALL ERREUR(472)
  236.           RETURN
  237.   5       CONTINUE
  238.         ENDDO
  239.         SEGACT IPT2, IPT4
  240.         SEGSUP KSIPP
  241.       ENDDO
  242. *
  243. *     NOMBRE DE COMPOSANTES MAXI PAR PARTITION
  244. *
  245.       NC = 0
  246.       DO IP =1,NPAR
  247.         MCHAML = ICHAML(IP)
  248.         SEGACT MCHAML
  249.         DO IT = 1,TYPCHE(/2)
  250.           IF(TYPCHE(IT)(1:8).EQ.'POINTEUR') THEN
  251. c           Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  252.             MOTERR(1:8) = 'KCHA2   '
  253.             CALL ERREUR(349)
  254.             RETURN
  255.           ENDIF
  256.         ENDDO
  257.         IC = MCHAML.IELVAL(/1)
  258.         NC = MAX(IC,NC)
  259. *        IF(IC.GT.NC) THEN
  260. *          NC = IC
  261. *        ENDIF
  262.         SEGACT MCHAML
  263.       ENDDO
  264.       MCOM = NC
  265.  
  266. *     Préparation du champ-point à plusieurs composantes
  267.       SEGINI KTRA
  268.       MCHAML = ICHAML(1)
  269.       SEGACT MCHAML
  270.       MC = MCHAML.IELVAL(/1)
  271.       DO IC =1,MC
  272.         MTAB(IC)=NOMCHE(IC)
  273.         NTAB(IC,1)=IC
  274.       ENDDO
  275.       SEGACT MCHAML
  276.  
  277.       K=MC
  278.       DO IP=2,NPAR
  279.         MCHAML = ICHAML(IP)
  280.         SEGACT MCHAML
  281.         MC = MCHAML.IELVAL(/1)
  282.         DO IC=1,MC
  283.           DO JC=1,K
  284.             IF(NOMCHE(IC).EQ.MTAB(JC))THEN
  285.               NTAB(IC,IP)=JC
  286.               GO TO 10
  287.             ENDIF
  288.           ENDDO
  289.           K = K+1
  290.           IF(MCOM.LT.K) THEN
  291.              MCOM = K
  292.              SEGADJ KTRA
  293.           ENDIF
  294.           MTAB(K)=NOMCHE(IC)
  295.           NTAB(IC,IP)=K
  296.  10       CONTINUE
  297.         ENDDO
  298.         SEGACT MCHAML
  299.       ENDDO
  300. *
  301. *     Construction du champ-point
  302. *
  303.       NSOUPO    = 1
  304.       NAT       = 2
  305.       SEGINI MCHPOI
  306.       MTYPOI    = '        '
  307.       MOCHDE    = 'KCHA FECIT'
  308.       JATTRI(1) = 2
  309.       NC        = MCOM
  310.       SEGINI MSOUPO
  311.       IPCHP(1)  = MSOUPO
  312.       IPT5      = IPCENT
  313.       SEGACT IPT5
  314.       N         = IPT5.NUM(/2)
  315.       SEGACT IPT5
  316.       SEGINI MPOVAL
  317.       IPOVAL    = MPOVAL
  318.       IGEOC     = IPCENT
  319.       IFOPOI    = IFOCHE
  320.  
  321.       DO IC=1,MCOM
  322.         NOCOMP(IC)=MTAB(IC)
  323. ***     NOHARN(IC)=INTAB(IC)
  324. ***            REVOIR NHARM
  325.       ENDDO
  326.  
  327.       DO IP=1,NPAR
  328.         MCHAML= ICHAML(IP)
  329.         SEGACT MCHAML
  330.         N2    = MCHAML.IELVAL(/1)
  331.         IPT4  = ITAB(IP)
  332.         SEGACT IPT4
  333.         MEL   = ZTAB(IP)
  334.         DO II=1,N2
  335.           IC     = NTAB(II,IP)
  336.           MELVAL = MCHAML.IELVAL(II)
  337.           SEGACT MELVAL
  338.           NPT    = VELCHE(/1)
  339.           NEL    = VELCHE(/2)
  340.           IF(NPT.EQ.1 .AND. NEL.EQ.1) THEN
  341. *           constance sur la sous-zone
  342.             DO IE = 1,MEL
  343.               JP            = LTAB(IE,IP)
  344.               VPOCHA(JP,IC) = VELCHE(1,1)
  345.             ENDDO
  346.           ENDIF
  347.           IF(NPT.EQ.1 .AND. NEL.NE.1) THEN
  348. *           cas classique
  349.             DO IE = 1,MEL
  350.               JP            = LTAB(IE,IP)
  351.               VPOCHA(JP,IC) = VELCHE(1,IE)
  352.             ENDDO
  353.           ENDIF
  354.           IF(NPT.NE.1 .AND. NEL.NE.1) THEN
  355. *           on n'a pas un chamelem aux centres
  356. *           on fait la moyenne sur les valeurs aux différents points
  357.             DO IE = 1,MEL
  358.               JP            = LTAB(IE,IP)
  359.               VAL           = 0.D0
  360.               DO KP=1,NPT
  361.                 VAL         = VAL + VELCHE(KP,IE)
  362.               ENDDO
  363.               VAL           = VAL / NPT
  364.               VPOCHA(JP,IC) = VAL
  365.             ENDDO
  366.           ENDIF
  367.           SEGACT MELVAL
  368.         ENDDO
  369.         SEGACT MCHAML, IPT4
  370.       ENDDO
  371. *
  372. *     Fermeture des segments
  373. *
  374.       SEGACT MPOVAL
  375.       SEGACT MSOUPO
  376.       SEGACT MCHPOI
  377.       SEGACT IPT1
  378.       SEGACT MCHELM
  379.       SEGSUP ITRA,JTRA,KTRA
  380.  
  381.       IRET   = MCHPOI
  382.       RETURN
  383.       END
  384.  
  385.  
  386.  
  387.  
  388.  
  389.  
  390.  
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  

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