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

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