Télécharger la plaquette Cast3M


fr en

Télécharger tadve1.eso

Retour à la liste

Numérotation des lignes : 

tadve1

  1. C TADVE1    SOURCE    OF166741  25/02/21    21:18:42     12166          
  2.  
  3. ************************************************************************
  4. *
  5. *                             T A D V E 1
  6. *                             -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *     CREATION DE LA MATRICE DE ADVECTION
  11. *     GESTION DES SEGMENTS ET TESTS DE COMPATIBILITE
  12. *
  13. * PARAMETRES:  (E)=ENTREE    (S)=SORTIE
  14. * -----------
  15. *     MMODEL   (E)  POINTEUR SUR LE SEGMENT MMODEL
  16. *     IPCHEL   (E)  POINTEUR SUR LE SEGMENT MCHELM
  17. *     IPRIGI   (S)  POINTEUR SUR LE SEGMENT MRIGID
  18. *
  19. * AUTEUR, DATE DE CREATION:
  20. * -------------------------
  21. *      MARINO ARROYO, 18 MAI 1999
  22. *
  23. * LANGAGE:
  24. * --------
  25. *     ESOPE + FORTRAN77
  26. *
  27. ************************************************************************
  28.  
  29.       SUBROUTINE TADVE1 (MMODEL,IPCHEL,IPRIGI,ISYMM)
  30.  
  31.       IMPLICIT INTEGER(I-N)
  32.       IMPLICIT REAL*8(A-H,O-Z)
  33.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC CCHAMP
  37.  
  38. -INC SMCOORD
  39. -INC SMCHAML
  40. -INC SMELEME
  41. -INC SMINTE
  42. -INC SMMODEL
  43.       POINTEUR nomid1.NOMID
  44. -INC SMRIGID
  45.  
  46. -INC TMPTVAL
  47.  
  48.       INTEGER OOOVAL
  49.  
  50.       SEGMENT NOTYPE
  51.         CHARACTER*16 TYPE(NBTYPE)
  52.       ENDSEGMENT
  53.  
  54.       PARAMETER ( NINF=3 )
  55.       INTEGER INFOS(NINF)
  56.  
  57.       CHARACTER*8 CMATE
  58.       CHARACTER*(LCONMO) CONM
  59.       CHARACTER*10 PEAU
  60.       CHARACTER*4 MOTADV
  61.  
  62.       PARAMETER ( NFO1=3 )
  63.       CHARACTER*16 MOTFOR,MOTFO1(NFO1)
  64.       DATA MOTFO1 /'THERMIQUE' , 'DIFFUSION','NAVIER_STOKES'/
  65.       MACRO,(THERMIQUE,DIFFUSION)
  66.       DATA MOTADV /'ADVE'/
  67.  
  68.       PARAMETER ( LNUCOQ=5 , LINUM=14 , LINUC=12 )
  69.       INTEGER INUCOQ(LNUCOQ), INUMA(LINUM), INUCO(LINUC)
  70. *
  71. *                TRI3 TRI6 QUA4 QUA8 CUB8 CU20 PRI6 PR15
  72.       DATA INUMA/   4,   6,   8,  10,  14,  15,  16,  17,
  73. *                TET4 TET10 PYR5 PY13 TRI7 QUA9
  74.      &             23,   24,  25,  26, 144, 145/
  75. *                 SEG2 SEG3 TRI3 TRI6 QUA4 QUA8
  76.       DATA INUCO /   2,   3,   4,   6,   8,  10,
  77. *                 RAC2 RAC3 LIA3 LIA6 LIA4 LIA8
  78.      &             12, 13,  18,  19,   20, 21 /
  79. *                  COQ2  COQ3  COQ6 COQ4 COQ8
  80.       DATA INUCOQ / 44 , 27  , 56 , 49  ,41 /
  81.  
  82.       IPRIGI = 0
  83. C---
  84. C Verification du lieu support du MCHAML de caracteristiques
  85. C---
  86.       CALL QUESUP(MMODEL,IPCHEL,6,0,ISUPCH,IRET)
  87.       IF (ISUPCH.GT.1) RETURN
  88.  
  89. C---
  90. C Initialisation de la matrice d'ADVECTION (chapeau de l'objet RIGIDITE)
  91. C---
  92.       NRIGEL = 0
  93.       SEGINI,MRIGID
  94.       MTYMAT = 'RIGIDITE'
  95.       ICHOLE = 0
  96.       IMGEO1 = 0
  97.       IMGEO2 = 0
  98.       IFORIG = IFOUR
  99.       ISUPEQ = 0
  100.  
  101. c en cas de besoin
  102.            L1 = 8
  103.            n1 = 1
  104.            segini mmode1
  105.            mchelm = ipchel
  106.            n3 = infche(/2)
  107.            segini mchel1
  108.            mchel1.ifoche = ifoche
  109.            n2 = 1
  110.            segini mcham1
  111.            mchel1.ichaml(1) = mcham1
  112. C---
  113. C BOUCLE SUR LES MODELES ELEMENTAIRES
  114. C---
  115.       NB_OK = 0
  116.       DO 10 III = 1, MMODEL.KMODEL(/1)
  117.         IPINTE = 0
  118.         IPINT1 = 0
  119.         MOMATE = 0
  120.         MOTYPE = 0
  121.  
  122. C- Recuperation du sous-modele et de la zone elementaire associee
  123.         IMODEL = MMODEL.KMODEL(III)
  124.         MOTFOR = IMODEL.FORMOD(1)
  125.         NMAT   = IMODEL.MATMOD(/2)
  126.  
  127. C- Selection uniquement des SOUS-MODELES qui nous interessent
  128.         CALL PLACE(MOTFO1,NFO1,ityp1,MOTFOR)
  129.         IF (ityp1 .EQ. 0) GOTO 10
  130.  
  131.         if (ityp1.le.2) then
  132.         CALL PLACE(IMODEL.MATMOD,NMAT,iok3,'ADVECTION       ')
  133.         else
  134.         CALL PLACE(IMODEL.MATMOD,NMAT,iok3,'NLIN            ')
  135.         endif
  136.         IF (iok3 .EQ. 0) GOTO 10
  137.  
  138.         NB_OK = NB_OK + 1
  139.  
  140. C- Recuperation d'informations sur le maillage elementaire
  141.         IPT1   = IMAMOD
  142.         NBNOE1 = IPT1.NUM(/1)
  143.         NBELE1 = IPT1.NUM(/2)
  144.         IF(NEFMOD.EQ.269 .OR. NEFMOD.EQ.270) THEN
  145.           ITUY = 1
  146.         ELSE
  147.           ITUY = 0
  148.         ENDIF
  149.  
  150. C- Quelques informations et verifications sur le modele elementaire
  151.         CONM  = CONMOD
  152.         CMATE = CMATEE
  153.         MATE  = IMATEE
  154.  
  155. C       Seule l'isotropie est disponible en 2D PLAN et AXISYMETRIQUE
  156.         if(ituy.ne.1.and.ityp1.lt.3) then
  157.           IF (MATE.EQ.1) THEN
  158.             IF (IFOMOD.EQ.1) THEN
  159.               WRITE(IOIMP,*) '### ERREUR DANS ADVE : ',
  160.      &                      'LE CAS FOURIER N''EST PAS PRIS EN COMPTE'
  161.               CALL ERREUR(19)
  162.               GOTO 1999
  163.             ENDIF
  164. C         ELSE
  165. C            WRITE(IOIMP,*) '### ERREUR DANS ADVE : ',
  166. C     &                   'SEULEMENT LE CAS ISOTROPE EST ENVISAGE'
  167. C            CALL ERREUR(19)
  168. C            GOTO 1999
  169.           ENDIF
  170.         endif
  171. *
  172.         IRET = 1
  173.         CALL IDENT(IPT1,CONM,IPCHEL,0, INFOS,IRET)
  174.         IF (IRET.EQ.0) GOTO 1999
  175. *
  176.         NEF  = NEFMOD
  177.         ICOQ = 0
  178.         CALL PLACE2(INUCOQ,LNUCOQ,ICOQ,NEF)
  179.         IMAS = 0
  180.         CALL PLACE2(INUMA,LINUM,IMAS,NEF)
  181.         IF (IMAS.EQ.0.and . ituy.eq.0) THEN
  182.           WRITE(IOIMP,*) '### ERREUR DANS ADVE : ',
  183.      &          'SEULS LES ELEMENTS FINIS MASSIFS SONT ENVISAGES'
  184.           CALL ERREUR(19)
  185.           GOTO 1999
  186.         ENDIF
  187.  
  188.  
  189. C- Recuperation des noms des composantes du champ vectoriel (obligatoires)
  190.  
  191.         if( ituy.eq.0) then
  192.          if (ityp1.eq.3) then
  193.            nbrobl = 1
  194.            nbrfac = 0
  195.            segini,nomid
  196.            lesobl(1) = motadv
  197.          else
  198. C         Curieux ici on ne tient pas compte en AXISYMETRIE et autres cas        
  199.           nbrobl = IDIM
  200.           nbrfac = 0
  201.           SEGINI,nomid
  202.           IF (IDIM.EQ.1) THEN
  203.             lesobl(1) = 'VITX'
  204.           ELSE IF (IDIM.EQ.2) THEN
  205.             lesobl(1) = 'VITX'
  206.             lesobl(2) = 'VITY'
  207. c*        ELSE IF (IDIM.EQ.3) THEN
  208.           ELSE
  209.             lesobl(1) = 'VITX'
  210.             lesobl(2) = 'VITY'
  211.             lesobl(3) = 'VITZ'
  212.           ENDIF
  213.          endif
  214.  
  215.         else
  216.           CASE, ityp1
  217.           WHEN,THERMIQUE
  218.             nbrobl = 4
  219.             nbrfac = 0
  220.             SEGINI,nomid
  221.             lesobl(1)='VITE'
  222.             lesobl(2)='RHO'
  223.             lesobl(3)='C'
  224.             lesobl(4)='SECT'
  225.  
  226.           WHEN,DIFFUSION
  227.             nbrobl = 3
  228.             nbrfac = 0
  229.             SEGINI,nomid
  230.             lesobl(1)='VITE'
  231.             lesobl(2)='CDIF'
  232.             lesobl(3)='SECT'
  233.           ENDCASE
  234.         endif
  235.         NMATO  = lesobl(/2)
  236.         NMATF  = lesfac(/2)
  237.         NMATT  = NMATO + NMATF
  238.         MOMATE = nomid
  239.  
  240.         nbtype = 1
  241.         SEGINI,notype
  242.         if (ityp1.eq.3) then
  243.           type(1) = 'POINTEURCHPOINT'
  244.         else
  245.           type(1)='REAL*8'
  246.         endif
  247.         MOTYPE = notype
  248.  
  249.        if (ityp1.lt.3) then
  250. C- Recuperation d'informations sur l'element fini
  251.         CALL TSHAPE(NEF,'GAUSS',IPINTE)
  252.         IF (IERR.NE.0) GOTO 1999
  253.         MINTE = IPINTE
  254.         SEGACT,MINTE
  255.  
  256. C- Definition du descripteur IDESCR
  257.         IDESCR = 0
  258.         IF (ICOQ.NE.0 .AND. IF1.NE.0) THEN
  259.           PEAU = '          '
  260.           IF (MATMOD(/1) .NE. 0) PEAU = MATMOD(1)
  261.           CALL TCONV2(ICOQ,PEAU,NBNOE1,IDESCR)
  262.         ELSE
  263.           NOMPRI = LNOMID(1)
  264.           NOMDUA = LNOMID(2)
  265.           CALL TCOND2(ICOQ,NBNOE1,IDESCR,NOMPRI,NOMDUA)
  266.         ENDIF
  267.         descr = IDESCR
  268.         SEGACT,descr
  269.         NLIGRD = LISDUA(/2)
  270.         NLIGRP = LISINC(/2)
  271.         SEGDES,descr
  272.         LRE = NLIGRP
  273.  
  274.        else
  275.         LRE = 3*NBNOE1
  276.        endif
  277.  
  278.  
  279. C- Partionnement si necessaire de la matrice de conductivite
  280. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  281.         LTRK = oooval(1,4)
  282.         IF (LTRK.EQ.0) LTRK = oooval(1,1)
  283.       LTRK=MAX(LTRK,2**24)
  284. * Ajout a la taille en mots de la matrice des infos du segment
  285.         LSEG = LRE*LRE*NBELE1 + 16
  286.         NBLPRT = (LSEG-1)/LTRK + 1
  287.         NBLMAX = (NBELE1-1)/NBLPRT + 1
  288.         NBLPRT = (NBELE1-1)/NBLMAX + 1
  289. *       write(ioimp,*) ' tadve1 : nblprt nblmax = ',nblprt,nblmax,nbele1
  290.  
  291. C- Ajout de la matrice d'ADVECTION a la matrice globale
  292.         NRIGE0 = IRIGEL(/2)
  293.         NRIGEL = NRIGE0 + NBLPRT
  294.         if (ityp1.eq.3) nrigel = nrigel + (idim - 1)*nblprt
  295.         SEGADJ,MRIGID
  296.  
  297.         descr  = IDESCR
  298.         meleme = IPT1
  299.         nbnn   = NBNOE1
  300.         nbelem = NBELE1
  301.         nbsous = 0
  302.         nbref  = 0
  303.  
  304. C====
  305. C Boucle sur les PARTITIONS elementaires de la matrice
  306. C====
  307.         DO 200 irige = 1, NBLPRT
  308.           IF (NBLPRT.GT.1) THEN
  309. C-- Partitionnement du maillage support de la matrice elementaire
  310.             ielem = (irige-1)*NBLMAX
  311.             nbelem = MIN(NBLMAX,NBELE1-ielem)
  312. *            write(ioimp,*) 'tadve1 : creation segment ',nbnn,nbelem
  313.             SEGINI,meleme
  314.             itypel = IPT1.itypel
  315.             DO ielt = 1, nbelem
  316.               jelt = ielt + ielem
  317.               DO inoe = 1, nbnn
  318.                 num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  319.               ENDDO
  320.               icolor(ielt) = IPT1.ICOLOR(jelt)
  321.             ENDDO
  322. C-- Recopie du descripteur
  323.             des1 = IDESCR
  324.             SEGINI,descr=des1
  325.             SEGDES,descr
  326.           ENDIF
  327.           ipmail = meleme
  328.           ipdesc = descr
  329.  
  330. C-- Recuperation des valeurs des caracteristiques necessaires
  331.           IVAMAT = 0
  332.           CALL KOMCHA(IPCHEL,ipmail,CONM,MOMATE,MOTYPE,1,INFOS,3,IVAMAT)
  333.           IF (IERR.NE.0) GOTO 2999
  334.           IF (ISUPCH.EQ.1) THEN
  335.             CALL VALCHE(IVAMAT,NMATT,IPINTE,0,MOMATE,NEF)
  336.             IF (IERR.NE.0) THEN
  337.               ISUPCH = 0
  338.               GOTO 2999
  339.             ENDIF
  340.           ENDIF
  341.  
  342.           if (ityp1.eq.3) then
  343.            segact mmode1*mod
  344.            mmode1.kmodel(1) = imodel
  345.            mchel1.conche(1) = conm
  346.            mchel1.imache(1) = ipmail
  347.            mptval = ivamat
  348.            do jj = 1,n2
  349.              mcham1.nomche(1) = motadv
  350.              mcham1.typche(1) = tyval(1)
  351.              mcham1.ielval(1) = ival(1)
  352.            enddo
  353.  
  354.            ipmons = mmode1
  355.            ipchns = mchel1
  356.            call go2nli(ipmons,ipchns,iprins,4)
  357.            if (ierr.ne.0) return
  358.  
  359.            goto 2999
  360.           endif 
  361.  
  362.  
  363. C-- Initialisation de la matrice de rigidite elementaire (xmatri)
  364.           NELRIG = nbelem
  365.           SEGINI,xmatri
  366.           ipmatr = xmatri
  367.  
  368. C-- Calcul de la matrice elementaire pour la zone irige (ipmail) et
  369. C-- Remplissage de la matrice globale (ipmatr)
  370. C Note : actuellement uniquement les elements massifs
  371.        if(imas.ne.0) then
  372.           CALL TADVE8(NEF,ipmail,IPINTE,MATE,IVAMAT,NMATT,ISYMM,
  373.      &                  ipmatr,LRE)
  374.        elseif(ituy.ne.0) then
  375.          call adtuy(nef,ipmail,ipinte,mate,ivamat,nmatt, ipmatr,
  376.      &        lre)
  377.        else
  378.           call erreur(19)
  379.        endif
  380. C-- Un peu de menage dans les segments
  381.  2999     CONTINUE
  382.           IF (ISUPCH.EQ.1 .OR. NBLPRT.NE.1) THEN
  383.             CALL DTMVAL(IVAMAT,3)
  384.           ELSE
  385.             CALL DTMVAL(IVAMAT,1)
  386.           ENDIF
  387. C-- Sortie prematuree en cas d'erreur
  388.           IF (IERR.NE.0) GOTO 1999
  389.  
  390.           xmatri = ipmatr
  391.           IF (NBLPRT.GT.1) THEN
  392.             meleme = ipmail
  393.           ENDIF
  394.          if (ityp1.eq.3) then
  395.            RI3 = iprins
  396.            segact ri3 
  397.            if (ri3.coerig(/1).ne.idim) then
  398.              call erreur(5)
  399.              return
  400.            endif
  401.            do kige = 1,IDIM
  402.              ipdesc = ri3.IRIGEL(3,kige)
  403.              ipmatr = ri3.IRIGEL(4,kige)
  404.              isymm = ri3.irigel(7,kige)
  405.  
  406.           jrige = NRIGE0 + kige
  407.           COERIG(jrige)   = ri3.coerig(kige)
  408.           IRIGEL(1,jrige) = ipmail
  409.           IRIGEL(2,jrige) = 0
  410.           IRIGEL(3,jrige) = ipdesc
  411.           IRIGEL(4,jrige) = ipmatr
  412.           IRIGEL(5,jrige) = NIFOUR
  413.           IRIGEL(6,jrige) = 0
  414.           IRIGEL(7,jrige) = 0
  415.           IRIGEL(7,jrige) = ri3.irigel(7,kige)
  416.           IRIGEL(8,jrige) = 0
  417.            enddo
  418.          else
  419. C-- Stockage de la matrice
  420.           jrige = NRIGE0 + irige
  421.           COERIG(jrige)   = 1.
  422.           IRIGEL(1,jrige) = ipmail
  423.           IRIGEL(2,jrige) = 0
  424.           IRIGEL(3,jrige) = ipdesc
  425.           IRIGEL(4,jrige) = ipmatr
  426.           IRIGEL(5,jrige) = NIFOUR
  427.           IRIGEL(6,jrige) = 0
  428.           IRIGEL(7,jrige) = 0
  429.           IF (ISYMM.NE.1) IRIGEL(7,jrige) = 2
  430.           xmatri.symre=irigel(7,jrige)
  431.           SEGDES,xmatri
  432.           IRIGEL(8,jrige) = 0
  433.         endif
  434.  
  435.  200    CONTINUE
  436. C====
  437. C FIN DE LA BOUCLE SUR LES PARTITIONS
  438. C====
  439.  
  440. C- Un peu de menage dans les segments
  441.  1999   CONTINUE
  442.         IF (MOMATE.NE.0) THEN
  443.           nomid = MOMATE
  444.           SEGSUP,nomid
  445.         ENDIF
  446.         IF (MOTYPE.NE.0) THEN
  447.           notype = MOTYPE
  448.           SEGSUP,notype
  449.         ENDIF
  450.         IF (IERR.NE.0) GOTO 999
  451.  10   CONTINUE
  452. C---
  453. C FIN DE LA BOUCLE SUR LES MODELES ELEMENTAIRES
  454. C---
  455.       IF(NB_OK .EQ. 0)THEN
  456.         MOTERR='ADVECTION'
  457.         CALL ERREUR(719)
  458.         RETURN
  459.       ENDIF
  460.  
  461.       IPRIGI = MRIGID
  462.       SEGDES,MRIGID
  463.  
  464.       segsup mmode1,mchel1,mcham1
  465.  
  466.  999  CONTINUE
  467.       RETURN
  468.       END
  469.  
  470.  
  471.  

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