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

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