Télécharger la plaquette Cast3M


fr en

Télécharger capa1.eso

Retour à la liste

Numérotation des lignes : 

capa1

  1. C CAPA1     SOURCE    CB215821  24/04/12    21:15:10     11897          
  2.  
  3. C=======================================================================
  4. C=                            C A P A 1                                =
  5. C=                            ---------                                =
  6. C=                                                                     =
  7. C=  Fonction :                                                         =
  8. C=  ----------                                                         =
  9. C=  Calcul de la matrice de CAPACITE CALORIFIQUE (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=   ISUPC    (E)   Support du champ de CARACTERISTIQUES               =
  16. C=   ITABCP   (E)   TABLE pour le changement de PHASE                  =
  17. C=   IPRIGI  (E/S)  Segment MRIGID : CAPACITE                  (ACTIF) =
  18. C=                                                                     =
  19. C=  Creation par Denis ROBERT le 15 fevrier 1988.                      =
  20. C=  Modifications par DEGAY le 10 mai 1994 et ulterieurement.          =
  21. C=======================================================================
  22.  
  23.       SUBROUTINE CAPA1 (IPMODE,IPCHEL,ISUPC,ITABCP, IPRIGI)
  24.  
  25.       IMPLICIT INTEGER(I-N)
  26.       IMPLICIT REAL*8 (A-H,O-Z)
  27.  
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC CCHAMP
  32. -INC CCREEL
  33.  
  34. -INC SMELEME
  35. -INC SMMODEL
  36.       POINTEUR NOMID1.NOMID,NOMID2.NOMID
  37. -INC SMRIGID
  38.  
  39.       INTEGER OOOVAL
  40.  
  41.       SEGMENT NOTYPE
  42.         CHARACTER*16 TYPE(NBTYPE)
  43.       ENDSEGMENT
  44.  
  45.       SEGMENT MPTVAL
  46.         INTEGER IPOS(NS),NSOF(NS), IVAL(NCOSOU)
  47.         CHARACTER*16 TYVAL(NCOSOU)
  48.       ENDSEGMENT
  49.  
  50.       CHARACTER*8  CMATE
  51.       CHARACTER*16 MOFOR
  52.       CHARACTER*(LCONMO) CONM
  53.  
  54.       PARAMETER ( NINF=3 )
  55.       DIMENSION INFOS(NINF)
  56.  
  57. C=  LEFMAS   Liste des numeros d'elements finis MASSIFs implementes
  58. C=  NEFMAS   Longueur de cette liste                                   =
  59. C=  LEFCOQ   Liste des numeros d'elements finis COQUEs implementes
  60. C=  NEFCOQ   Longueur de cette liste                                   =
  61.       PARAMETER (NEFMAS=14, NEFCOQ=5,neftuy=2)
  62.       DIMENSION LEFMAS(NEFMAS), LEFCOQ(NEFCOQ),leftuy(neftuy)
  63.  
  64. C Elements         TRI3 TRI6 QUA4 QUA8 CUB8 CU20 PRI6 PR15 TET4
  65. C MASSIFs          TE10 PYR5 PY13 T1D2 T1D3
  66.       DATA LEFMAS /   4,   6,   8,  10,  14,  15,  16,  17,  23,
  67.      &               24,  25,  26, 191, 192 /
  68. C COQUEs            COQ2  COQ3  COQ6  COQ4  COQ8
  69.       DATA LEFCOQ /   44,   27,   56,   49,   41 /
  70. C   Tuyau(pour advection)
  71. C                    TUY2   TUY3
  72.       DATA  leftuy/  269  , 270/
  73.  
  74.       IPINTE = 0
  75.       IPINT2 = 0
  76.       MOMATE = 0
  77.       MOTYPE = 0
  78.       IPCPHA = 0
  79.       MOCPHA = 0
  80.  
  81. C- Matrice de capacite
  82.       MRIGID = IPRIGI
  83. c*      SEGACT,MRIGID
  84.       NRIGE0 = IRIGEL(/2)
  85.  
  86. C- Recuperation du sous-modele et de la zone elementaire associee
  87.       IMODEL = IPMODE
  88. C*      SEGACT,IMODEL
  89.  
  90.       NEF = NEFMOD
  91.       MFR = NUMMFR(NEF)
  92.       IF (NEF.EQ.22) RETURN
  93.  
  94.       IMAS = 0
  95.       ICOQ = 0
  96.       ituy = 0
  97.       CALL PLACE2(LEFMAS,NEFMAS,IMAS,NEF)
  98.       CALL PLACE2(LEFCOQ,NEFCOQ,ICOQ,NEF)
  99.       CALL PLACE2(LEFTUY,NEFTUY,ituy,NEF)
  100. C- Recuperation d'informations sur le maillage elementaire
  101.       IPT1 = IMAMOD
  102.       SEGACT,IPT1
  103.       NBNOE1 = IPT1.NUM(/1)
  104.       NBELE1 = IPT1.NUM(/2)
  105.  
  106. C- Quelques informations sur le modele
  107.       CONM  = CONMOD
  108.       CMATE = CMATEE
  109.       MATE  = IMATEE
  110.  
  111.       IRET = 1
  112.  
  113.  
  114.       CALL IDENT(IPT1,CONM,IPCHEL,0, INFOS,IRET)
  115.       IF (IRET.EQ.0) GOTO 9990
  116.  
  117. C- Recuperation d'informations sur l'element fini
  118.       CALL TSHAPE(NEF,'GAUSS',IPINTE)
  119.       IF (IERR.NE.0) GOTO 9990
  120.       IF (ICOQ.NE.0) THEN
  121.         IF (NEF.EQ.56 .OR. NEF.EQ.41 .OR. NEF.EQ.49) THEN
  122.           CALL TSHAPE(NEF,'NOEUD',IPINT2)
  123.         ENDIF
  124.       ENDIF
  125.  
  126. C- Recuperation des caracteristiques materielles (obligatoires)
  127.       nbrfac = 0
  128.       nbrobl = 0
  129.       MOFOR  = FORMOD(1)
  130.       IF    (MOFOR .EQ. 'THERMIQUE') THEN
  131.         INFOR = 1
  132.         IF (NEF.EQ.46 .OR. ICOQ.NE.0 .or. ituy.ne.0) THEN
  133.           nbrobl = 3
  134.         ELSE
  135.           nbrobl = 2
  136.         ENDIF
  137.         SEGINI,nomid
  138.  
  139.         IF(MFR .EQ. 75)THEN
  140. C         Cas des JOI1 (MFR=75) ==> Ressorts THERMIQUES
  141. C         ====================
  142.           lesobl(1) = 'M   '
  143.           lesobl(2) = 'C   '
  144.         ELSE
  145.           lesobl(1) = 'RHO '
  146.           lesobl(2) = 'C   '
  147.         ENDIF
  148.  
  149.       ELSEIF(MOFOR .EQ. 'DIFFUSION') THEN
  150.         INFOR = 2
  151.         IF (NEF.EQ.46 .OR. ICOQ.NE.0 .or. ituy.ne.0) THEN
  152.           nbrobl = 2
  153.         ELSE
  154.           nbrobl = 1
  155.         ENDIF
  156.         SEGINI,nomid
  157.         lesobl(1) = 'CDIF'
  158.       ELSE
  159.         CALL ERREUR(21)
  160.         RETURN
  161.       ENDIF
  162.  
  163.       IF (NEF.EQ.46.or.ituy.ne.0) THEN
  164.         lesobl(nbrobl) = 'SECT'
  165.       ELSE IF (ICOQ.NE.0) THEN
  166.         lesobl(nbrobl) = 'EPAI'
  167.       ENDIF
  168.  
  169.       NMATT   = nbrobl + nbrfac
  170.       MOMATE  = nomid
  171. c
  172.       nbtype  = 1
  173.       SEGINI,notype
  174.       type(1) = 'REAL*8'
  175.       MOTYPE  = notype
  176.  
  177. C- Recuperation de donnees dans le cas d'un CHANGEMENT DE PHASE
  178. C  Dans le cas d'un changement de phase, on calcule une capacite
  179. C  calorifique equivalente liee a la chaleur latente (MCHAML IPCPHA).
  180. C  Le support de ce champ est celui des points de GAUSS (IPINTE).
  181.       IF (ITABCP.NE.0) THEN
  182.         CALL CAPA7(ITABCP,IPT1,ICOQ,IPINTE, IPCPHA)
  183.         IF (IERR.NE.0) GOTO 9990
  184.         nbrobl = 1
  185.         nbrfac = 0
  186.         SEGINI,nomid
  187.         lesobl(1) = 'C   '
  188.         MOCPHA = nomid
  189.         NPHAT = nbrobl + nbrfac
  190.       ENDIF
  191.  
  192. C- Definition du descripteur IDESCR pour le modele elementaire
  193.       IDESCR = 0
  194.       NOMPRI = LNOMID(1)
  195.       NOMDUA = LNOMID(2)
  196.       CALL TCOND2(ICOQ,NBNOE1,IDESCR,NOMPRI,NOMDUA)
  197.       DESCR  = IDESCR
  198.       SEGACT,DESCR
  199.       NLIGRD = LISDUA(/2)
  200.       NLIGRP = LISINC(/2)
  201.       SEGDES,DESCR
  202.       LRE    = NLIGRD
  203.  
  204. C- Partionnement si necessaire de la matrice de capacite
  205. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  206.       LTRK = oooval(1,4)
  207.       IF (LTRK.EQ.0) LTRK = oooval(1,1)
  208.       LTRK=MAX(LTRK,2**24)
  209. * Ajout a la taille en mots de la matrice des infos du segment
  210.       LSEG = LRE*LRE*NBELE1 + 16
  211.       NBLPRT = (LSEG-1)/LTRK + 1
  212.       NBLMAX = (NBELE1-1)/NBLPRT + 1
  213.       NBLPRT = (NBELE1-1)/NBLMAX + 1
  214. *      write(ioimp,*) ' capa1 : nblprt nblmax = ',nblprt,nblmax,nbele1
  215.  
  216. C Ajout de la matrice de CAPACITE a la matrice globale
  217. C ====================================================
  218.       NRIGEL = NRIGE0 + NBLPRT
  219.       SEGADJ,MRIGID
  220.  
  221.       descr  = IDESCR
  222.       meleme = IPT1
  223.       nbnn   = NBNOE1
  224.       nbelem = NBELE1
  225.       nbsous = 0
  226.       nbref  = 0
  227.  
  228. C Boucle sur les PARTITIONS elementaires de la matrice
  229. C ====================================================
  230.       DO irige = 1, NBLPRT
  231.  
  232.         IVAMAT = 0
  233.         IVAPHA = 0
  234.  
  235.         IF (NBLPRT.GT.1) THEN
  236. C- Partitionnement du maillage support de la matrice elementaire
  237.           SEGACT,IPT1
  238.           ielem = (irige-1)*NBLMAX
  239.           nbelem = MIN(NBLMAX,NBELE1-ielem)
  240. *          write(ioimp,*) ' creation segment ',nbnn,nbelem
  241.           SEGINI,meleme
  242.           itypel = IPT1.itypel
  243.           DO ielt = 1, nbelem
  244.             jelt = ielt + ielem
  245.             DO inoe = 1, nbnn
  246.               num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  247.             ENDDO
  248.             icolor(ielt) = IPT1.ICOLOR(jelt)
  249.           ENDDO
  250. C- Recopie du descripteur
  251.           des1 = IDESCR
  252.           SEGINI,descr=des1
  253.           SEGDES,descr
  254.         ENDIF
  255.         ipmail = meleme
  256.         ipdesc = descr
  257.  
  258. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  259.         NELRIG = nbelem
  260.         SEGINI,xmatri
  261.         ipmatr = xmatri
  262.  
  263. C- Recuperation des valeurs de caracteristiques sur la partition
  264.         CALL KOMCHA(IPCHEL,ipmail,CONM,MOMATE,MOTYPE,1,INFOS,3,IVAMAT)
  265.         IF (IERR.NE.0) GOTO 9991
  266.         IF (ISUPC.EQ.1 .AND. NEF.NE.265) THEN
  267. C           On ne change pas le support pour JOI1      
  268.           CALL VALCHE(IVAMAT,NMATT,IPINTE,0,MOMATE,NEF)
  269.           IF (IERR.NE.0) THEN
  270.             ISUPC = 0
  271.             GOTO 9991
  272.           ENDIF
  273.         ENDIF
  274.  
  275. C- Idem pour capacite equivalente en cas de changement de phase
  276.         IF (ITABCP.NE.0) THEN
  277.           CALL KOMCHA(IPCPHA,ipmail,CONM,MOCPHA,MOTYPE,1,INFOS,3,IVAPHA)
  278.           IF (IERR.NE.0) GOTO 9991
  279.         ENDIF
  280.  
  281. C- Calcul de la matrice elementaire pour la paritition elementaire et
  282. C  Remplissage de la matrice globale (IPRIGI)
  283. C---> Elements MASSIFs a integration NUMERIQUE
  284.         IF (IMAS.NE.0) THEN
  285.           CALL CAPANU(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT,
  286.      &                ipmatr,LRE,INFOR)
  287. C---> Elements de COQUEs
  288.         ELSE IF (ICOQ.NE.0) THEN
  289. C-----> Element COQ2 (axisymetrique)
  290.           IF (NEF.EQ.44) THEN
  291.             CALL CAPAC1(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT,
  292.      &                  ipmatr,LRE,INFOR)
  293. C-----> Element COQ3
  294.           ELSE IF (NEF.EQ.27) THEN
  295.             CALL CAPAC3(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT,
  296.      &                  ipmatr,LRE,INFOR)
  297. C-----> Elements COQ4, COQ6 et COQ8
  298. C*          ELSE IF (NEF.EQ.56 .OR. NEF.EQ.41 .OR. NEF.EQ.49) THEN
  299.           ELSE
  300.             CALL CAPAC2(NEF,ipmail,IPINTE,IPINT2,IVAMAT,NMATT,
  301.      &                  IVAPHA,NPHAT, ipmatr,LRE,INFOR)
  302.           ENDIF
  303. C---> Element BARRE (integration NUMERIQUE)
  304.         ELSE IF (NEF.EQ.46.or.nef.eq.269.or.nef.eq.270) THEN
  305.           CALL CAPABA(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT,
  306.      &                ipmatr,LRE,INFOR)
  307. C---> Elements seg3, RAC2 et RAC3 : non implementes
  308.         ELSE IF (NEF.EQ.3 .OR. NEF.EQ.12 .OR. NEF.EQ.13) THEN
  309.           CALL ERREUR(251)
  310.           RETURN
  311. C---> Elements JOI1 : pas d'integration
  312.         ELSE IF (NEF.EQ.265) THEN
  313.           CALL CAPAJ1(IPMAIL,IVAMAT,NMATT,IPMATR,INFOR)
  314. C---> Elements POI1 : pas d'integration
  315.         ELSE IF (NEF.EQ.45) THEN
  316.           CALL CAPAP1(IPMAIL,IVAMAT,IPMATR,INFOR)
  317. C---> Option indisponible : ERREUR
  318.         ELSE
  319.           CALL ERREUR(19)
  320.           RETURN
  321.         ENDIF
  322.  
  323. C- Un peu de menage dans les segments
  324.  9991   CONTINUE
  325.         IF (ISUPC.EQ.1 .AND. NEF.NE.265 .OR. NBLPRT.NE.1) THEN
  326.           CALL DTMVAL(IVAMAT,3)
  327.         ELSE
  328.           CALL DTMVAL(IVAMAT,1)
  329.         ENDIF
  330.         IF (ITABCP.NE.0) THEN
  331.           IF (NBLPRT.NE.1) THEN
  332.             CALL DTMVAL(IVAPHA,3)
  333.           ELSE
  334.             CALL DTMVAL(IVAPHA,1)
  335.           ENDIF
  336.         ENDIF
  337. C- Sortie prematuree en cas d'erreur
  338.         IF (IERR.NE.0) GOTO 9990
  339.  
  340.         xmatri = ipmatr
  341.         SEGDES,xmatri
  342.         IF (NBLPRT.NE.1) THEN
  343.           meleme = ipmail
  344.         ENDIF
  345.  
  346. C- Stockage de la matrice de CAPACITE du modele
  347.         jrige = NRIGE0 + irige
  348.         COERIG(jrige)   = 1.
  349.         IRIGEL(1,jrige) = ipmail
  350.         IRIGEL(2,jrige) = 0
  351.         IRIGEL(3,jrige) = ipdesc
  352.         IRIGEL(4,jrige) = ipmatr
  353.         IRIGEL(5,jrige) = NIFOUR
  354.         IRIGEL(6,jrige) = 0
  355.         IRIGEL(7,jrige) = 0
  356.         IRIGEL(8,jrige) = 0
  357.  
  358.       ENDDO
  359.  
  360.       IPRIGI = MRIGID
  361.  
  362. C MENAGE : DESACTIVATION/DESTRUCTION DE SEGMENTS
  363. C ==============================================
  364.  9990 CONTINUE
  365.       IF (MOMATE.NE.0) THEN
  366.         nomid = MOMATE
  367.         SEGSUP,nomid
  368.       ENDIF
  369.       IF (MOTYPE.NE.0) THEN
  370.         notype = MOTYPE
  371.         SEGSUP,notype
  372.       ENDIF
  373.       IF (MOCPHA.NE.0) THEN
  374.         nomid = MOCPHA
  375.         SEGSUP,nomid
  376.       ENDIF
  377.       IF (IPCPHA.NE.0) THEN
  378.         CALL DTCHAM(IPCPHA)
  379.       ENDIF
  380.  
  381.       RETURN
  382.       END
  383.  
  384.  
  385.  
  386.  
  387.  

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