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

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