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

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