Télécharger la plaquette Cast3M


fr en

Télécharger tcondu.eso

Retour à la liste

Numérotation des lignes : 

tcondu

  1. C TCONDU    SOURCE    OF166741  25/02/21    21:18:45     12166          
  2.  
  3. C=======================================================================
  4. C=                            T C O N D U                              =
  5. C=                            -----------                              =
  6. C=                                                                     =
  7. C=  Fonction :                                                         =
  8. C=  ----------                                                         =
  9. C=  Calcul de la matrice de CONDUCTIVITE THERMIQUE (type RIGIDITE)     =
  10. C=                                                                     =
  11. C=  Parametres :  (E)=Entree   (S)=Sortie                              =
  12. C=  ------------                                                       =
  13. C=   IPMODE   (E)   Segment IMODEL pour un modele elementaire  (ACTIF) =
  14. C=   IPCHEL   (E)   Segment MCHELM de CARACTERISTIQUES         (?)     =
  15. C=   ISUPMA   (E)   Support du champ de caracteristiques materiau      =
  16. C=   IPRIGI  (E/S)  Segment MRIGID : CONDUCTIVITE              (ACTIF) =
  17. C=======================================================================
  18.  
  19.       SUBROUTINE TCONDU (IPMODE,IPCHEL,ISUPMA, IPRIGI)
  20.  
  21.       IMPLICIT INTEGER(I-N)
  22.       IMPLICIT REAL*8(A-H,O-Z)
  23.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC CCHAMP
  27. -INC CCGEOME
  28. -INC CCREEL
  29.  
  30. -INC SMCOORD
  31. -INC SMELEME
  32. -INC SMINTE
  33. -INC SMMODEL
  34.       POINTEUR nomid1.NOMID
  35. -INC SMRIGID
  36.  
  37. -INC TMPTVAL
  38.  
  39.       INTEGER OOOVAL
  40.  
  41.       SEGMENT NOTYPE
  42.         CHARACTER*16 TYPE(NBTYPE)
  43.       ENDSEGMENT
  44.  
  45.       CHARACTER*8 CMATE
  46.       CHARACTER*(LCONMO) CONM
  47.  
  48.       PARAMETER ( NINF=3 )
  49.       DIMENSION INFOS(NINF)
  50.  
  51. C=  LEFMAS   Liste des numeros d'elements finis MASSIFs a integration
  52. C            numerique pour la formulation thermique
  53. C=  NEFMAS   Longueur de cette liste                                   =
  54. C=  LEFCOQ   Liste des numeros d'elements finis COQUEs
  55. C=  NEFCOQ   Longueur de cette liste                                   =
  56.       PARAMETER ( NEFMAS = 14 , NEFCOQ=5 ,nefseg=6)
  57.       DIMENSION LEFMAS(NEFMAS), LEFCOQ(NEFCOQ),lefseg(nefseg)
  58. C= Petit tableau des "couleurs" pour les relations de conformite
  59.       DIMENSION LCOLOR(6)
  60. C Numerotation dans le tableau NOMTP de bdata.eso
  61.  
  62. C  Elements         TRI3 TRI6 QUA4 QUA8 CUB8 CU20 PRI6 PR15 TET4 TE10
  63. C  MASSIFs          PYR5 PY13 T1D2 T1D3
  64.       DATA LEFMAS /    4,   6,   8,  10,  14,  15,  16,  17,  23,  24,
  65.      &                25,  26, 191, 192/
  66. C  COQUEs           COQ2 COQ3 COQ6 COQ4 COQ8
  67.       DATA LEFCOQ /   44,  27,  56,  49,  41  /
  68. C element          seg2 seg3  barr tuy2  tuy3 joi1
  69.       DATA LEFSEG/ 2  , 3  ,  46 , 269  ,270, 265 /
  70.       DATA LCOLOR / 1, 3, 6, 10, 16, 24 /
  71.  
  72.       MACRO, (SEG2, SEG3, BARR, TUY2, TUY3, JOI1)
  73.  
  74. **    write(6,*) 'entree dans tcondu '
  75.       IPINTE = 0
  76.       MOMATE = 0
  77.       MOTYPE = 0
  78.  
  79. C- Matrice de CONDUCTIVITE
  80.       MRIGID = IPRIGI
  81. c*      SEGACT,MRIGID
  82.       NRIGE0 = IRIGEL(/2)
  83.  
  84. C- Recuperation du sous-modele et de la zone elementaire associee
  85.       IMODEL = IPMODE
  86. c*      SEGACT,IMODEL
  87.  
  88.       NEF = NEFMOD
  89.  
  90. C- Recuperation d'informations sur le maillage elementaire
  91.       IPT1 = IMAMOD
  92.       SEGACT,IPT1
  93.       NBNOE1 = IPT1.NUM(/1)
  94.       NBELE1 = IPT1.NUM(/2)
  95. *
  96. C- Quelques informations sur le modele (sauf EF de type 22 ou 259)
  97.       IF ((NEF.EQ.22).OR.(NEF.EQ.259)) GOTO 2200
  98.  
  99.       CONM  = CONMOD
  100.       CMATE = CMATEE
  101.       MATE  = IMATEE
  102.  
  103.       CALL PLACE2(LEFMAS,NEFMAS,IMAS,NEF)
  104.       CALL PLACE2(LEFCOQ,NEFCOQ,ICOQ,NEF)
  105.       call place2(lefseg,nefseg,ise,nef)
  106.       IRET = 1
  107.       CALL IDENT(IPT1,CONM,IPCHEL,0, INFOS,IRET)
  108.       IF (IRET.EQ.0) GOTO 9990
  109.  
  110. C- Recuperation d'informations sur l'element fini
  111.       CALL TSHAPE(NEF,'GAUSS',IPINTE)
  112.       IF (IERR.NE.0) GOTO 9990
  113.       MINTE = IPINTE
  114.  
  115. C- Recuperation des caracteristiques materielles (obligatoires)
  116.       IF (ise.ne.0) THEN
  117.         CASE, ise
  118.         WHEN, JOI1
  119.           nbrobl = 1
  120.           nbrfac = 0
  121.           SEGINI,nomid
  122.           IF    (FORMOD(1).EQ.'THERMIQUE') THEN
  123.             LESOBL(1) = 'KT'
  124.           ELSEIF(FORMOD(1).EQ.'DIFFUSION') THEN
  125.             LESOBL(1) = 'KD  '
  126.           ELSE
  127.             CALL ERREUR(5)
  128.           ENDIF
  129.  
  130.         WHENOTHERS
  131.           nbrobl = 2
  132.           nbrfac = 0
  133.           SEGINI,nomid
  134.           IF    (FORMOD(1).EQ.'THERMIQUE') THEN
  135.             LESOBL(1) = 'K   '
  136.           ELSEIF(FORMOD(1).EQ.'DIFFUSION') THEN
  137.             LESOBL(1) = 'KD  '
  138.           ELSE
  139.             CALL ERREUR(5)
  140.           ENDIF
  141.           lesobl(2) = 'SECT'
  142.         ENDCASE
  143.  
  144.       ELSE
  145.         nomid1 = LNOMID(6)
  146.         SEGINI,nomid=nomid1
  147.         IF (ICOQ.NE.0) THEN
  148.           nbrobl = lesobl(/2) + 1
  149.           nbrfac = 0
  150.           SEGADJ,nomid
  151.           lesobl(nbrobl) = 'EPAI'
  152.         ENDIF
  153.       ENDIF
  154.  
  155.       NMATO = lesobl(/2)
  156.       NMATF = lesfac(/2)
  157.       NMATT = NMATO + NMATF
  158.       MOMATE = nomid
  159.  
  160. C
  161.       nbtype = 1
  162.       SEGINI,notype
  163.       type(1) = 'REAL*8'
  164.       MOTYPE = notype
  165.  
  166.  2200 CONTINUE
  167. C- Definition du descripteur IDESCR
  168.       IDESCR = 0
  169.  
  170. C-- Cas particulier des relations de conformite pour la thermique
  171.       IF ((NEF.EQ.22).OR.(NEF.EQ.259)) THEN
  172. C        IF (IPT1.ITYPEL.NE.22) GOTO 9990
  173.         IDEBUT = LCOLOR(IPT1.ICOLOR(1)) - 3
  174.         IF (NEF.EQ.259) THEN
  175. * creation d'un maillage avec un premier noeud par lélément
  176. * correspondant à un multiplicateur de lagrange
  177.           SEGACT IPT1
  178.           NBNN=IPT1.NUM(/1)+1
  179.           NBELEM=IPT1.NUM(/2)
  180.           NBSOUS=0
  181.           NBREF=0
  182.           SEGINI, IPT2
  183.           IPT2.ITYPEL=22
  184.           DO  J=1,IPT1.NUM(/2)
  185.               ipt2.icolor(j)=IPT1.icolor(j)
  186.               DO  I=1,IPT1.NUM(/1)
  187.                   IPT2.NUM(I+1,J)=IPT1.NUM(I,J)
  188.               ENDDO
  189.           ENDDO
  190. * creation n'un nouveau noeud pour supporter chaque multiplicateur de lagrange
  191.           segact mcoord*mod
  192.           NBPT1= nbpts
  193.           NBPTS=NBPT1+(IPT2.NUM(/2))
  194.           SEGADJ MCOORD
  195.           DO J=1,IPT1.NUM(/2)
  196.              NGLOB=(NBPT1+J-1)*(IDIM+1)
  197. * remplissage des coordonees des nouveux points
  198.              DO ID= 1,IDIM
  199.                  XCOOR(NGLOB+ID)=XCOOR((IPT2.NUM(2,J)-1)*(IDIM+1)+ID)
  200.              ENDDO
  201.              IPT2.NUM(1,J) = NBPT1 + J
  202.           ENDDO
  203.           NBNOE1= IPT2.NUM(/1)
  204.         ENDIF
  205.  
  206. * Petite verification sur le nom de la composante mise en relation
  207.         nomid = LNOMID(1)
  208.         SEGACT,nomid
  209.         NEXIST = 0
  210.         DO i = 1, LNOMDD
  211.           IF (NOMDD(i).EQ.lesobl(1)) NEXIST = i
  212.         ENDDO
  213.  
  214.         IF (NEXIST.EQ.0) THEN
  215.           CALL ERREUR(837)
  216.           GOTO 9990
  217.         ENDIF
  218. * Remplissage du DESCRipteur
  219.         NLIGRD = NBNOE1
  220.         NLIGRP = NLIGRD
  221.         SEGINI,DESCR
  222.         LISINC(1) = 'LX  '
  223.         LISDUA(1) = 'FLX '
  224.         NOELEP(1) = 1
  225.         NOELED(1) = 1
  226.         DO i = 2,NLIGRD
  227.           LISINC(i) = NOMDD(NEXIST)
  228.           LISDUA(i) = NOMDU(NEXIST)
  229.           NOELEP(i) = i
  230.           NOELED(i) = i
  231.         ENDDO
  232.         IDESCR = DESCR
  233.  
  234. C-- Cas GENERAL
  235.       ELSE
  236.         NOMPRI = LNOMID(1)
  237.         NOMDUA = LNOMID(2)
  238.         CALL TCOND2(ICOQ,NBNOE1,IDESCR,NOMPRI,NOMDUA)
  239.         DESCR = IDESCR
  240.         SEGACT,DESCR
  241.         NLIGRD = LISDUA(/2)
  242.         NLIGRP = LISINC(/2)
  243.       ENDIF
  244.  
  245.       SEGDES,DESCR
  246.       LRE = NLIGRD
  247.  
  248. C- Partionnement si necessaire de la matrice de conductivite
  249. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  250.       LTRK = oooval(1,4)
  251.       IF (LTRK.EQ.0) LTRK = oooval(1,1)
  252.       LTRK=max(ltrk,2**24)
  253. C-- Ajout a la taille en mots de la matrice des infos du segment
  254.       LSEG = LRE*LRE*NBELE1 + 16
  255.       NBLPRT = (LSEG-1)/LTRK + 1
  256.       NBLMAX = (NBELE1-1)/NBLPRT + 1
  257.       NBLPRT = (NBELE1-1)/NBLMAX + 1
  258. C      write(ioimp,*) ' tcondu : nblprt nblmax = ',nblprt,nblmax,nbele1
  259.  
  260. C Ajout de la matrice de CONDUCTIVITE a la matrice globale
  261. C ========================================================
  262.       NRIGEL = NRIGE0 + NBLPRT
  263.       SEGADJ,MRIGID
  264.  
  265.       descr  = IDESCR
  266.       IF (NEF.EQ.259) THEN
  267.         meleme = IPT2
  268.       ELSE
  269.         meleme = IPT1
  270.       ENDIF
  271.       nbnn   = NBNOE1
  272.       nbelem = NBELE1
  273.       nbsous = 0
  274.       nbref  = 0
  275.  
  276. C Boucle sur les PARTITIONS elementaires de la matrice
  277. C ====================================================
  278.       DO irige = 1, NBLPRT
  279. **    write(6,*) 'nblprt irige nef ',nblprt,irige,nef
  280.  
  281.         IF (NBLPRT.GT.1) THEN
  282. C- Partitionnement du maillage support de la matrice elementaire
  283.           SEGACT,IPT1
  284.           ielem = (irige-1)*NBLMAX
  285.           nbelem = MIN(NBLMAX,NBELE1-ielem)
  286. *          write(ioimp,*) ' creation segment ',nbnn,nbelem
  287.           SEGINI,meleme
  288.           IF (NEF.EQ.259) THEN
  289.           itypel = IPT2.itypel
  290.           ELSE
  291.           itypel = IPT1.itypel
  292.           endif
  293.           DO ielt = 1, nbelem
  294.             jelt = ielt + ielem
  295.             DO inoe = 1, nbnn
  296.               IF (NEF.EQ.259) THEN
  297.                 num(inoe,ielt) = IPT2.NUM(inoe,jelt)
  298.               ELSE
  299.                 num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  300.               ENDIF
  301.             ENDDO
  302.             IF (NEF.EQ.259) THEN
  303.                icolor(ielt) = IPT2.ICOLOR(jelt)
  304.             ELSE
  305.                icolor(ielt) = IPT1.ICOLOR(jelt)
  306.             endif
  307.           ENDDO
  308. C- Recopie du descripteur
  309.           des1 = IDESCR
  310.           SEGINI,descr=des1
  311.           SEGDES,descr
  312.         ENDIF
  313.         ipmail = meleme
  314.         ipdesc = descr
  315.  
  316. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  317.         NELRIG = nbelem
  318.         SEGINI,xmatri
  319.         ipmatr = xmatri
  320.  
  321. C- Creation des blocages thermiques dus aux relations de compatibilite
  322.         IF ((NEF.EQ.22).OR.(NEF.EQ.259)) THEN
  323.           DO ielt = 1, NELRIG
  324.             xmatri.re(2,1,ielt) = -1.
  325.             xmatri.re(1,2,ielt) = -1.
  326.             DO inoe = 3, NBNOE1
  327.               xmatri.re(inoe,1,ielt) = XCOEFF(IDEBUT+inoe)
  328.               xmatri.re(1,inoe,ielt) = xmatri.re(inoe,1,ielt)
  329.             ENDDO
  330.           ENDDO
  331.  
  332. C- CAS GENERAL
  333.         ELSE
  334.  
  335.           IVAMAT = 0
  336.           CALL KOMCHA(IPCHEL,ipmail,CONM,MOMATE,MOTYPE,1,INFOS,3,IVAMAT)
  337.           IF (IERR.NE.0) GOTO 9991
  338.           IF (ISUPMA.EQ.1 .AND. NEF.NE.265) THEN
  339. C           On ne change pas le support pour JOI1
  340.             CALL VALCHE(IVAMAT,NMATT,IPINTE,0,MOMATE,NEF)
  341.             IF (IERR.NE.0) THEN
  342.               ISUPMA = 0
  343.               GOTO 9991
  344.             ENDIF
  345.           ENDIF
  346. C-- Calcul de la matrice elementaire pour la zone iMai et
  347. C-- Remplissage de la matrice globale (ipmatr)
  348. C---> Elements MASSIFs a integration NUMERIQUE
  349.           IF (IMAS.NE.0) THEN
  350.             CALL TNUMAC(NEF,ipmail,IPINTE,MATE,IVAMAT,NMATT, ipmatr,LRE)
  351. C---> Elements de COQUEs
  352.           ELSE IF (ICOQ.NE.0) THEN
  353.             GOTO (144,127,156,156,156), ICOQ
  354.             GOTO 100
  355. C-----> Element de COQUE AXISYMETRIQUE (COQ2)
  356.  144        CONTINUE
  357.             CALL TCOQ2C(NEF,ipmail,IPINTE,MATE,IVAMAT,NMATT, ipmatr,LRE)
  358.             GOTO 100
  359. C-----> Element COQ3
  360.  127        CONTINUE
  361.             CALL TCOQ3C(NEF,ipmail,IPINTE,MATE,IVAMAT,NMATT, ipmatr,LRE)
  362.             GOTO 100
  363. C-----> Element COQ8 ou COQ6 ou COQ4
  364.  156      CONTINUE
  365.             CALL TCOQ8C(NEF,ipmail,IPINTE,MATE,IVAMAT,NMATT, ipmatr,LRE)
  366.             GOTO 100
  367.  100        CONTINUE
  368. C----> Autres elements
  369. C   --> Element BARR (SEG2)  ou tuy3 (seg3 ) ou tuy2 (seg2) ou JOI1 (SEG2) en conduction
  370.           ELSE IF (ISE.ne.0) THEN
  371.             CASE, ISE
  372.             WHEN, SEG2, BARR, TUY2
  373.               CALL TSEG2C(NEF,ipmail,IPINTE,MATE,IVAMAT,NMATT,
  374.      &                    ipmatr,LRE)
  375.             WHEN, SEG3,TUY3
  376.               CALL TSEG3C(NEF,IPMAIL,IPINTE,MATE,IVAMAT,NMATT,
  377.      &                    IPMATR,LRE)
  378.             WHEN, JOI1
  379.               CALL TJOI1C(IPMAIL,IVAMAT,IPMATR)
  380.             ENDCASE
  381.           ELSE
  382.             CALL ERREUR(19)
  383.           ENDIF
  384.  
  385. C- Un peu de menage dans les segments
  386.  9991     CONTINUE
  387.           IF (ISUPMA.EQ.1 .OR. NBLPRT.GT.1) THEN
  388.             CALL DTMVAL(IVAMAT,3)
  389.           ELSE
  390.             CALL DTMVAL(IVAMAT,1)
  391.           ENDIF
  392.  
  393.         ENDIF
  394. C- Sortie prematuree en cas d'erreur
  395.         IF (IERR.NE.0) GOTO 9990
  396.  
  397.         xmatri = ipmatr
  398. C        IF (NBLPRT.GT.1) THEN
  399. C          meleme = ipmail
  400. C        ENDIF
  401.  
  402. C- Stockage de la matrice
  403.         jrige = NRIGE0 + irige
  404.         COERIG(jrige)   = 1.
  405.         IRIGEL(1,jrige) = ipmail
  406.         IRIGEL(2,jrige) = 0
  407.         IRIGEL(3,jrige) = ipdesc
  408.         IRIGEL(4,jrige) = ipmatr
  409.         IRIGEL(5,jrige) = NIFOUR
  410.         IRIGEL(6,jrige) = 0
  411.         IRIGEL(7,jrige) = xmatri.SYMRE
  412.         IRIGEL(8,jrige) = 0
  413.  
  414.         SEGDES,xmatri
  415.       ENDDO
  416.  
  417. C MENAGE : desactivation/destruction de segments
  418. C ==============================================
  419.  9990 CONTINUE
  420. **    write(6,*) 'sortie de tcondu '
  421.       IF (IPINTE.NE.0) THEN
  422.         MINTE = IPINTE
  423.       ENDIF
  424.       IF (MOMATE.NE.0) THEN
  425.         nomid = MOMATE
  426.         SEGSUP,nomid
  427.       ENDIF
  428.       IF (MOTYPE.NE.0) THEN
  429.         notype = MOTYPE
  430.         SEGSUP,notype
  431.       ENDIF
  432.  
  433.       RETURN
  434.       END
  435.  
  436.  
  437.  

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